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

Start on ARM64

Browse source 
Copy stuff from arm32 changing 'arm' to 'arm64'.
This commit is contained in:
Stas Boukarev 2015-06-02 20:31:14 +00:00
parent 1b1e95d6a1
commit d576cb5608
60 changed files with 12427 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
build-order.lisp-expr
View file

@ -252,6 +252,7 @@
#!+alpha ("src/code/alpha-vm" :not-host)
#!+mips ("src/code/mips-vm" :not-host)
#!+arm ("src/code/arm-vm" :not-host)
#!+arm64 ("src/code/arm64-vm" :not-host)
;; FIXME: do we really want to keep this? -- CSR, 2002-08-31
#!+rt ("src/code/rt-vm" :not-host)

11
make-config.sh
View file

@ -733,6 +733,17 @@ elif [ "$sbcl_arch" = "arm" ]; then
printf ' :stack-allocatable-vectors :stack-allocatable-closures' >> $ltf
printf ' :precise-arg-count-error :unwind-to-frame-and-call-vop' >> $ltf
printf ' :fp-and-pc-standard-save' >> $ltf
elif [ "$sbcl_arch" = "arm64" ]; then
printf ' :gencgc' >> $ltf
# printf ' :gencgc :linkage-table :alien-callbacks' >> $ltf
# # As opposed to soft-float or FPA, we support VFP only (and
# # possibly VFPv2 and higher only), but we'll leave the obvious
# # hooks in for someone to add the support later.
printf ' :arm-vfp :arm-vfpv2' >> $ltf
# printf ' :ash-right-vops :multiply-high-vops :symbol-info-vops' >> $ltf
# printf ' :stack-allocatable-lists :stack-allocatable-fixed-objects' >> $ltf
# printf ' :stack-allocatable-vectors :stack-allocatable-closures' >> $ltf
# printf ' :precise-arg-count-error :unwind-to-frame-and-call-vop' >> $ltf
else
# Nothing need be done in this case, but sh syntax wants a placeholder.
echo > /dev/null

3
src/assembly/arm64/alloc.lisp Normal file
View file

@ -0,0 +1,3 @@
(in-package "SB!VM")
;;; Dummy placeholder file.

58
src/assembly/arm64/arith.lisp Normal file
View file

@ -0,0 +1,58 @@
;;;; stuff to handle simple cases for generic arithmetic
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; division
(define-assembly-routine (signed-truncate
(:note "(signed-byte 32) truncate")
(:cost 60)
(:policy :fast-safe)
(:translate truncate)
(:arg-types signed-num signed-num)
(:result-types signed-num signed-num))
((:arg dividend signed-reg nl2-offset)
(:arg divisor signed-reg nargs-offset)
(:res quo signed-reg nl2-offset)
(:res rem signed-reg nl3-offset)
(:temp quo-sign non-descriptor-reg ocfp-offset)
(:temp rem-sign descriptor-reg r8-offset))
(inst eor quo-sign dividend divisor)
(inst bic rem-sign dividend fixnum-tag-mask)
(inst mov rem 0)
(inst tst divisor divisor)
(let ((error (generate-error-code nil 'division-by-zero-error
dividend divisor)))
(inst b :eq error))
(inst rsb :mi divisor divisor 0)
(inst tst dividend dividend)
(inst rsb :mi dividend dividend 0)
(dotimes (i 33)
(inst cmp rem divisor)
(inst sub :hs rem rem divisor)
(inst adcs quo quo quo)
(unless (= i 32)
(inst adc rem rem rem)))
;; If the quo-sign is negative, we need to negate quo.
(inst tst quo-sign quo-sign)
(inst rsb :mi quo quo 0)
;; If the rem-sign is negative, we need to negate rem.
(inst tst rem-sign rem-sign)
(inst rsb :mi rem rem 0))

91
src/assembly/arm64/array.lisp Normal file
View file

@ -0,0 +1,91 @@
;;;; various array operations that are too expensive (in space) to do
;;;; inline
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(define-assembly-routine (allocate-vector-on-heap
(:policy :fast-safe)
(:arg-types positive-fixnum
positive-fixnum
positive-fixnum))
((:arg type any-reg r0-offset)
(:arg length any-reg r1-offset)
(:arg words any-reg r2-offset)
(:res result descriptor-reg r0-offset)
(:temp ndescr non-descriptor-reg nl2-offset)
(:temp pa-flag non-descriptor-reg ocfp-offset)
(:temp vector descriptor-reg r8-offset))
;; Why :LINK NIL?
;; Either LR or PC need to always point into the code object.
;; Since this is a static assembly routine, PC is already not pointing there.
;; But it's called using blx, so LR is still good.
;; Normally PSEUDO-ATOMIC calls do_pending_interrupt using BLX too,
;; which will make LR point here, now GC can collect the parent function away.
;; But the call to do_pending_interrupt is at the end, and there's
;; nothing more needed to be done by the routine, so
;; do_pending_interrupt can return to the parent function directly.
;; This still uses the normal :return-style, BX LR, since the call
;; to do_pending_interrupt interrupt is conditional.
(pseudo-atomic (pa-flag :link nil)
;; boxed words == unboxed bytes
(inst add ndescr words (* (1+ vector-data-offset) n-word-bytes))
(inst bic ndescr ndescr lowtag-mask)
(allocation vector ndescr other-pointer-lowtag :flag-tn pa-flag)
(inst mov ndescr (lsr type word-shift))
(storew ndescr vector 0 other-pointer-lowtag)
;; Touch the last element, to ensure that null-terminated strings
;; passed to C do not cause a WP violation in foreign code.
;; Do that before storing length, since nil-arrays don't have any
;; space, but may have non-zero length.
#!-gencgc
(inst mov ndescr 0)
#!-gencgc
(storew ndescr pa-flag -1)
(storew length vector vector-length-slot other-pointer-lowtag)
(move result vector)))
(define-assembly-routine (allocate-vector-on-stack
(:policy :fast-safe)
(:arg-types positive-fixnum
positive-fixnum
positive-fixnum))
((:arg type any-reg r0-offset)
(:arg length any-reg r1-offset)
(:arg words any-reg r2-offset)
(:res result descriptor-reg r0-offset)
(:temp ndescr non-descriptor-reg nl2-offset)
(:temp pa-flag non-descriptor-reg ocfp-offset)
(:temp vector descriptor-reg r8-offset))
;; See why :LINK NIL is needed in ALLOCATE-VECTOR-ON-HEAP above.
(pseudo-atomic (pa-flag :link nil)
;; boxed words == unboxed bytes
(inst add ndescr words (* (1+ vector-data-offset) n-word-bytes))
(inst bic ndescr ndescr lowtag-mask)
(allocation vector ndescr other-pointer-lowtag
:flag-tn pa-flag
:stack-allocate-p t)
(inst mov pa-flag (lsr type word-shift))
(storew pa-flag vector 0 other-pointer-lowtag)
;; Zero fill
(let ((loop (gen-label)))
(inst sub result vector (- other-pointer-lowtag n-word-bytes))
;; The header word has already been set, skip it.
(inst sub ndescr ndescr (fixnumize 1))
(inst mov pa-flag 0)
(emit-label loop)
(inst str pa-flag (@ result n-word-bytes :post-index))
(inst subs ndescr ndescr (fixnumize 1))
(inst b :gt loop))
(storew length vector vector-length-slot other-pointer-lowtag)
(move result vector)))

230
src/assembly/arm64/assem-rtns.lisp Normal file
View file

@ -0,0 +1,230 @@
(in-package "SB!VM")
;;;; Return-multiple with other than one value
#+sb-assembling ;; we don't want a vop for this one.
(define-assembly-routine
(return-multiple
(:return-style :none))
;; These four are really arguments.
((:temp nvals any-reg nargs-offset)
(:temp vals any-reg ocfp-offset)
(:temp old-fp any-reg nl2-offset)
(:temp lra descriptor-reg lexenv-offset)
;; These are just needed to facilitate the transfer
(:temp count any-reg nfp-offset)
(:temp src any-reg code-offset)
(:temp dst descriptor-reg r8-offset)
;; These are needed so we can get at the register args.
(:temp r0 descriptor-reg r0-offset)
(:temp r1 descriptor-reg r1-offset)
(:temp r2 descriptor-reg r2-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
;; helps overmuch).
;; If there are more return values than there are arg-passing
;; registers, then we need to arrange for the excess values to be
;; moved.
(inst cmp nvals (fixnumize 3))
(inst b :gt MOVE-STACK-VALUES)
;; We don't need to copy stack values at this point, so default any
;; unsupplied values that should be in arg-passing registers. First
;; piece of black magic: A computed jump.
(inst add pc-tn pc-tn nvals)
;; Eat a word of padding for the computed jump.
(inst word 0)
;; The computed jump above will land on one of the next four
;; instructions, based on the number of values to return.
(inst mov r0 null-tn)
(inst mov r1 null-tn)
(inst mov r2 null-tn)
;; We've defaulted any unsupplied parameters, but now we need to
;; load the supplied parameters. Second piece of black magic: A
;; hairier computed jump.
(inst rsb count nvals (fixnumize 2))
(inst add pc-tn pc-tn count)
;; The computed jump above will land on one of the next four
;; instructions, based on the number of values to return, in reverse
;; order.
(inst ldr r2 (@ vals (* 2 n-word-bytes)))
;; If we need to copy stack values, we land here so as to load the
;; first two register values (the third will be loaded after the
;; values are copied, due to register pressure).
MOVE-STACK-VALUES
(inst ldr r1 (@ vals n-word-bytes))
(inst ldr r0 (@ vals))
;; The last instruction to set the flags was the CMP to check to see
;; if we needed to move the values on the stack. If we do not need
;; to move the values on the stack then we're almost done.
(inst b :le DONE)
;; Copy the remaining args (including the future R2 register value)
;; over the outbound stack frame.
(inst add src vals (* 2 n-word-bytes))
(inst add dst cfp-tn (* 2 n-word-bytes))
(inst sub count nvals (fixnumize 2))
LOOP
(inst subs count count (fixnumize 1))
(inst ldr r2 (@ src n-word-bytes :post-index))
(inst str r2 (@ dst n-word-bytes :post-index))
(inst b :ge LOOP)
;; Load the last remaining register result.
(inst ldr r2 (@ cfp-tn (* 2 n-word-bytes)))
DONE
;; Deallocate the unused stack space.
(move ocfp-tn cfp-tn)
(move cfp-tn old-fp)
(inst add dst ocfp-tn nvals)
(store-csp dst)
;; Return.
(lisp-return lra :multiple-values))
;;;; tail-call-variable.
#+sb-assembling ;; no vop for this one either.
(define-assembly-routine
(tail-call-variable
(:return-style :none))
;; These are really args.
((:temp args any-reg nl2-offset)
(:temp lexenv descriptor-reg lexenv-offset)
;; We need to compute this
(:temp nargs any-reg nargs-offset)
;; These are needed by the blitting code.
(:temp dest any-reg nl2-offset) ;; Not live concurrent with ARGS.
(:temp count any-reg nl3-offset)
(:temp temp descriptor-reg r8-offset)
(:temp stack-top non-descriptor-reg ocfp-offset)
;; These are needed so we can get at the register args.
(:temp r0 descriptor-reg r0-offset)
(:temp r1 descriptor-reg r1-offset)
(:temp r2 descriptor-reg r2-offset))
;; We're in a tail-call scenario, so we use the existing LRA and
;; OCFP, both already set up in the stack frame. We have a set of
;; arguments, represented as the address of the first argument
;; (ARGS) and the address just beyond the last argument (CSP-TN),
;; and need to set up the arg-passing-registers (R0, R1, and R2),
;; any stack arguments (the fourth and subsequent arguments, if such
;; exist), and the total arg count (NARGS).
;; Calculate NARGS (as a fixnum)
(load-csp nargs)
(inst sub nargs nargs args)
;; Load the argument regs (must do this now, 'cause the blt might
;; trash these locations, and we need ARGS to be dead for the blt)
(loadw r0 args 0)
(loadw r1 args 1)
(loadw r2 args 2)
;; ARGS is now dead, we access the remaining arguments by offset
;; from CSP-TN.
;; Figure out how many arguments we really need to shift.
(inst subs count nargs (fixnumize register-arg-count))
;; If there aren't any stack args then we're done.
(inst b :le DONE)
;; Find where our shifted arguments ned to go.
(inst add dest cfp-tn nargs)
;; And come from.
(load-csp stack-top)
LOOP
;; Copy one arg.
(inst ldr temp (@ stack-top (- count)))
(inst str temp (@ dest (- count)))
(inst subs count count n-word-bytes)
(inst b :ne LOOP)
DONE
;; 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), and R8 (known as TEMP) and, technically, CODE happen
;; to be the only ones available.
(loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
(lisp-jump temp))
;;;; Non-local exit noise.
(define-assembly-routine (throw
(:return-style :none))
((:arg target descriptor-reg r0-offset)
(:arg start any-reg r8-offset)
(:arg count any-reg nargs-offset)
(:temp catch any-reg r1-offset)
(:temp tag descriptor-reg r2-offset))
(declare (ignore start count))
(load-symbol-value catch *current-catch-block*)
LOOP
(let ((error (generate-error-code nil 'unseen-throw-tag-error target)))
(inst cmp catch 0)
(inst b :eq error))
(loadw tag catch catch-block-tag-slot)
(inst cmp tag target)
(loadw catch catch catch-block-previous-catch-slot 0 :ne)
(inst b :ne LOOP)
;; As a dreadful cleverness, make use of the fact that assembly
;; routines are emitted in order, with no padding, and that the body
;; of UNWIND follows to arrange for the stack to be unwound to our
;; chosen destination.
(move target catch) ;; TARGET coincides with UNWIND's BLOCK argument
)
(define-assembly-routine (unwind
(:return-style :none)
(:translate %continue-unwind)
(:policy :fast-safe))
((:arg block (any-reg descriptor-reg) r0-offset)
(:arg start (any-reg descriptor-reg) r8-offset)
(:arg count (any-reg descriptor-reg) nargs-offset)
(:temp ocfp non-descriptor-reg ocfp-offset)
(:temp lra descriptor-reg lexenv-offset)
(:temp cur-uwp any-reg nl2-offset))
(declare (ignore start count))
(let ((error (generate-error-code nil 'invalid-unwind-error)))
(inst cmp block 0)
(inst b :eq error))
(load-symbol-value cur-uwp *current-unwind-protect-block*)
(loadw ocfp block unwind-block-current-uwp-slot)
(inst cmp cur-uwp ocfp)
(loadw ocfp cur-uwp unwind-block-current-uwp-slot 0 :ne)
(store-symbol-value ocfp *current-unwind-protect-block* :ne)
(move cur-uwp block :eq)
(loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
(loadw code-tn cur-uwp unwind-block-current-code-slot)
(loadw lra cur-uwp unwind-block-entry-pc-slot)
(lisp-return lra :known))

80
src/assembly/arm64/support.lisp Normal file
View file

@ -0,0 +1,80 @@
;;;; the machine-specific support routines needed by the file assembler
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(defun generate-call-sequence (name style vop options)
(declare (ignore options))
(ecase style
((:none :raw)
(let ((fixup-address (make-symbol "FIXUP-ADDRESS")))
(values
`((let ((,fixup-address (gen-label)))
,@(if (eq style :none)
`((inst load-from-label pc-tn lr-tn ,fixup-address))
`((inst load-from-label lr-tn lr-tn ,fixup-address)
(inst blx lr-tn)))
(assemble (*elsewhere* ,vop)
(emit-label ,fixup-address)
(inst word (make-fixup ',name :assembly-routine)))))
nil)))
#+(or)
(:full-call
(let ((temp (make-symbol "TEMP"))
(jump (make-symbol "JUMP"))
(nfp-save (make-symbol "NFP-SAVE"))
(lra (make-symbol "LRA")))
(values
`((let ((lra-label (gen-label))
(cur-nfp (current-nfp-tn ,vop)))
(when cur-nfp
(store-stack-tn ,nfp-save cur-nfp))
(inst compute-lra-from-code ,lra code-tn lra-label ,temp)
(note-next-instruction ,vop :call-site)
(inst lr ,jump (make-fixup ',name :assembly-routine))
(inst mtlr ,jump)
(inst blr)
(emit-return-pc lra-label)
(note-this-location ,vop :single-value-return)
(without-scheduling ()
(move csp-tn ocfp-tn)
(inst nop))
(inst compute-code-from-lra code-tn lra-tn
lra-label ,temp)
(when cur-nfp
(load-stack-tn cur-nfp ,nfp-save))))
`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
,temp)
(:temporary (:sc descriptor-reg :offset lra-offset
:from (:eval 0) :to (:eval 1))
,lra)
(:temporary (:scs (control-stack) :offset nfp-save-offset)
,nfp-save)
(:temporary (:sc any-reg) ,jump)
(:save-p :compute-only)))))))
(defun generate-return-sequence (style)
(ecase style
(:raw
`((inst bx lr-tn)))
#+(or)
(:full-call
`((lisp-return (make-random-tn :kind :normal
:sc (sc-or-lose 'descriptor-reg )
:offset lra-offset)
(make-random-tn :kind :normal
:sc (sc-or-lose 'interior-reg )
:offset lip-offset)
:offset 2)))
(:none)))
(defun return-machine-address (scp)
(context-register scp lr-offset))

7
src/bootstrap.lisp Normal file
View file

@ -0,0 +1,7 @@
(in-package "SB!KERNEL")
(defun bar (x)
(values x #. (coerce "Hello World" 'simple-base-string)))
(defun !cold-init ()
(cons 20 30))

547
src/bootstrap.trace Normal file
View file

@ -0,0 +1,547 @@
;;;; component: "top level form"
IR1 block 0 start c1
start stack:
1> bind SB!C::CLAMBDA (SB!C::TOP-LEVEL-FORM NIL) :KIND :TOPLEVEL
2> 3: FIND-UNDELETED-PACKAGE-OR-LOSE {GLOBAL-FUNCTION}
4> 5: '"SB!KERNEL"
6> 7: known combination v3 v5
8> set *PACKAGE* {SPECIAL} v7
9> 10: 'NIL
11> return v10 SB!C::CLAMBDA (SB!C::TOP-LEVEL-FORM NIL)
end stack:
successors c12
;;;; IR2 component: "top level form"
entries:
L1: (SB!C::TOP-LEVEL-FORM NIL)
TNs: 17 local, 12 temps, 4 constant, 2 env, 0 comp, 2 global.
Wired: 21, Unused: 0. 1 block, 4 global conflicts.
IR1 block 3 start c12
IR2 block NIL start c12
IR1 block 0 start c1
IR2 block 0 start c1
0: XEP-ALLOCATE-FRAME {#<SB!ASSEM:LABEL 1>}
1: XEP-SETUP-SP
2: MOVE t1[CS0]>t2[NL0] => t3[CS0]<t4[NL0]
3: MOVE t5[CS1]>t6[R0] => t7[CS1]<t8[R0]
4: NOTE-ENVIRONMENT-START {#<SB!ASSEM:LABEL 2>}
5: ALLOCATE-FULL-CALL-FRAME {1} => t9[OCFP]
6: MOVE-ARG '"SB!KERNEL"!10[Const4]>t11[R0] t9[OCFP] => t12[R0]
7: CALL-NAMED t9[OCFP] t13[Const5] t12[R0] {# 1 1 NIL} => t14[R0]
8: MOVE t14[R0] => t15[R0]
9: SET '*PACKAGE*!16[Const6]>t17[R1] t15[R0]
10: MOVE 'NIL!18 => t19[R0]
11: RETURN-SINGLE t3[CS0]>t20[NL0] t7[CS1]>t21[R1] t19[R0]
IR1 block 1 start c12
IR2 block NIL start c12
assembly code for #<SB!C:COMPONENT :NAME "top level form" {1014292303}>
in the ELSEWHERE segment:
L3:
in the REGULAR segment:
L4:
in the ELSEWHERE segment:
L5:
in the REGULAR segment:
VOP XEP-ALLOCATE-FRAME {#<SB!ASSEM:LABEL 1>}
.align 4
L1:
SIMPLE-FUN-HEADER-WORD
DWORD 0
DWORD 0
DWORD 0
DWORD 0
DWORD 0
DWORD 0
COMPUTE-CODE #<TN t22[CODE]>, #<TN t23[LR]>, L1, #<TN t24[NL0]>
VOP XEP-SETUP-SP
ADD #<TN t25[CSP]>, #<TN t26[CFP]>, 24
VOP NOTE-ENVIRONMENT-START {#<SB!ASSEM:LABEL 2>}
L2:
VOP ALLOCATE-FULL-CALL-FRAME {1} => t9[OCFP]
ORR #<TN t9[OCFP]>, #<TN t27[ZR]>, #<TN t25[CSP]>
ADD #<TN t25[CSP]>, #<TN t25[CSP]>, 16
STR #<TN t26[CFP]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t9[OCFP]>
:OFFSET 0
:MODE OFFSET)
VOP MOVE-ARG '"SB!KERNEL"!10[Const4]>t11[R0] t9[OCFP] => t12[R0]
LDR #<TN t11[R0]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t22[CODE]>
:OFFSET 17
:MODE OFFSET)
VOP CALL-NAMED t9[OCFP] t13[Const5] t12[R0] {# 1 1 NIL} => t14[R0]
LDR #<TN t28[LEXENV]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t22[CODE]>
:OFFSET 25
:MODE OFFSET)
MOVZ #<TN t29[NARGS]>, 2
LDR #<TN t30[R1]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t28[LEXENV]>
:OFFSET 9
:MODE OFFSET)
COMPUTE-LRA #<TN t31[LR]>, #<TN t31[LR]>, L6
STR #<TN t31[LR]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t9[OCFP]>
:OFFSET 8
:MODE OFFSET)
ORR #<TN t26[CFP]>, #<TN t27[ZR]>, #<TN t9[OCFP]>
L7:
ADD #<TN t32[TMP]>, #<TN t30[R1]>, 45
BR #<TN t32[TMP]>
.align 4
L6:
LRA-HEADER-WORD
L8:
COMPUTE-CODE #<TN t22[CODE]>, #<TN t31[LR]>, L6, #<TN t33[NL0]>
CSEL #<TN t25[CSP]>, #<TN t34[OCFP]>, #<TN t25[CSP]>, EQ
VOP SET '*PACKAGE*!16[Const6]>t17[R1] t15[R0]
LDR #<TN t17[R1]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t22[CODE]>
:OFFSET 33
:MODE OFFSET)
STR #<TN t15[R0]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t17[R1]>
:OFFSET -7
:MODE OFFSET)
VOP MOVE 'NIL!18 => t19[R0]
ORR #<TN t19[R0]>, #<TN t27[ZR]>, #<TN t35[NULL]>
VOP RETURN-SINGLE t3[CS0]>t20[NL0] t7[CS1]>t21[R1] t19[R0]
LDR #<TN t20[NL0]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t26[CFP]>
:OFFSET 0
:MODE OFFSET)
LDR #<TN t21[R1]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t26[CFP]>
:OFFSET 8
:MODE OFFSET)
ORR #<TN t25[CSP]>, #<TN t27[ZR]>, #<TN t26[CFP]>
ORR #<TN t26[CFP]>, #<TN t27[ZR]>, #<TN t20[NL0]>
MSR NZCV, #<TN t27[ZR]>
SUB #<TN t32[TMP]>, #<TN t21[R1]>, 7
BR #<TN t32[TMP]>
.align 4
;;;; component: BAR
IR1 block 0 start c13
start stack:
13> bind SB!C::CLAMBDA (SB!C::TL-XEP BAR) :KIND :EXTERNAL
14> 15: SB!C::CLAMBDA BAR
16> 17: #:G0
18> tail local combination v15 v17
end stack:
successors c19
IR1 block 1 start c19
start stack:
19> bind SB!C::CLAMBDA BAR
end stack:
successors c20
IR1 block 2 start c20
start stack:
20> entry NIL
21> 22: VALUES {GLOBAL-FUNCTION}
23> 24: X
25> 26: '"Hello World"
27> 28: known combination v22 v24 v26
end stack:
successors c29
IR1 block 3 start c29
start stack:
29> return v28 SB!C::CLAMBDA BAR
end stack:
successors c12
;;;; IR2 component: BAR
entries:
L9: BAR
TNs: 12 local, 10 temps, 1 constant, 6 env, 0 comp, 5 global.
Wired: 23, Unused: 0. 4 blocks, 20 global conflicts.
IR1 block 6 start c12
IR2 block NIL start c12
IR1 block 0 start c13
IR2 block 3 start c13
0: XEP-ALLOCATE-FRAME {#<SB!ASSEM:LABEL 9>}
1: VERIFY-ARG-COUNT t36[NARGS] {NIL 1}
2: XEP-SETUP-SP
3: MOVE t37[R0] => #:G0!38[R0]
4: MOVE t39[CS0]>t40[NL0] => t41[CS0]<t42[NL0]
5: MOVE t43[CS1]>t44[R1] => t45[CS1]<t46[R1]
6: NOTE-ENVIRONMENT-START {#<SB!ASSEM:LABEL 10>}
7: MOVE #:G0!38[R0] => X!47[R0]
8: MOVE t41[CS0]>t48[NL0] => t49[CS0]<t50[NL0]
9: MOVE t45[CS1]>t51[R1] => t52[CS1]<t53[R1]
IR1 block 1 start c19
IR2 block 2 start c19
0: MOVE t52[CS1]>t54[R1] => t55[CS1]<t56[R1]
1: NOTE-ENVIRONMENT-START {#<SB!ASSEM:LABEL 11>}
IR1 block 2 start c20
IR2 block 1 start c20
IR1 block 3 start c29
IR2 block 0 start c29
0: MOVE X!47[R0] => t57[R0]
1: MOVE '"Hello World"!58[Const4]>t59[R1] => t60[R1]
2: RETURN t49[CS0]>t61[NL0] t55[CS1]>t62[LEXENV] t57[R0] t60[R1] {2}
IR1 block 1 start c12
IR2 block NIL start c12
assembly code for #<SB!C:COMPONENT :NAME BAR {10142DF753}>
in the ELSEWHERE segment:
L12:
in the REGULAR segment:
L13:
in the ELSEWHERE segment:
L14:
in the REGULAR segment:
VOP XEP-ALLOCATE-FRAME {#<SB!ASSEM:LABEL 9>}
.align 4
L9:
SIMPLE-FUN-HEADER-WORD
DWORD 0
DWORD 0
DWORD 0
DWORD 0
DWORD 0
DWORD 0
COMPUTE-CODE #<TN t22[CODE]>, #<TN t63[LR]>, L9, #<TN t64[NL2]>
in the ELSEWHERE segment:
VOP VERIFY-ARG-COUNT t36[NARGS] {NIL 1}
L15:
L16:
DEBUG-TRAP
BYTE 10
BYTE 4
BYTE 25
BYTE 254
BYTE 132
BYTE 5
.align 3
in the REGULAR segment:
SUBS #<TN t27[ZR]>, #<TN t36[NARGS]>, 2
B NE, L15
VOP XEP-SETUP-SP
ADD #<TN t25[CSP]>, #<TN t26[CFP]>, 16
VOP NOTE-ENVIRONMENT-START {#<SB!ASSEM:LABEL 10>}
L10:
L17:
in the ELSEWHERE segment:
L18:
in the REGULAR segment:
VOP NOTE-ENVIRONMENT-START {#<SB!ASSEM:LABEL 11>}
L11:
L19:
L20:
VOP MOVE '"Hello World"!58[Const4]>t59[R1] => t60[R1]
LDR #<TN t59[R1]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t22[CODE]>
:OFFSET 17
:MODE OFFSET)
VOP RETURN t49[CS0]>t61[NL0] t55[CS1]>t62[LEXENV] t57[R0] t60[R1] {2}
LDR #<TN t61[NL0]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t26[CFP]>
:OFFSET 0
:MODE OFFSET)
LDR #<TN t62[LEXENV]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t26[CFP]>
:OFFSET 8
:MODE OFFSET)
ORR #<TN t65[OCFP]>, #<TN t27[ZR]>, #<TN t26[CFP]>
ORR #<TN t26[CFP]>, #<TN t27[ZR]>, #<TN t61[NL0]>
ADD #<TN t66[NARGS]>, #<TN t65[OCFP]>, 16
ORR #<TN t25[CSP]>, #<TN t27[ZR]>, #<TN t66[NARGS]>
MOVZ #<TN t66[NARGS]>, 4
ORR #<TN t67[R2]>, #<TN t27[ZR]>, #<TN t35[NULL]>
ORR #<TN t32[TMP]>, #<TN t27[ZR]>, 4026531840
MSR NZCV, #<TN t32[TMP]>
SUB #<TN t32[TMP]>, #<TN t68[LEXENV]>, 7
BR #<TN t32[TMP]>
.align 4
;;;; component: !COLD-INIT
IR1 block 0 start c30
start stack:
30> bind SB!C::CLAMBDA (SB!C::TL-XEP !COLD-INIT) :KIND :EXTERNAL
31> 32: SB!C::CLAMBDA !COLD-INIT
33> tail local combination v32
end stack:
successors c34
IR1 block 1 start c34
start stack:
34> bind SB!C::CLAMBDA !COLD-INIT
end stack:
successors c35
IR1 block 2 start c35
start stack:
35> entry NIL
36> 37: CONS {GLOBAL-FUNCTION}
38> 39: '20
40> 41: '30
42> 43: known combination v37 v39 v41
end stack:
successors c44
IR1 block 3 start c44
start stack:
44> return v43 SB!C::CLAMBDA !COLD-INIT
end stack:
successors c12
;;;; IR2 component: !COLD-INIT
entries:
L21: !COLD-INIT
TNs: 6 local, 5 temps, 2 constant, 4 env, 0 comp, 5 global.
Wired: 15, Unused: 0. 4 blocks, 16 global conflicts.
IR1 block 6 start c12
IR2 block NIL start c12
IR1 block 0 start c30
IR2 block 3 start c30
0: XEP-ALLOCATE-FRAME {#<SB!ASSEM:LABEL 21>}
1: VERIFY-ARG-COUNT t69[NARGS] {NIL 0}
2: XEP-SETUP-SP
3: MOVE t70[CS0]>t71[NL0] => t72[CS0]<t73[NL0]
4: MOVE t74[CS1]>t75[R0] => t76[CS1]<t77[R0]
5: NOTE-ENVIRONMENT-START {#<SB!ASSEM:LABEL 22>}
6: MOVE t72[CS0]>t78[NL0] => t79[CS0]<t80[NL0]
7: MOVE t76[CS1]>t81[R0] => t82[CS1]<t83[R0]
IR1 block 1 start c34
IR2 block 2 start c34
0: MOVE t82[CS1]>t84[R0] => t85[CS1]<t86[R0]
1: NOTE-ENVIRONMENT-START {#<SB!ASSEM:LABEL 23>}
IR1 block 2 start c35
IR2 block 1 start c35
0: FIXED-ALLOC {CONS 2 NIL 7 NIL} => t87[R0]
1: INIT-SLOT t87[R0] '20!88>t89[NL0] {CONS 0 7}
2: INIT-SLOT t87[R0] '30!90>t91[NL0] {CONS 1 7}
IR1 block 3 start c44
IR2 block 0 start c44
0: MOVE t87[R0] => t92[R0]
1: RETURN-SINGLE t79[CS0]>t93[NL0] t85[CS1]>t94[R1] t92[R0]
IR1 block 1 start c12
IR2 block NIL start c12
assembly code for #<SB!C:COMPONENT :NAME !COLD-INIT {1014327383}>
in the ELSEWHERE segment:
L24:
in the REGULAR segment:
L25:
in the ELSEWHERE segment:
L26:
in the REGULAR segment:
VOP XEP-ALLOCATE-FRAME {#<SB!ASSEM:LABEL 21>}
.align 4
L21:
SIMPLE-FUN-HEADER-WORD
DWORD 0
DWORD 0
DWORD 0
DWORD 0
DWORD 0
DWORD 0
COMPUTE-CODE #<TN t22[CODE]>, #<TN t95[LR]>, L21, #<TN t96[NL2]>
in the ELSEWHERE segment:
VOP VERIFY-ARG-COUNT t69[NARGS] {NIL 0}
L27:
L28:
DEBUG-TRAP
BYTE 10
BYTE 4
BYTE 25
BYTE 254
BYTE 132
BYTE 5
.align 3
in the REGULAR segment:
SUBS #<TN t27[ZR]>, #<TN t69[NARGS]>, 0
B NE, L27
VOP XEP-SETUP-SP
ADD #<TN t25[CSP]>, #<TN t26[CFP]>, 16
VOP NOTE-ENVIRONMENT-START {#<SB!ASSEM:LABEL 22>}
L22:
L29:
in the ELSEWHERE segment:
L30:
in the REGULAR segment:
VOP NOTE-ENVIRONMENT-START {#<SB!ASSEM:LABEL 23>}
L23:
L31:
VOP FIXED-ALLOC {CONS 2 NIL 7 NIL} => t87[R0]
MOVZ #<TN t32[TMP]>, 2209
STR #<TN t25[CSP]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t35[NULL]>
:OFFSET #<TN t32[TMP]>
:MODE OFFSET)
LOAD-FROM-LABEL #<TN t97[OCFP]>, L32
LDR #<TN t87[R0]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t97[OCFP]>
:OFFSET 0
:MODE OFFSET)
LDR #<TN t97[OCFP]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t97[OCFP]>
:OFFSET 8
:MODE OFFSET)
ADD #<TN t87[R0]>, #<TN t87[R0]>, 16
SUBS #<TN t27[ZR]>, #<TN t87[R0]>, #<TN t97[OCFP]>
B HI, L33
LOAD-FROM-LABEL #<TN t97[OCFP]>, L32
STR #<TN t87[R0]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t97[OCFP]>
:OFFSET 0
:MODE OFFSET)
SUB #<TN t87[R0]>, #<TN t87[R0]>, 16
L34:
ADD #<TN t87[R0]>, #<TN t87[R0]>, 7
in the ELSEWHERE segment:
L33:
MOVZ #<TN t87[R0]>, 16
STP #<TN t87[R0]>, #<TN t98[LR]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t99[ZR]>
:OFFSET -16
:MODE PRE-INDEX)
LOAD-FROM-LABEL #<TN t87[R0]>, L35
BLR #<TN t87[R0]>
LDP #<TN t87[R0]>, #<TN t98[LR]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t99[ZR]>
:OFFSET 16
:MODE POST-INDEX)
B L34
L35:
DWORD #S(SB!C:FIXUP :NAME alloc_tramp :FLAVOR FOREIGN :OFFSET NIL)
L32:
DWORD #S(SB!C:FIXUP :NAME boxed_region :FLAVOR FOREIGN :OFFSET NIL)
in the REGULAR segment:
MOVZ #<TN t32[TMP]>, 2209
STR #<TN t35[NULL]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t35[NULL]>
:OFFSET #<TN t32[TMP]>
:MODE OFFSET)
MOVZ #<TN t32[TMP]>, 2257
LDR #<TN t97[OCFP]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t35[NULL]>
:OFFSET #<TN t32[TMP]>
:MODE OFFSET)
CBZ #<TN t97[OCFP]>, L36
BLR #<TN t97[OCFP]>
L36:
VOP INIT-SLOT t87[R0] '20!88>t89[NL0] {CONS 0 7}
MOVZ #<TN t89[NL0]>, 40
STR #<TN t89[NL0]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t87[R0]>
:OFFSET -7
:MODE OFFSET)
VOP INIT-SLOT t87[R0] '30!90>t91[NL0] {CONS 1 7}
MOVZ #<TN t91[NL0]>, 60
STR #<TN t91[NL0]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t87[R0]>
:OFFSET 1
:MODE OFFSET)
L37:
VOP RETURN-SINGLE t79[CS0]>t93[NL0] t85[CS1]>t94[R1] t92[R0]
LDR #<TN t93[NL0]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t26[CFP]>
:OFFSET 0
:MODE OFFSET)
LDR #<TN t94[R1]>, #S(SB!VM::MEMORY-OPERAND
:BASE #<TN t26[CFP]>
:OFFSET 8
:MODE OFFSET)
ORR #<TN t25[CSP]>, #<TN t27[ZR]>, #<TN t26[CFP]>
ORR #<TN t26[CFP]>, #<TN t27[ZR]>, #<TN t93[NL0]>
MSR NZCV, #<TN t27[ZR]>
SUB #<TN t32[TMP]>, #<TN t94[R1]>, 7
BR #<TN t32[TMP]>
.align 4

70
src/code/arm64-vm.lisp Normal file
View file

@ -0,0 +1,70 @@
;;; This file contains the ARM specific runtime stuff.
;;;
(in-package "SB!VM")
;;; See x86-vm.lisp for a description of this.
;;; FIXME: Why is this present in every ARCH-vm.lisp with the the same definition. Is there something like common-vm?
(define-alien-type os-context-t (struct os-context-t-struct))
(defun machine-type ()
#!+sb-doc
"Return a string describing the type of the local machine."
"ARM64")
;;;; FIXUP-CODE-OBJECT
(defun fixup-code-object (code offset fixup kind)
(declare (type index offset))
(unless (zerop (rem offset n-word-bytes))
(error "Unaligned instruction? offset=#x~X." offset))
(sb!sys:without-gcing
(let ((sap (%primitive sb!kernel::code-instructions code)))
(ecase kind
(:absolute
(setf (sap-ref-32 sap offset) fixup))))))
;;;; "Sigcontext" access functions, cut & pasted from sparc-vm.lisp,
;;;; then modified for ARM.
;;;;
;;;; See also x86-vm for commentary on signed vs unsigned.
(define-alien-routine ("os_context_register_addr" context-register-addr)
(* unsigned-int)
(context (* os-context-t))
(index int))
;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
;;; (Are they used in anything time-critical, or just the debugger?)
(defun context-register (context index)
(declare (type (alien (* os-context-t)) context))
(deref (context-register-addr context index)))
(defun %set-context-register (context index new)
(declare (type (alien (* os-context-t)) context))
(setf (deref (context-register-addr context index))
new))
(defun context-pc (context)
(int-sap (context-register context pc-offset)))
;;;; INTERNAL-ERROR-ARGS.
;;; Given a (POSIX) signal context, extract the internal error
;;; arguments from the instruction stream.
(defun internal-error-args (context)
(declare (type (alien (* os-context-t)) context))
(let* ((pc (context-pc context))
(length (sap-ref-8 pc 5)) ;; Skip trap instruction and kind byte
(vector (make-array length :element-type '(unsigned-byte 8))))
(declare (type system-area-pointer pc)
(type (unsigned-byte 8) length)
(type (simple-array (unsigned-byte 8) (*)) vector))
(copy-ub8-from-system-area pc 6 vector 0 length)
(let* ((index 0)
(error-number (sb!c:read-var-integer vector index)))
(collect ((sc-offsets))
(loop
(when (>= index length)
(return))
(sc-offsets (sb!c:read-var-integer vector index)))
(values error-number (sc-offsets))))))

2
src/code/pred.lisp
View file

@ -170,7 +170,7 @@
(def-type-predicate-wrapper vectorp)
(def-type-predicate-wrapper vector-nil-p))
#!+(or x86 x86-64 arm)
#!+(or x86 x86-64 arm arm64)
(defun fixnum-mod-p (x limit)
(and (fixnump x)
(<= 0 x limit)))

5
src/cold/shared.lisp
View file

@ -142,7 +142,7 @@
"target backend-subfeatures *SHEBANG-BACKEND-FEATURES*=~@<~S~:>~%"
*shebang-backend-subfeatures*))
(let ((arch (intersection '(:alpha :arm :hppa :mips :ppc :sparc :x86 :x86-64)
(let ((arch (intersection '(:alpha :arm :arm64 :hppa :mips :ppc :sparc :x86 :x86-64)
*shebang-features*)))
(cond ((not arch) (error "No architecture selected"))
((> (length arch) 1) (error "More than one architecture selected"))))
@ -160,7 +160,7 @@
":GENCGC and :CHENEYGC are incompatible")
("(and cheneygc (not (or alpha arm hppa mips ppc sparc)))"
":CHENEYGC not supported on selected architecture")
("(and gencgc (not (or sparc ppc x86 x86-64 arm)))"
("(and gencgc (not (or sparc ppc x86 x86-64 arm arm64)))"
":GENCGC not supported on selected architecture")
("(not (or gencgc cheneygc))"
"One of :GENCGC or :CHENEYGC must be enabled")
@ -260,6 +260,7 @@
#!+alpha "alpha"
#!+hppa "hppa"
#!+arm "arm"
#!+arm64 "arm64"
(subseq stem (+ position 7)))
stem)))
(compile 'stem-remap-target)

200
src/compiler/arm64/alloc.lisp Normal file
View file

@ -0,0 +1,200 @@
;;;; allocation VOPs for the ARM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(define-vop (list-or-list*)
(:args (things :more t :scs (control-stack)))
(:temporary (:scs (descriptor-reg) :type list) ptr)
(:temporary (:scs (any-reg)) temp)
(:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
res)
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:info num)
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(:policy :fast-safe)
(:node-var node)
(:generator 0
(cond ((zerop num)
(move result null-tn))
((and star (= num 1))
(move result (tn-ref-tn things)))
(t
(macrolet
((maybe-load (tn)
(once-only ((tn tn))
`(sc-case ,tn
((any-reg descriptor-reg null)
,tn)
(control-stack
(load-stack-tn temp ,tn)
temp)))))
(let* ((cons-cells (if star (1- num) num))
(alloc (* (pad-data-block cons-size) cons-cells)))
(pseudo-atomic (pa-flag)
(allocation res alloc list-pointer-lowtag
:flag-tn pa-flag
:stack-allocate-p (node-stack-allocate-p node))
(move ptr res)
(dotimes (i (1- cons-cells))
(storew (maybe-load (tn-ref-tn things)) ptr
cons-car-slot list-pointer-lowtag)
(setf things (tn-ref-across things))
(inst add ptr ptr (pad-data-block cons-size))
(storew ptr ptr
(- cons-cdr-slot cons-size)
list-pointer-lowtag))
(storew (maybe-load (tn-ref-tn things)) ptr
cons-car-slot list-pointer-lowtag)
(storew (if star
(maybe-load (tn-ref-tn (tn-ref-across things)))
null-tn)
ptr cons-cdr-slot list-pointer-lowtag))
(move result res)))))))
(define-vop (list list-or-list*)
(:variant nil))
(define-vop (list* list-or-list*)
(:variant t))
;;;; Special purpose inline allocators.
#!-gencgc
(define-vop (allocate-code-object)
(:args (boxed-arg :scs (any-reg))
(unboxed-arg :scs (any-reg)))
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (non-descriptor-reg)) size)
(:temporary (:scs (any-reg) :from (:argument 0)) boxed)
(:temporary (:scs (non-descriptor-reg)) unboxed)
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:generator 100
(inst add boxed boxed-arg (fixnumize (1+ code-constants-offset)))
(inst bic boxed boxed lowtag-mask)
(inst mov unboxed (lsr unboxed-arg word-shift))
(inst add unboxed unboxed lowtag-mask)
(inst bic unboxed unboxed lowtag-mask)
(inst mov ndescr (lsl boxed (- n-widetag-bits word-shift)))
(inst orr ndescr ndescr code-header-widetag)
(inst add size boxed unboxed)
(pseudo-atomic (pa-flag)
(allocation result size other-pointer-lowtag :flag-tn pa-flag)
(storew ndescr result 0 other-pointer-lowtag)
(storew unboxed-arg result code-code-size-slot other-pointer-lowtag)
(storew null-tn result code-entry-points-slot other-pointer-lowtag)
(storew null-tn result code-debug-info-slot other-pointer-lowtag))))
(define-vop (make-fdefn)
(:args (name :scs (descriptor-reg) :to :eval))
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:results (result :scs (descriptor-reg) :from :argument))
(:temporary (:sc interior-reg) lip)
(:policy :fast-safe)
(:translate make-fdefn)
(:generator 37
(let ((undefined-tramp-fixup (gen-label)))
(with-fixed-allocation (result pa-flag fdefn-widetag fdefn-size)
(inst load-from-label temp lip undefined-tramp-fixup)
(storew name result fdefn-name-slot other-pointer-lowtag)
(storew null-tn result fdefn-fun-slot other-pointer-lowtag)
(storew temp result fdefn-raw-addr-slot other-pointer-lowtag))
(assemble (*elsewhere*)
(emit-label undefined-tramp-fixup)
(inst word (make-fixup "undefined_tramp" :foreign))))))
(define-vop (make-closure)
(:args (function :to :save :scs (descriptor-reg)))
(:info length stack-allocate-p)
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:results (result :scs (descriptor-reg)))
(:generator 10
(let* ((size (+ length closure-info-offset))
(alloc-size (pad-data-block size)))
(pseudo-atomic (pa-flag)
(allocation result alloc-size
fun-pointer-lowtag
:flag-tn pa-flag
:stack-allocate-p stack-allocate-p)
(load-immediate-word pa-flag
(logior
(ash (1- size) n-widetag-bits)
closure-header-widetag))
(storew pa-flag result 0 fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag)))))
;;; The compiler likes to be able to directly make value cells.
;;;
(define-vop (make-value-cell)
(:args (value :to :save :scs (descriptor-reg any-reg)))
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:info stack-allocate-p)
(:results (result :scs (descriptor-reg)))
(:generator 10
(with-fixed-allocation (result pa-flag value-cell-header-widetag
value-cell-size :stack-allocate-p stack-allocate-p)
(storew value result value-cell-value-slot other-pointer-lowtag))))
;;;; Automatic allocators for primitive objects.
(define-vop (make-unbound-marker)
(:args)
(:results (result :scs (descriptor-reg any-reg)))
(:generator 1
(inst mov result unbound-marker-widetag)))
(define-vop (make-funcallable-instance-tramp)
(:args)
(:results (result :scs (any-reg)))
(:temporary (:sc interior-reg) lip)
(:generator 1
(let ((fixup (gen-label)))
(inst load-from-label result lip fixup)
(assemble (*elsewhere*)
(emit-label fixup)
(inst word (make-fixup "funcallable_instance_tramp" :foreign))))))
(define-vop (fixed-alloc)
(:args)
(:info name words type lowtag stack-allocate-p)
(:ignore name)
(:results (result :scs (descriptor-reg)))
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:generator 4
(with-fixed-allocation (result pa-flag type words
:lowtag lowtag
:stack-allocate-p stack-allocate-p))))
(define-vop (var-alloc)
(:args (extra :scs (any-reg)))
(:arg-types positive-fixnum)
(:info name words type lowtag)
(:ignore name)
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (any-reg)) bytes)
(:temporary (:scs (non-descriptor-reg)) header)
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:generator 6
;; Build the object header, assuming that the header was in WORDS
;; but should not be in the header
(inst add bytes extra (* (1- words) n-word-bytes))
(inst mov header (lsl bytes (- n-widetag-bits n-fixnum-tag-bits)))
(inst add header header type)
;; Add the object header to the allocation size and round up to
;; the allocation granularity
(inst add bytes bytes (* 2 n-word-bytes))
(inst bic bytes bytes lowtag-mask)
;; Allocate the object and set its header
(pseudo-atomic (pa-flag)
(allocation result bytes lowtag :flag-tn pa-flag)
(storew header result 0 lowtag))))

976
src/compiler/arm64/arith.lisp Normal file
View file

@ -0,0 +1,976 @@
;;;; the VM definition arithmetic VOPs for the ARM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; unary operations.
(define-vop (fast-safe-arith-op)
(:policy :fast-safe)
(:effects)
(:affected))
(define-vop (fixnum-unop fast-safe-arith-op)
(:args (x :scs (any-reg)))
(:results (res :scs (any-reg)))
(:note "inline fixnum arithmetic")
(:arg-types tagged-num)
(:result-types tagged-num))
(define-vop (signed-unop fast-safe-arith-op)
(:args (x :scs (signed-reg)))
(:results (res :scs (signed-reg)))
(:note "inline (signed-byte 32) arithmetic")
(:arg-types signed-num)
(:result-types signed-num))
(define-vop (unsigned-unop fast-safe-arith-op)
(:args (x :scs (unsigned-reg)))
(:results (res :scs (unsigned-reg)))
(:note "inline (unsigned-byte 32) arithmetic")
(:arg-types unsigned-num)
(:result-types unsigned-num))
(define-vop (fast-negate/fixnum fixnum-unop)
(:translate %negate)
(:generator 1
(inst rsb res x 0)))
(define-vop (fast-negate/signed signed-unop)
(:translate %negate)
(:generator 2
(inst rsb res x 0)))
(define-vop (fast-negate/unsigned signed-unop)
(:args (x :scs (unsigned-reg) :target res))
(:arg-types unsigned-num)
(:translate %negate)
(:generator 3
(inst rsb res x 0)))
(define-vop (fast-lognot/fixnum signed-unop)
(:args (x :scs (any-reg)))
(:arg-types tagged-num)
(:translate lognot)
(:generator 1
(inst mvn res (asr x n-fixnum-tag-bits))))
(define-vop (fast-lognot/signed signed-unop)
(:translate lognot)
(:generator 2
(inst mvn res x)))
;;;; Binary fixnum operations.
;;; Assume that any constant operand is the second arg...
(define-vop (fast-fixnum-binop fast-safe-arith-op)
(:args (x :target r :scs (any-reg))
(y :target r :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:note "inline fixnum arithmetic"))
(define-vop (fast-unsigned-binop fast-safe-arith-op)
(:args (x :target r :scs (unsigned-reg))
(y :target r :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 32) arithmetic"))
(define-vop (fast-signed-binop fast-safe-arith-op)
(:args (x :target r :scs (signed-reg))
(y :target r :scs (signed-reg)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:note "inline (signed-byte 32) arithmetic"))
(define-vop (fast-fixnum-binop-c fast-safe-arith-op)
(:args (x :target r :scs (any-reg)))
(:info y)
(:arg-types tagged-num
(:constant (signed-byte #.n-fixnum-bits)))
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:note "inline fixnum arithmetic"))
(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
(:args (x :target r :scs (unsigned-reg)))
(:info y)
(:arg-types unsigned-num
(:constant (unsigned-byte 32)))
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 32) arithmetic"))
(define-vop (fast-signed-binop-c fast-safe-arith-op)
(:args (x :target r :scs (signed-reg)))
(:info y)
(:arg-types signed-num
(:constant (signed-byte 32)))
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:note "inline (signed-byte 32) arithmetic"))
(defmacro define-binop (translate untagged-penalty op
&key cop arg-swap neg-op invert-y invert-r try-single-op)
(let ((cop (or cop op)))
`(progn
(define-vop (,(symbolicate 'fast- translate '/fixnum=>fixnum)
fast-fixnum-binop)
(:translate ,translate)
(:generator 2
,(if arg-swap
`(inst ,op r y x)
`(inst ,op r x y))))
(define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
fast-fixnum-binop-c)
(:translate ,translate)
(:generator 1
(composite-immediate-instruction ,cop r x y :fixnumize t :neg-op ,neg-op :invert-y ,invert-y :invert-r ,invert-r :single-op-op ,(when try-single-op op))))
(define-vop (,(symbolicate 'fast- translate '/signed=>signed)
fast-signed-binop)
(:translate ,translate)
(:generator ,(1+ untagged-penalty)
,(if arg-swap
`(inst ,op r y x)
`(inst ,op r x y))))
(define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
fast-signed-binop-c)
(:translate ,translate)
(:generator ,untagged-penalty
(composite-immediate-instruction ,cop r x y :neg-op ,neg-op :invert-y ,invert-y :invert-r ,invert-r :single-op-op ,(when try-single-op op))))
(define-vop (,(symbolicate 'fast- translate '/unsigned=>unsigned)
fast-unsigned-binop)
(:translate ,translate)
(:generator ,(1+ untagged-penalty)
,(if arg-swap
`(inst ,op r y x)
`(inst ,op r x y))))
(define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
fast-unsigned-binop-c)
(:translate ,translate)
(:generator ,untagged-penalty
(composite-immediate-instruction ,cop r x y :neg-op ,neg-op :invert-y ,invert-y :invert-r ,invert-r :single-op-op ,(when try-single-op op)))))))
(define-binop + 4 add :neg-op sub)
(define-binop - 4 sub :neg-op add)
(define-binop logand 2 and :cop bic :invert-y t :try-single-op t)
(define-binop logandc1 2 bic :cop orr :arg-swap t :invert-y t :invert-r t)
(define-binop logandc2 2 bic)
(define-binop logior 2 orr)
(define-binop logxor 2 eor)
(define-vop (fast-logior-unsigned-signed=>signed fast-safe-arith-op)
(:args (x :scs (unsigned-reg))
(y :target r :scs (signed-reg)))
(:arg-types unsigned-num signed-num)
(:results (r :scs (signed-reg) :from (:argument 1)))
(:result-types signed-num)
(:note "inline (unsigned-byte 32) arithmetic")
(:translate logior)
(:generator 3
(inst orr r x y)))
(define-vop (fast-logior-signed-unsigned=>signed fast-safe-arith-op)
(:args (x :target r :scs (signed-reg))
(y :scs (unsigned-reg)))
(:arg-types signed-num unsigned-num)
(:results (r :scs (signed-reg) :from (:argument 0)))
(:result-types signed-num)
(:note "inline (unsigned-byte 32) arithmetic")
(:translate logior)
(:generator 3
(inst orr r x y)))
;;; Multiplication
(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
(:args (x :scs (signed-reg)) ;; one operand needs to be untagged
(y :target r :scs (any-reg)))
(:translate *)
(:generator 2
(inst mul r x y)))
(define-vop (fast-*-c/fixnum=>fixnum fast-fixnum-binop-c)
(:args (x :scs (any-reg) :to :result))
(:results (r :scs (any-reg) :from :eval))
(:temporary (:sc non-descriptor-reg :target r) temp)
(:translate *)
(:generator 1
(load-immediate-word temp y)
(inst mul r temp x)))
(define-vop (fast-*/signed=>signed fast-signed-binop)
(:translate *)
(:generator 3
(inst mul r x y)))
(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
(:translate *)
(:generator 3
(inst mul r x y)))
;;;
(define-vop (fast-lognor/fixnum=>fixnum fast-fixnum-binop)
(:translate lognor)
(:args (x :target r :scs (any-reg))
(y :target r :scs (any-reg)))
(:temporary (:sc non-descriptor-reg) temp)
(:generator 3
(inst orr temp x y)
(inst mvn temp temp)
(inst eor r temp fixnum-tag-mask)))
(define-vop (fast-logand/signed-unsigned=>unsigned fast-logand/unsigned=>unsigned)
(:args (x :scs (signed-reg) :target r)
(y :scs (unsigned-reg) :target r))
(:arg-types signed-num unsigned-num)
(:translate logand))
(define-source-transform logeqv (&rest args)
(if (oddp (length args))
`(logxor ,@args)
`(lognot (logxor ,@args))))
(define-source-transform logorc1 (x y)
`(logior (lognot ,x) ,y))
(define-source-transform logorc2 (x y)
`(logior ,x (lognot ,y)))
;;; Shifting
(define-vop (fast-ash-left-c/fixnum=>fixnum)
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (any-reg) :target result))
(:info amount)
(:arg-types tagged-num (:constant unsigned-byte))
(:results (result :scs (any-reg)))
(:result-types tagged-num)
(:note "inline ASH")
(:generator 1
(if (< amount 32)
(inst mov result (lsl number amount))
(inst mov result 0))))
(define-vop (fast-ash-right-c/fixnum=>fixnum)
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (any-reg) :target result))
(:info amount)
(:arg-types tagged-num (:constant (integer * -1)))
(:results (result :scs (any-reg)))
(:result-types tagged-num)
(:temporary (:sc unsigned-reg :target result) temp)
(:note "inline ASH")
(:generator 1
(inst mov temp (asr number (min (- amount) 31)))
(inst bic result temp fixnum-tag-mask)))
(define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
fast-ash-left-c/fixnum=>fixnum)
(:translate ash-left-modfx))
(define-vop (fast-ash-left-mod32-c/fixnum=>fixnum
fast-ash-left-c/fixnum=>fixnum)
(:translate ash-left-mod32))
(define-vop (fast-ash-c/unsigned=>unsigned)
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (unsigned-reg) :target result))
(:info amount)
(:arg-types unsigned-num (:constant integer))
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(:note "inline ASH")
(:generator 3
(cond ((< -32 amount 32)
(if (plusp amount)
(inst mov result (lsl number amount))
(inst mov result (lsr number (- amount)))))
(t
(inst mov result 0)))))
(define-vop (fast-ash-c/signed=>signed)
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (signed-reg) :target result))
(:info amount)
(:arg-types signed-num (:constant integer))
(:results (result :scs (signed-reg)))
(:result-types signed-num)
(:note "inline ASH")
(:generator 3
(cond ((< -32 amount 32)
(if (plusp amount)
(inst mov result (lsl number amount))
(inst mov result (asr number (- amount)))))
(t
(inst mov result 0)))))
(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
(:translate ash-left-mod32))
(define-vop (fast-ash-left-mod32-c/signed=>signed
fast-ash-c/signed=>signed)
(:translate ash-left-mod32))
(define-vop (fast-ash/signed/unsigned)
(:note "inline ASH")
(:args (number)
(amount))
(:results (result))
(:policy :fast-safe)
(:temporary (:sc non-descriptor-reg) temp)
(:variant-vars variant)
(:generator 5
(move temp amount)
(inst cmp temp 0)
(inst b :ge LEFT)
(inst rsb temp temp 0) ;; negate
(inst cmp temp sb!vm:n-word-bits)
(inst mov :gt temp sb!vm:n-word-bits)
(inst mov result (ecase variant
(:signed (asr number temp))
(:unsigned (lsr number temp))))
(inst b END)
LEFT
(inst cmp temp sb!vm:n-word-bits)
(inst mov :gt temp sb!vm:n-word-bits)
(inst mov result (lsl number temp))
END))
(define-vop (fast-ash/signed=>signed fast-ash/signed/unsigned)
(:args (number :scs (signed-reg) :to :save)
(amount :scs (signed-reg) :to :save :target temp))
(:arg-types signed-num signed-num)
(:results (result :scs (signed-reg)))
(:result-types signed-num)
(:translate ash)
(:variant :signed))
(define-vop (fast-ash/unsigned=>unsigned fast-ash/signed/unsigned)
(:args (number :scs (unsigned-reg) :to :save)
(amount :scs (signed-reg) :to :save))
(:arg-types unsigned-num signed-num)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(:translate ash)
(:variant :unsigned))
(macrolet ((def (name sc-type type result-type cost)
`(define-vop (,name)
(:note "inline ASH")
(:translate ash)
(:args (number :scs (,sc-type))
(amount :scs (signed-reg unsigned-reg)
:target temp))
(:temporary (:sc non-descriptor-reg) temp)
(:arg-types ,type positive-fixnum)
(:results (result :scs (,result-type)))
(:result-types ,type)
(:policy :fast-safe)
(:generator ,cost
(move temp amount)
(inst cmp temp sb!vm:n-word-bits)
(inst mov :gt temp sb!vm:n-word-bits)
(inst mov result (lsl number temp))))))
;; FIXME: There's the opportunity for a sneaky optimization here, I
;; think: a FAST-ASH-LEFT-C/FIXNUM=>SIGNED vop. -- CSR, 2003-09-03
(def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
(def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
(def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
(define-vop (fast-ash-left-mod32/unsigned=>unsigned
fast-ash-left/unsigned=>unsigned)
(:translate ash-left-mod32))
#!+ash-right-vops
(define-vop (fast-%ash/right/unsigned)
(:translate %ash/right)
(:policy :fast-safe)
(:args (number :scs (unsigned-reg) :target result)
(amount :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(:results (result :scs (unsigned-reg) :from (:argument 0)))
(:result-types unsigned-num)
(:generator 4
(inst mov result (lsr number amount))))
#!+ash-right-vops
(define-vop (fast-%ash/right/signed)
(:translate %ash/right)
(:policy :fast-safe)
(:args (number :scs (signed-reg) :target result)
(amount :scs (unsigned-reg)))
(:arg-types signed-num unsigned-num)
(:results (result :scs (signed-reg) :from (:argument 0)))
(:result-types signed-num)
(:generator 4
(inst mov result (asr number amount))))
#!+ash-right-vops
(define-vop (fast-%ash/right/fixnum)
(:translate %ash/right)
(:policy :fast-safe)
(:args (number :scs (any-reg) :target result)
(amount :scs (unsigned-reg) :target temp))
(:arg-types tagged-num unsigned-num)
(:results (result :scs (any-reg) :from (:argument 0)))
(:result-types tagged-num)
(:temporary (:sc unsigned-reg :target result) temp)
(:generator 3
(inst mov temp (asr number amount))
(inst bic result temp fixnum-tag-mask)))
;;; Only the lower 5 bits of the shift amount are significant.
(define-vop (shift-towards-someplace)
(:policy :fast-safe)
(:args (num :scs (unsigned-reg))
(amount :scs (signed-reg)))
(:arg-types unsigned-num tagged-num)
(:temporary (:sc signed-reg) temp)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num))
(define-vop (shift-towards-start shift-towards-someplace)
(:translate shift-towards-start)
(:note "SHIFT-TOWARDS-START")
(:generator 1
(inst and temp amount #b11111)
(inst mov r (lsr num temp))))
(define-vop (shift-towards-end shift-towards-someplace)
(:translate shift-towards-end)
(:note "SHIFT-TOWARDS-END")
(:generator 1
(inst and temp amount #b11111)
(inst mov r (lsl num temp))))
(define-vop (signed-byte-32-len)
(:translate integer-length)
(:note "inline (signed-byte 32) integer-length")
(:policy :fast-safe)
(:args (arg :scs (signed-reg) :target temp))
(:arg-types signed-num)
(:results (res :scs (any-reg)))
(:result-types positive-fixnum)
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp)
(:generator 30
(move temp arg)
(inst cmp temp 0)
(inst mvn :lt temp temp)
(inst clz temp temp)
(inst rsb temp temp 32)
(inst mov res (lsl temp n-fixnum-tag-bits))))
(define-vop (unsigned-byte-32-count)
(:translate logcount)
(:note "inline (unsigned-byte 32) logcount")
(:policy :fast-safe)
(:args (arg :scs (unsigned-reg) :target num))
(:arg-types unsigned-num)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
:target res) num)
(:temporary (:scs (non-descriptor-reg)) mask temp)
(:generator 30
(move num arg)
(load-immediate-word mask #x55555555)
(inst and temp mask (lsr num 1))
(inst and num num mask)
(inst add num num temp)
(load-immediate-word mask #x33333333)
(inst and temp mask (lsr num 2))
(inst and num num mask)
(inst add num num temp)
(load-immediate-word mask #x0f0f0f0f)
(inst and temp mask (lsr num 4))
(inst and num num mask)
(inst add num num temp)
(inst add num num (lsr num 8))
(inst add num num (lsr num 16))
(inst and res num #xff)))
;;; Modular functions
(define-modular-fun lognot-mod32 (x) lognot :untagged nil 32)
(define-vop (lognot-mod32/unsigned=>unsigned)
(:translate lognot-mod32)
(:args (x :scs (unsigned-reg)))
(:arg-types unsigned-num)
(:results (res :scs (unsigned-reg)))
(:result-types unsigned-num)
(:policy :fast-safe)
(:generator 1
(inst mvn res x)))
(macrolet
((define-modular-backend (fun &optional constantp)
(let ((mfun-name (symbolicate fun '-mod32))
(modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
(modcvop (symbolicate 'fast- fun 'mod32-c/unsigned=>unsigned))
(vop (symbolicate 'fast- fun '/unsigned=>unsigned))
(cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
`(progn
(define-modular-fun ,mfun-name (x y) ,fun :untagged nil 32)
(define-vop (,modvop ,vop)
(:translate ,mfun-name))
,@(when constantp
`((define-vop (,modcvop ,cvop)
(:translate ,mfun-name))))))))
(define-modular-backend + t)
(define-modular-backend - t)
(define-modular-backend *)
;; (define-modular-backend logeqv)
;; (define-modular-backend lognand)
;; (define-modular-backend lognor)
(define-modular-backend logandc1)
(define-modular-backend logandc2)
;; (define-modular-backend logorc1)
;; (define-modular-backend logorc2)
)
;;;; Binary conditional VOPs:
(define-vop (fast-conditional)
(:conditional :eq)
(:effects)
(:affected)
(:policy :fast-safe))
(define-vop (fast-conditional/fixnum fast-conditional)
(:args (x :scs (any-reg))
(y :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison"))
(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
(:args (x :scs (any-reg)))
(:arg-types tagged-num (:constant (unsigned-byte 8)))
(:info y))
(define-vop (fast-conditional/signed fast-conditional)
(:args (x :scs (signed-reg))
(y :scs (signed-reg)))
(:arg-types signed-num signed-num)
(:note "inline (signed-byte 32) comparison"))
(define-vop (fast-conditional-c/signed fast-conditional/signed)
(:args (x :scs (signed-reg)))
(:arg-types signed-num (:constant (unsigned-byte 8)))
(:info y))
(define-vop (fast-conditional/unsigned fast-conditional)
(:args (x :scs (unsigned-reg))
(y :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(:note "inline (unsigned-byte 32) comparison"))
(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
(:args (x :scs (unsigned-reg)))
(:arg-types unsigned-num (:constant (unsigned-byte 8)))
(:info y))
(defmacro define-conditional-vop (tran cond unsigned)
`(progn
,@(mapcar (lambda (suffix cost signed)
(unless (and (member suffix '(/fixnum -c/fixnum))
(eq tran 'eql))
`(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
tran suffix))
,(intern
(format nil "~:@(FAST-CONDITIONAL~A~)"
suffix)))
(:translate ,tran)
(:conditional ,(if signed cond unsigned))
(:generator ,cost
(inst cmp x
,(if (eq suffix '-c/fixnum) '(fixnumize y) 'y))))))
'(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
'(4 3 6 5 6 5)
'(t t t t nil nil))))
(define-conditional-vop < :lt :lo)
(define-conditional-vop > :gt :hi)
(define-conditional-vop eql :eq :eq)
;;; EQL/FIXNUM is funny because the first arg can be of any type, not
;;; just a known fixnum.
;;; These versions specify a fixnum restriction on their first arg.
;;; We have also generic-eql/fixnum VOPs which are the same, but have
;;; no restriction on the first arg and a higher cost. The reason for
;;; doing this is to prevent fixnum specific operations from being
;;; used on word integers, spuriously consing the argument.
(define-vop (fast-eql/fixnum)
(:args (x :scs (any-reg))
(y :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison")
(:translate eql)
(:conditional :eq)
(:policy :fast-safe)
(:generator 4
(inst cmp x y)))
(define-vop (generic-eql/fixnum fast-eql/fixnum)
(:args (x :scs (any-reg descriptor-reg))
(y :scs (any-reg)))
(:arg-types * tagged-num)
(:variant-cost 7))
(define-vop (fast-eql-c/fixnum)
(:args (x :scs (any-reg)))
(:arg-types tagged-num (:constant (signed-byte 9)))
(:info y)
(:translate eql)
(:policy :fast-safe)
(:conditional :eq)
(:generator 3
(if (minusp y)
(inst cmn x (fixnumize (abs y)))
(inst cmp x (fixnumize y)))))
(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
(:args (x :scs (any-reg descriptor-reg)))
(:arg-types * (:constant (signed-byte 9)))
(:variant-cost 6))
(macrolet ((define-logtest-vops ()
`(progn
,@(loop for suffix in '(/fixnum -c/fixnum
/signed -c/signed
/unsigned -c/unsigned)
for cost in '(4 3 6 5 6 5)
collect
`(define-vop (,(symbolicate "FAST-LOGTEST" suffix)
,(symbolicate "FAST-CONDITIONAL" suffix))
(:translate logtest)
(:conditional :ne)
(:generator ,cost
(inst tst x
,(case suffix
(-c/fixnum
`(fixnumize y))
((-c/signed -c/unsigned)
`y)
(t
'y)))))))))
(define-logtest-vops))
(define-source-transform lognand (x y)
`(lognot (logand ,x ,y)))
(defknown %logbitp (integer unsigned-byte) boolean
(movable foldable flushable always-translatable))
;;; For constant folding
(defun %logbitp (integer index)
(logbitp index integer))
(define-vop (fast-logbitp-c/fixnum fast-conditional-c/fixnum)
(:translate %logbitp)
(:conditional :ne)
(:arg-types tagged-num (:constant (integer 0 29)))
(:generator 4
(inst tst x (ash 1 (+ y n-fixnum-tag-bits)))))
(define-vop (fast-logbitp-c/signed fast-conditional-c/signed)
(:translate %logbitp)
(:conditional :ne)
(:arg-types signed-num (:constant (integer 0 31)))
(:generator 5
(inst tst x (ash 1 y))))
(define-vop (fast-logbitp-c/unsigned fast-conditional-c/unsigned)
(:translate %logbitp)
(:conditional :ne)
(:arg-types unsigned-num (:constant (integer 0 31)))
(:generator 5
(inst tst x (ash 1 y))))
(define-vop (fast-signum-fixnum fixnum-unop)
(:args (x :scs (any-reg) :target res))
(:translate signum)
(:generator 4
(move res x)
(inst cmp x 0)
(inst mov :ne res (fixnumize 1))
(inst mvn :mi res (lognot (fixnumize -1)))))
(define-vop (fast-signum-signed signed-unop)
(:args (x :scs (signed-reg) :target res))
(:translate signum)
(:generator 5
(move res x)
(inst cmp x 0)
(inst mov :ne res 1)
(inst mvn :mi res 0)))
(define-vop (fast-signum-unsigned unsigned-unop)
(:args (x :scs (unsigned-reg) :target res))
(:translate signum)
(:generator 5
(move res x)
(inst cmp x 0)
(inst mov :ne res 1)))
;; Specialised mask-signed-field VOPs.
(define-vop (mask-signed-field-word/c)
(:translate sb!c::mask-signed-field)
(:policy :fast-safe)
(:args (x :scs (signed-reg unsigned-reg) :target r))
(:arg-types (:constant (integer 0 32)) untagged-num)
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:info width)
(:generator 3
(cond ((zerop width)
(inst mov r 0))
((= width 32)
(move r x))
(t
(let ((delta (- n-word-bits width)))
(inst mov r (lsl x delta))
(inst mov r (asr r delta)))))))
(define-vop (mask-signed-field-bignum/c)
(:translate sb!c::mask-signed-field)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg) :target r))
(:arg-types (:constant (integer 0 32)) bignum)
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:info width)
(:generator 4
(cond ((zerop width)
(inst mov r 0))
(t
(loadw r x bignum-digits-offset other-pointer-lowtag)
(let ((delta (- n-word-bits width)))
(inst mov r (lsl r delta))
(inst mov r (asr r delta)))))))
;;;; Bignum stuff.
(define-vop (bignum-length get-header-data)
(:translate sb!bignum:%bignum-length)
(:policy :fast-safe))
(define-vop (bignum-set-length set-header-data)
(:translate sb!bignum:%bignum-set-length)
(:policy :fast-safe))
(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
(unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
(unsigned-reg) unsigned-num sb!bignum:%bignum-set)
(define-vop (digit-0-or-plus)
(:translate sb!bignum:%digit-0-or-plusp)
(:policy :fast-safe)
(:args (digit :scs (unsigned-reg)))
(:arg-types unsigned-num)
(:conditional)
(:info target not-p)
(:generator 2
(inst cmp digit 0)
(inst b (if not-p :lt :ge) target)))
(define-vop (add-w/carry)
(:translate sb!bignum:%add-with-carry)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg))
(b :scs (unsigned-reg))
(c :scs (any-reg)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg))
(carry :scs (unsigned-reg) :from :eval))
(:result-types unsigned-num positive-fixnum)
(:generator 3
(inst cmp c 1) ;; Set carry if (fixnum 0 or 1) c=0, else clear.
(inst adcs result a b)
(inst mov :cs carry 1)
(inst mov :cc carry 0)))
(define-vop (sub-w/borrow)
(:translate sb!bignum:%subtract-with-borrow)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg))
(b :scs (unsigned-reg))
(c :scs (any-reg)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg))
(borrow :scs (unsigned-reg) :from :eval))
(:result-types unsigned-num positive-fixnum)
(:generator 4
(inst cmp c 1) ;; Set carry if (fixnum 0 or 1) c=0, else clear.
(inst sbcs result a b)
(inst mov :cs borrow 1)
(inst mov :cc borrow 0)))
(define-vop (bignum-mult-and-add-3-arg)
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :to :result)
(y :scs (unsigned-reg) :to :result)
(carry-in :scs (unsigned-reg) :target lo))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:results (hi :scs (unsigned-reg) :from :eval)
(lo :scs (unsigned-reg) :from (:argument 2)))
(:result-types unsigned-num unsigned-num)
(:generator 2
(move lo carry-in)
(inst mov hi 0)
(inst umlal lo hi x y)))
(define-vop (bignum-mult-and-add-4-arg)
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :to :result)
(y :scs (unsigned-reg) :to :result)
(prev :scs (unsigned-reg) :to :eval)
(carry-in :scs (unsigned-reg) :to :eval))
(:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
(:results (hi :scs (unsigned-reg) :from :eval)
(lo :scs (unsigned-reg) :from :eval))
(:result-types unsigned-num unsigned-num)
(:generator 9
(inst adds lo prev carry-in)
(inst mov :cs hi 1)
(inst mov :cc hi 0)
(inst umlal lo hi x y)))
(define-vop (bignum-mult)
(:translate sb!bignum:%multiply)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg))
(y :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(:results (hi :scs (unsigned-reg))
(lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 1
(inst umull lo hi x y)))
#!+multiply-high-vops
(define-vop (mulhi)
(:translate %multiply-high)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :target hi)
(y :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg) lo)
(:results (hi :scs (unsigned-reg)))
(:result-types unsigned-num)
(:generator 20
(inst umull lo hi x y)))
#!+multiply-high-vops
(define-vop (mulhi/fx)
(:translate %multiply-high)
(:policy :fast-safe)
(:args (x :scs (any-reg) :target hi)
(y :scs (unsigned-reg)))
(:arg-types positive-fixnum unsigned-num)
(:temporary (:sc any-reg) lo)
(:results (hi :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 15
(inst umull lo hi x y)
(inst bic hi hi fixnum-tag-mask)))
(define-vop (bignum-lognot lognot-mod32/unsigned=>unsigned)
(:translate sb!bignum:%lognot))
(define-vop (bignum-floor)
(:translate sb!bignum:%bigfloor)
(:policy :fast-safe)
(:args (div-high :scs (unsigned-reg) :target rem)
(div-low :scs (unsigned-reg) :target quo)
(divisor :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:results (quo :scs (unsigned-reg) :from (:argument 1))
(rem :scs (unsigned-reg) :from (:argument 0)))
(:result-types unsigned-num unsigned-num)
(:generator 300
(move rem div-high)
(move quo div-low)
(dotimes (i 33)
(inst cmp rem divisor)
(inst sub :hs rem rem divisor)
(inst adcs quo quo quo)
(unless (= i 32)
(inst adc rem rem rem)))))
(define-vop (signify-digit)
(:translate sb!bignum:%fixnum-digit-with-correct-sign)
(:policy :fast-safe)
(:args (digit :scs (unsigned-reg) :target res))
(:arg-types unsigned-num)
(:results (res :scs (any-reg signed-reg)))
(:result-types signed-num)
(:generator 1
(if (sc-is res any-reg)
(inst mov res (lsl digit n-fixnum-tag-bits))
(inst mov res digit))))
(define-vop (digit-ashr)
(:translate sb!bignum:%ashr)
(:policy :fast-safe)
(:args (digit :scs (unsigned-reg))
(count :scs (unsigned-reg)))
(:arg-types unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(:generator 1
(inst mov result (asr digit count))))
(define-vop (digit-lshr digit-ashr)
(:translate sb!bignum:%digit-logical-shift-right)
(:generator 1
(inst mov result (lsr digit count))))
(define-vop (digit-ashl digit-ashr)
(:translate sb!bignum:%ashl)
(:generator 1
(inst mov result (lsl digit count))))
;;;; Static functions.
(define-static-fun two-arg-gcd (x y) :translate gcd)
(define-static-fun two-arg-lcm (x y) :translate lcm)
(define-static-fun two-arg-+ (x y) :translate +)
(define-static-fun two-arg-- (x y) :translate -)
(define-static-fun two-arg-* (x y) :translate *)
(define-static-fun two-arg-/ (x y) :translate /)
(define-static-fun two-arg-< (x y) :translate <)
(define-static-fun two-arg-> (x y) :translate >)
(define-static-fun two-arg-= (x y) :translate =)
(define-static-fun two-arg-and (x y) :translate logand)
(define-static-fun two-arg-ior (x y) :translate logior)
(define-static-fun two-arg-xor (x y) :translate logxor)
(define-static-fun two-arg-eqv (x y) :translate logeqv)
(define-static-fun eql (x y) :translate eql)
(define-static-fun %negate (x) :translate %negate)

426
src/compiler/arm64/array.lisp Normal file
View file

@ -0,0 +1,426 @@
;;;; array operations for the ARM VM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; Allocator for the array header.
(define-vop (make-array-header)
(:translate make-array-header)
(:policy :fast-safe)
(:args (type :scs (any-reg))
(rank :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:results (result :scs (descriptor-reg)))
(:generator 5
;; Compute the allocation size.
(inst add ndescr rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
lowtag-mask))
(inst bic ndescr ndescr lowtag-mask)
(pseudo-atomic (pa-flag)
(allocation header ndescr other-pointer-lowtag :flag-tn pa-flag)
;; Now that we have the space allocated, compute the header
;; value.
(inst add ndescr rank (fixnumize (1- array-dimensions-offset)))
(inst mov ndescr (lsl ndescr (- n-widetag-bits n-fixnum-tag-bits)))
(inst orr ndescr ndescr (lsr type n-fixnum-tag-bits))
;; And store the header value.
(storew ndescr header 0 other-pointer-lowtag))
(move result header)))
(define-vop (make-array-header/c)
(:translate make-array-header)
(:policy :fast-safe)
(:arg-types (:constant t) (:constant t))
(:info type rank)
(:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:results (result :scs (descriptor-reg)))
(:generator 4
(let* ((header-size (+ rank
(1- array-dimensions-offset)))
(bytes (logandc2 (+ (* (1+ header-size) n-word-bytes)
lowtag-mask)
lowtag-mask))
(header-bits (logior (ash header-size
n-widetag-bits)
type)))
(pseudo-atomic (pa-flag)
(allocation header bytes other-pointer-lowtag :flag-tn pa-flag)
(load-immediate-word pa-flag header-bits)
(storew pa-flag header 0 other-pointer-lowtag)))
(move result header)))
;;;; Additional accessors and setters for the array header.
(define-full-reffer %array-dimension *
array-dimensions-offset other-pointer-lowtag
(any-reg) positive-fixnum sb!kernel:%array-dimension)
(define-full-setter %set-array-dimension *
array-dimensions-offset other-pointer-lowtag
(any-reg) positive-fixnum sb!kernel:%set-array-dimension)
(define-vop (array-rank-vop)
(:translate sb!kernel:%array-rank)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (res :scs (any-reg descriptor-reg)))
(:generator 6
(loadw temp x 0 other-pointer-lowtag)
(inst mov temp (asr temp n-widetag-bits))
(inst sub temp temp (1- array-dimensions-offset))
(inst mov res (lsl temp n-fixnum-tag-bits))))
;;;; Bounds checking routine.
(define-vop (check-bound)
(:translate %check-bound)
(:policy :fast-safe)
(:args (array :scs (descriptor-reg))
(bound :scs (any-reg descriptor-reg))
(index :scs (any-reg descriptor-reg) :target result))
(:results (result :scs (any-reg descriptor-reg)))
(:vop-var vop)
(:save-p :compute-only)
(:generator 5
(let ((error (generate-error-code vop 'invalid-array-index-error array bound index)))
(inst cmp index bound)
(inst b :hs error)
(move result index))))
;;;; Accessors/Setters
;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
;;; elements are represented in integer registers and are built out of
;;; 8, 16, or 32 bit elements.
(macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
`(progn
(define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
vector-data-offset other-pointer-lowtag
,(remove-if #'(lambda (x) (member x '(null))) scs)
,element-type
data-vector-ref)
(define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
vector-data-offset other-pointer-lowtag ,scs ,element-type
data-vector-set)))
(def-partial-data-vector-frobs (type element-type size signed &rest scs)
`(progn
(define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
,size ,signed vector-data-offset other-pointer-lowtag ,scs
,element-type data-vector-ref)
(define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
,size vector-data-offset other-pointer-lowtag ,scs
,element-type data-vector-set))))
(def-full-data-vector-frobs simple-vector *
descriptor-reg any-reg null)
(def-partial-data-vector-frobs simple-base-string character
:byte nil character-reg)
#!+sb-unicode
(def-full-data-vector-frobs simple-character-string character character-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
:byte nil unsigned-reg signed-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
:byte nil unsigned-reg signed-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
:short nil unsigned-reg signed-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
:short nil unsigned-reg signed-reg)
(def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
unsigned-reg)
(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
unsigned-reg)
(def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
:byte t signed-reg)
(def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
:short t signed-reg)
(def-full-data-vector-frobs simple-array-unsigned-fixnum positive-fixnum
any-reg)
(def-full-data-vector-frobs simple-array-fixnum tagged-num
any-reg)
(def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
signed-reg))
;;; Integer vectors whose elements are smaller than a byte. I.e. bit, 2-bit,
;;; and 4-bit vectors.
(macrolet ((def-small-data-vector-frobs (type bits)
(let* ((elements-per-word (floor n-word-bits bits))
(bit-shift (1- (integer-length elements-per-word))))
`(progn
(define-vop (,(symbolicate "DATA-VECTOR-REF/" type))
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (unsigned-reg)))
(:arg-types ,type positive-fixnum)
(:results (value :scs (any-reg)))
(:result-types positive-fixnum)
(:temporary (:scs (interior-reg)) lip)
(:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
(:generator 20
;; Compute the offset for the word we're interested in.
(inst mov temp (lsr index ,bit-shift))
;; Load the word in question.
(inst add lip object (lsl temp word-shift))
(inst ldr result (@ lip
(- (* vector-data-offset n-word-bytes)
other-pointer-lowtag)))
;; Compute the position of the bitfield we need.
(inst and temp index ,(1- elements-per-word))
,@(when (eq *backend-byte-order* :big-endian)
`((inst eor temp temp ,(1- elements-per-word))))
,@(unless (= bits 1)
`((inst mov temp (lsl temp ,(1- (integer-length bits))))))
;; Shift the field we need to the low bits of RESULT.
(inst mov result (lsr result temp))
;; Mask out the field we're interested in.
(inst and result result ,(1- (ash 1 bits)))
;; And fixnum-tag the result.
(inst mov value (lsl result n-fixnum-tag-bits))))
(define-vop (,(symbolicate "DATA-VECTOR-SET/" type))
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (unsigned-reg) :target shift)
(value :scs (unsigned-reg immediate) :target result))
(:arg-types ,type positive-fixnum positive-fixnum)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:temporary (:scs (interior-reg)) lip)
(:temporary (:scs (non-descriptor-reg)) temp old)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
(:generator 25
;; Compute the offset for the word we're interested in.
(inst mov temp (lsr index ,bit-shift))
(inst mov temp (lsl temp n-fixnum-tag-bits))
;; Load the word in question.
(inst add lip object temp)
(inst ldr old (@ lip
(- (* vector-data-offset n-word-bytes)
other-pointer-lowtag)))
;; Compute the position of the bitfield we need.
(inst and shift index ,(1- elements-per-word))
,@(when (eq *backend-byte-order* :big-endian)
`((inst eor shift ,(1- elements-per-word))))
,@(unless (= bits 1)
`((inst mov shift (lsl shift ,(1- (integer-length bits))))))
;; Clear the target bitfield.
(unless (and (sc-is value immediate)
(= (tn-value value) ,(1- (ash 1 bits))))
(inst mov temp ,(1- (ash 1 bits)))
(inst bic old old (lsl temp shift)))
;; LOGIOR in the new value (shifted appropriatly).
(sc-case value
(immediate
(inst mov temp (logand (tn-value value) ,(1- (ash 1 bits)))))
(unsigned-reg
(inst and temp value ,(1- (ash 1 bits)))))
(inst orr old old (lsl temp shift))
;; Write the altered word back to the array.
(inst str old (@ lip
(- (* vector-data-offset n-word-bytes)
other-pointer-lowtag)))
;; And present the result properly.
(sc-case value
(immediate
(inst mov result (tn-value value)))
(unsigned-reg
(move result value)))))))))
(def-small-data-vector-frobs simple-bit-vector 1)
(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
(def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
;;; And the float variants.
(define-vop (data-vector-ref/simple-array-single-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (any-reg)))
(:arg-types simple-array-single-float positive-fixnum)
(:results (value :scs (single-reg)))
(:temporary (:scs (interior-reg)) lip)
(:result-types single-float)
(:generator 5
(inst add lip object (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(inst add lip lip index)
(inst flds value (@ lip))))
(define-vop (data-vector-set/simple-array-single-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (any-reg))
(value :scs (single-reg) :target result))
(:arg-types simple-array-single-float positive-fixnum single-float)
(:results (result :scs (single-reg)))
(:result-types single-float)
(:temporary (:scs (interior-reg)) lip)
(:generator 5
(inst add lip object (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(inst add lip lip index)
(inst fsts value (@ lip))
(unless (location= result value)
(inst fcpys result value))))
(define-vop (data-vector-ref/simple-array-double-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (any-reg)))
(:arg-types simple-array-double-float positive-fixnum)
(:results (value :scs (double-reg)))
(:result-types double-float)
(:temporary (:scs (interior-reg)) lip)
(:generator 7
(inst add lip object (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(inst add lip lip (lsl index 1))
(inst fldd value (@ lip))))
(define-vop (data-vector-set/simple-array-double-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (any-reg))
(value :scs (double-reg) :target result))
(:arg-types simple-array-double-float positive-fixnum double-float)
(:results (result :scs (double-reg)))
(:result-types double-float)
(:temporary (:scs (interior-reg)) lip)
(:generator 20
(inst add lip object (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(inst add lip lip (lsl index 1))
(inst fstd value (@ lip))
(unless (location= result value)
(inst fcpyd result value))))
;;; Complex float arrays.
(define-vop (data-vector-ref/simple-array-complex-single-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
(index :scs (any-reg)))
(:arg-types simple-array-complex-single-float positive-fixnum)
(:results (value :scs (complex-single-reg)))
(:temporary (:scs (interior-reg)) lip)
(:result-types complex-single-float)
(:generator 5
(let ((real-tn (complex-single-reg-real-tn value)))
(inst add lip object (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(inst add lip lip (lsl index 1))
(inst flds real-tn (@ lip)))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(inst flds imag-tn (@ lip n-word-bytes)))))
(define-vop (data-vector-set/simple-array-complex-single-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
(index :scs (any-reg))
(value :scs (complex-single-reg) :target result))
(:arg-types simple-array-complex-single-float positive-fixnum
complex-single-float)
(:results (result :scs (complex-single-reg)))
(:result-types complex-single-float)
(:temporary (:scs (interior-reg)) lip)
(:generator 5
(let ((value-real (complex-single-reg-real-tn value))
(result-real (complex-single-reg-real-tn result)))
(inst add lip object (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(inst add lip lip (lsl index 1))
(inst fsts value-real (@ lip))
(unless (location= result-real value-real)
(inst fcpys result-real value-real)))
(let ((value-imag (complex-single-reg-imag-tn value))
(result-imag (complex-single-reg-imag-tn result)))
(inst fsts value-imag (@ lip n-word-bytes))
(unless (location= result-imag value-imag)
(inst fcpys result-imag value-imag)))))
(define-vop (data-vector-ref/simple-array-complex-double-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
(index :scs (any-reg)))
(:arg-types simple-array-complex-double-float positive-fixnum)
(:results (value :scs (complex-double-reg)))
(:result-types complex-double-float)
(:temporary (:scs (interior-reg)) lip)
(:generator 7
(let ((real-tn (complex-double-reg-real-tn value)))
(inst add lip object (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(inst add lip lip (lsl index 2))
(inst fldd real-tn (@ lip)))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(inst fldd imag-tn (@ lip (* 2 n-word-bytes))))))
(define-vop (data-vector-set/simple-array-complex-double-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
(index :scs (any-reg))
(value :scs (complex-double-reg) :target result))
(:arg-types simple-array-complex-double-float positive-fixnum
complex-double-float)
(:results (result :scs (complex-double-reg)))
(:result-types complex-double-float)
(:temporary (:scs (interior-reg)) lip)
(:generator 20
(let ((value-real (complex-double-reg-real-tn value))
(result-real (complex-double-reg-real-tn result)))
(inst add lip object (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(inst add lip lip (lsl index 2))
(inst fstd value-real (@ lip))
(unless (location= result-real value-real)
(inst fcpyd result-real value-real)))
(let ((value-imag (complex-double-reg-imag-tn value))
(result-imag (complex-double-reg-imag-tn result)))
(inst fstd value-imag (@ lip (* 2 n-word-bytes)))
(unless (location= result-imag value-imag)
(inst fcpyd result-imag value-imag)))))
;;; These vops are useful for accessing the bits of a vector irrespective of
;;; what type of vector it is.
(define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
(unsigned-reg) unsigned-num %vector-raw-bits)
(define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
(unsigned-reg) unsigned-num %set-vector-raw-bits)

23
src/compiler/arm64/backend-parms.lisp Normal file
View file

@ -0,0 +1,23 @@
(in-package "SB!VM")
(def!constant +backend-fasl-file-implementation+ :arm)
(setf *backend-byte-order*
#!+little-endian :little-endian
#!-little-endian :big-endian)
(eval-when (:compile-toplevel :load-toplevel :execute)
;; Minumum observed value, not authoritative.
(setf *backend-page-bytes* 4096))
;;; The size in bytes of GENCGC cards, i.e. the granularity at which
;;; writes to old generations are logged. With mprotect-based write
;;; barriers, this must be a multiple of the OS page size.
(def!constant gencgc-card-bytes *backend-page-bytes*)
;;; The minimum size of new allocation regions. While it doesn't
;;; currently make a lot of sense to have a card size lower than
;;; the alloc granularity, it will, once we are smarter about finding
;;; the start of objects.
(def!constant gencgc-alloc-granularity 0)
;;; The minimum size at which we release address ranges to the OS.
;;; This must be a multiple of the OS page size.
(def!constant gencgc-release-granularity *backend-page-bytes*)

549
src/compiler/arm64/c-call.lisp Normal file
View file

@ -0,0 +1,549 @@
;;;; VOPs and other machine-specific support routines for call-out to C
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(defconstant +number-stack-alignment-mask+ 7)
(defconstant +max-register-args+ 4)
(defun my-make-wired-tn (prim-type-name sc-name offset)
(make-wired-tn (primitive-type-or-lose prim-type-name)
(sc-number-or-lose sc-name)
offset))
(defstruct arg-state
(num-register-args 0)
#!-arm-softfp
(fp-registers 0)
(stack-frame-size 0))
(defstruct (result-state (:copier nil))
(num-results 0))
(defun result-reg-offset (slot)
(ecase slot
(0 nargs-offset)
(1 nl3-offset)))
(defun register-args-offset (index)
(elt '(#.ocfp-offset #.nargs-offset #.nl2-offset #.nl3-offset)
index))
(defun int-arg (state prim-type reg-sc stack-sc)
(let ((reg-args (arg-state-num-register-args state)))
(cond ((< reg-args +max-register-args+)
(setf (arg-state-num-register-args state) (1+ reg-args))
(my-make-wired-tn prim-type reg-sc (register-args-offset reg-args)))
(t
(let ((frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ frame-size))
(my-make-wired-tn prim-type stack-sc frame-size))))))
(define-alien-type-method (integer :arg-tn) (type state)
(if (alien-integer-type-signed type)
(int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
(int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
(define-alien-type-method (system-area-pointer :arg-tn) (type state)
(declare (ignore type))
(int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
#!+arm-softfp
(define-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(int-arg state 'single-float 'unsigned-reg 'single-stack))
#!-arm-softfp
(define-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(let ((register (arg-state-fp-registers state)))
(cond ((> register 15)
(let ((frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ frame-size))
(my-make-wired-tn 'single-float 'single-stack frame-size)))
(t
(incf (arg-state-fp-registers state))
(my-make-wired-tn 'single-float 'single-reg register)))))
#!+arm-softfp
(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let* ((register (arg-state-num-register-args state))
;; The registers used are aligned, only r0-r1 and r2-r3 pairs
;; can be used.
(register (+ register (logand register 1))))
(cond ((> (+ register 2) +max-register-args+)
(setf (arg-state-num-register-args state) +max-register-args+)
(let ((frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (+ frame-size 2))
(my-make-wired-tn 'double-float 'double-stack frame-size)))
(t
(setf (arg-state-num-register-args state) (+ register 2))
(list
(my-make-wired-tn 'unsigned-byte-32 'unsigned-reg
(register-args-offset register))
(my-make-wired-tn 'unsigned-byte-32 'unsigned-reg
(register-args-offset (1+ register)))
'move-double-to-int-args)))))
#!-arm-softfp
(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let ((register (setf (arg-state-fp-registers state)
(logandc2 (+ (arg-state-fp-registers state) 1) 1))))
(cond ((> register 15)
(let ((frame-size
;; align
(setf (arg-state-stack-frame-size state)
(logandc2 (+ (arg-state-stack-frame-size state) 1) 1))))
(setf (arg-state-stack-frame-size state) (+ frame-size 2))
(my-make-wired-tn 'double-float 'double-stack frame-size)))
(t
(incf (arg-state-fp-registers state) 2)
(my-make-wired-tn 'double-float 'double-reg register)))))
(define-alien-type-method (integer :result-tn) (type state)
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(multiple-value-bind (ptype reg-sc)
(if (alien-integer-type-signed type)
(values 'signed-byte-32 'signed-reg)
(values 'unsigned-byte-32 'unsigned-reg))
(my-make-wired-tn ptype reg-sc
(result-reg-offset num-results)))))
(define-alien-type-method (system-area-pointer :result-tn) (type state)
(declare (ignore type state))
(my-make-wired-tn 'system-area-pointer 'sap-reg nargs-offset))
#!+arm-softfp
(define-alien-type-method (single-float :result-tn) (type state)
(declare (ignore type state))
(my-make-wired-tn 'single-float 'unsigned-reg nargs-offset))
#!-arm-softfp
(define-alien-type-method (single-float :result-tn) (type state)
(declare (ignore type state))
(my-make-wired-tn 'single-float 'single-reg 0))
#!+arm-softfp
(define-alien-type-method (double-float :result-tn) (type state)
(declare (ignore type state))
(list (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nargs-offset)
(my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl3-offset)
'move-int-args-to-double))
#!-arm-softfp
(define-alien-type-method (double-float :result-tn) (type state)
(declare (ignore type state))
(my-make-wired-tn 'double-float 'double-reg 0))
(define-alien-type-method (values :result-tn) (type state)
(let ((values (alien-values-type-values type)))
(when (> (length values) 2)
(error "Too many result values from c-call."))
(mapcar (lambda (type)
(invoke-alien-type-method :result-tn type state))
values)))
(defun make-call-out-tns (type)
(let ((arg-state (make-arg-state)))
(collect ((arg-tns))
(dolist (arg-type (alien-fun-type-arg-types type))
(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
(values (make-normal-tn *fixnum-primitive-type*)
(* (arg-state-stack-frame-size arg-state) n-word-bytes)
(arg-tns)
(invoke-alien-type-method :result-tn
(alien-fun-type-result-type type)
(make-result-state))))))
(define-vop (foreign-symbol-sap)
(:translate foreign-symbol-sap)
(:policy :fast-safe)
(:args)
(:arg-types (:constant simple-string))
(:info foreign-symbol)
(:temporary (:sc interior-reg) lip)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2
(let ((fixup-label (gen-label)))
(inst load-from-label res lip fixup-label)
(assemble (*elsewhere*)
(emit-label fixup-label)
(inst word (make-fixup foreign-symbol :foreign))))))
#!+linkage-table
(define-vop (foreign-symbol-dataref-sap)
(:translate foreign-symbol-dataref-sap)
(:policy :fast-safe)
(:args)
(:arg-types (:constant simple-string))
(:info foreign-symbol)
(:temporary (:sc interior-reg) lip)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2
(let ((fixup-label (gen-label)))
(inst load-from-label res lip fixup-label)
(inst ldr res (@ res))
(assemble (*elsewhere*)
(emit-label fixup-label)
(inst word (make-fixup foreign-symbol :foreign-dataref))))))
(define-vop (call-out)
(:args (function :scs (sap-reg sap-stack))
(args :more t))
(:results (results :more t))
(:ignore args results)
(:save-p t)
(:temporary (:sc any-reg :offset r8-offset
:from (:argument 0) :to (:result 0)) cfunc)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:temporary (:sc any-reg) temp)
(:temporary (:sc interior-reg) lip)
(:vop-var vop)
(:generator 0
(let ((call-into-c-fixup (gen-label))
(cur-nfp (current-nfp-tn vop)))
(assemble (*elsewhere*)
(emit-label call-into-c-fixup)
(inst word (make-fixup "call_into_c" :foreign)))
(when cur-nfp
(store-stack-tn nfp-save cur-nfp))
(inst load-from-label temp lip call-into-c-fixup)
(sc-case function
(sap-reg (move cfunc function))
(sap-stack
(load-stack-offset cfunc cur-nfp function)))
(inst blx temp)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save)))))
(define-vop (alloc-number-stack-space)
(:info amount)
(:result-types system-area-pointer)
(:results (result :scs (sap-reg any-reg)))
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount +number-stack-alignment-mask+)
+number-stack-alignment-mask+)))
(composite-immediate-instruction sub nsp-tn nsp-tn delta)
(move result nsp-tn)))))
(define-vop (dealloc-number-stack-space)
(:info amount)
(:policy :fast-safe)
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount +number-stack-alignment-mask+)
+number-stack-alignment-mask+)))
(composite-immediate-instruction add nsp-tn nsp-tn delta)))))
;;;
#!+arm-softfp
(define-vop (move-double-to-int-args)
(:args (double :scs (double-reg)))
(:results (lo-bits :scs (unsigned-reg))
(hi-bits :scs (unsigned-reg)))
(:arg-types double-float)
(:result-types unsigned-num unsigned-num)
(:policy :fast-safe)
(:generator 1
(inst fmrrd lo-bits hi-bits double)))
#!+arm-softfp
(define-vop (move-int-args-to-double)
(:args (lo-bits :scs (unsigned-reg))
(hi-bits :scs (unsigned-reg)))
(:results (double :scs (double-reg)))
(:arg-types unsigned-num unsigned-num)
(:result-types double-float)
(:policy :fast-safe)
(:generator 1
(inst fmdrr double lo-bits hi-bits)))
;;; long-long support
(deftransform %alien-funcall ((function type &rest args) * * :node node)
(aver (sb!c::constant-lvar-p type))
(let* ((type (sb!c::lvar-value type))
(env (sb!c::node-lexenv node))
(arg-types (alien-fun-type-arg-types type))
(result-type (alien-fun-type-result-type type)))
(aver (= (length arg-types) (length args)))
(if (or (some (lambda (type)
(and (alien-integer-type-p type)
(> (sb!alien::alien-integer-type-bits type) 32)))
arg-types)
(and (alien-integer-type-p result-type)
(> (sb!alien::alien-integer-type-bits result-type) 32)))
(collect ((new-args) (lambda-vars) (new-arg-types))
(loop with i = 0
for type in arg-types
for arg = (gensym)
do
(lambda-vars arg)
(cond ((and (alien-integer-type-p type)
(> (sb!alien::alien-integer-type-bits type) 32))
(when (oddp i)
;; long-long is only passed in pairs of r0-r1 and r2-r3,
;; and the stack is double-word aligned
(incf i)
(new-args 0)
(new-arg-types (parse-alien-type '(signed 8) env)))
(incf i 2)
(new-args `(logand ,arg #xffffffff))
(new-args `(ash ,arg -32))
(new-arg-types (parse-alien-type '(unsigned 32) env))
(if (alien-integer-type-signed type)
(new-arg-types (parse-alien-type '(signed 32) env))
(new-arg-types (parse-alien-type '(unsigned 32) env))))
(t
(incf i (cond ((or (alien-double-float-type-p type)
#!-arm-softfp (alien-single-float-type-p type))
#!+arm-softfp 2
#!-arm-softfp 0)
(t
1)))
(new-args arg)
(new-arg-types type))))
(cond ((and (alien-integer-type-p result-type)
(> (sb!alien::alien-integer-type-bits result-type) 32))
(let ((new-result-type
(let ((sb!alien::*values-type-okay* t))
(parse-alien-type
(if (alien-integer-type-signed result-type)
'(values (unsigned 32) (signed 32))
'(values (unsigned 32) (unsigned 32)))
env))))
`(lambda (function type ,@(lambda-vars))
(declare (ignore type))
(multiple-value-bind (low high)
(%alien-funcall function
',(make-alien-fun-type
:arg-types (new-arg-types)
:result-type new-result-type)
,@(new-args))
(logior low (ash high 32))))))
(t
`(lambda (function type ,@(lambda-vars))
(declare (ignore type))
(%alien-funcall function
',(make-alien-fun-type
:arg-types (new-arg-types)
:result-type result-type)
,@(new-args))))))
(sb!c::give-up-ir1-transform))))
;;; Callback
#-sb-xc-host
(defun alien-callback-accessor-form (type sap offset)
(let ((parsed-type type))
(if (alien-integer-type-p parsed-type)
(let ((bits (sb!alien::alien-integer-type-bits parsed-type)))
(let ((byte-offset
(cond ((< bits n-word-bits)
(- n-word-bytes
(ceiling bits n-byte-bits)))
(t 0))))
`(deref (sap-alien (sap+ ,sap
,(+ byte-offset offset))
(* ,type)))))
`(deref (sap-alien (sap+ ,sap ,offset) (* ,type))))))
#-sb-xc-host
(defun alien-callback-assembler-wrapper (index result-type argument-types)
(flet ((make-tn (offset &optional (sc-name 'any-reg))
(make-random-tn :kind :normal
:sc (sc-or-lose sc-name)
:offset offset)))
(let* ((segment (make-segment))
;; How many arguments have been copied
(arg-count 0)
;; How many arguments have been copied from the stack
(stack-argument-count 0)
(r0-tn (make-tn 0))
(r1-tn (make-tn 1))
(r2-tn (make-tn 2))
(r3-tn (make-tn 3))
(r4-tn (make-tn 4))
(temp-tn (make-tn 5))
(nsp-save-tn (make-tn 6))
#!-arm-softfp
(fp-registers 0)
(gprs (list r0-tn r1-tn r2-tn r3-tn))
(frame-size
(loop for type in argument-types
sum (* n-word-bytes
(if (or (alien-double-float-type-p type)
(and (alien-integer-type-p type)
(eql (alien-type-bits type) 64)))
2
1)))))
(setf frame-size (logandc2 (+ frame-size +number-stack-alignment-mask+)
+number-stack-alignment-mask+))
(assemble (segment)
(emit-word segment #xe92d4ff8) ;; stmfd sp!, {r3-r11, lr}
(move nsp-save-tn nsp-tn)
;; Make room on the stack for arguments.
(when (plusp frame-size)
(inst sub nsp-tn nsp-tn frame-size))
;; Copy arguments
(dolist (type argument-types)
(let ((target-tn (@ nsp-tn (* arg-count n-word-bytes)))
;; A TN pointing to the stack location that contains
;; the next argument passed on the stack.
;; 10 is the amount of registers saved by stmfd above.
(stack-arg-tn (@ nsp-save-tn (* (+ 10 stack-argument-count)
n-word-bytes))))
(cond ((or (and (alien-integer-type-p type)
(not (eql (alien-type-bits type) 64)))
(alien-pointer-type-p type)
(alien-type-= #.(parse-alien-type 'system-area-pointer nil)
type)
#!+arm-softfp
(alien-single-float-type-p type))
(let ((gpr (pop gprs)))
(cond (gpr
(inst str gpr target-tn))
(t
(incf stack-argument-count)
(inst ldr temp-tn stack-arg-tn)
(inst str temp-tn target-tn))))
(incf arg-count))
((or #!+arm-softfp
(alien-double-float-type-p type)
;; long-long
(alien-integer-type-p type))
(let ((left (length gprs)))
(case left
((2 3 4)
(when (= left 3)
(pop gprs))
(inst str (pop gprs) (@ nsp-tn (* arg-count n-word-bytes)))
(incf arg-count)
(inst str (pop gprs) (@ nsp-tn (* arg-count n-word-bytes)))
(incf arg-count))
(t
(pop gprs)
;; two-word aligned
(setf stack-argument-count
(logandc2 (+ stack-argument-count 1) 1))
(inst ldr temp-tn (@ nsp-save-tn (* (+ 10 stack-argument-count)
n-word-bytes)))
(inst str temp-tn (@ nsp-tn (* arg-count n-word-bytes)))
(incf arg-count)
(inst ldr temp-tn (@ nsp-save-tn (* (+ 11 stack-argument-count)
n-word-bytes)))
(inst str temp-tn (@ nsp-tn (* arg-count n-word-bytes)))
(incf stack-argument-count 2)
(incf arg-count)))))
#!-arm-softfp
((alien-double-float-type-p type)
(setf fp-registers (logandc2 (+ fp-registers 1) 1))
(cond
((> fp-registers 15)
;; align
(setf stack-argument-count
(logandc2 (+ stack-argument-count 1) 1))
(inst ldr temp-tn (@ nsp-save-tn (* (+ 10 stack-argument-count)
n-word-bytes)))
(inst str temp-tn (@ nsp-tn (* arg-count n-word-bytes)))
(incf arg-count)
(inst ldr temp-tn (@ nsp-save-tn (* (+ 11 stack-argument-count)
n-word-bytes)))
(inst str temp-tn (@ nsp-tn (* arg-count n-word-bytes)))
(incf stack-argument-count 2)
(incf arg-count))
(t
(inst fstd (make-tn fp-registers 'double-reg) target-tn)
(incf fp-registers 2)
(incf arg-count 2))))
#!-arm-softfp
((alien-single-float-type-p type)
(cond ((> fp-registers 15)
(incf stack-argument-count)
(inst ldr temp-tn stack-arg-tn)
(inst str temp-tn target-tn))
(t
(inst fsts (make-tn fp-registers 'single-reg) target-tn)
(incf fp-registers 1)))
(incf arg-count 1))
(t
(bug "Unknown alien floating point type: ~S" type)))))
;; arg0 to FUNCALL3 (function)
;;
;; Indirect the access to ENTER-ALIEN-CALLBACK through
;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK*
;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK.
;; Skip any SB-THREAD TLS magic, since we don't expect anyone
;; to rebind the variable. -- JES, 2006-01-01
(load-immediate-word r0-tn (+ nil-value (static-symbol-offset
'sb!alien::*enter-alien-callback*)))
(loadw r0-tn r0-tn symbol-value-slot other-pointer-lowtag)
;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index)
(inst mov r1-tn (fixnumize index))
;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)
(inst mov r2-tn nsp-tn)
;; add room on stack for return value
(inst sub nsp-tn nsp-tn 8)
;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value)
(inst mov r3-tn nsp-tn)
;; Call
(load-immediate-word r4-tn (foreign-symbol-address "funcall3"))
(inst blx r4-tn)
;; Result now on top of stack, put it in the right register
(cond
((or (and (alien-integer-type-p result-type)
(not (eql (alien-type-bits result-type) 64)))
(alien-pointer-type-p result-type)
(alien-type-= #.(parse-alien-type 'system-area-pointer nil)
result-type)
#!+arm-softfp
(alien-single-float-type-p result-type))
(loadw r0-tn nsp-tn))
((or #!+arm-softfp (alien-double-float-type-p result-type)
;; long-long
(alien-integer-type-p result-type))
(loadw r0-tn nsp-tn)
(loadw r1-tn nsp-tn 1))
#!-arm-softfp
((alien-single-float-type-p result-type)
(inst flds (make-tn 0 'single-reg) (@ nsp-tn)))
#!-arm-softfp
((alien-double-float-type-p result-type)
(inst fldd (make-tn 0 'double-reg) (@ nsp-tn)))
((alien-void-type-p result-type))
(t
(error "Unrecognized alien type: ~A" result-type)))
(move nsp-tn nsp-save-tn)
(emit-word segment #xe8bd4ff8) ;; ldmfd sp!, {r3-r11, lr}
(inst bx lr-tn))
(finalize-segment segment)
;; Now that the segment is done, convert it to a static
;; vector we can point foreign code to.
(let* ((buffer (sb!assem::segment-buffer segment))
(vector (make-static-vector (length buffer)
:element-type '(unsigned-byte 8)
:initial-contents buffer))
(sap (vector-sap vector)))
(alien-funcall
(extern-alien "os_flush_icache"
(function void
system-area-pointer
unsigned-long))
sap (length buffer))
vector))))

1223
src/compiler/arm64/call.lisp Normal file
View file

File diff suppressed because it is too large Load diff

342
src/compiler/arm64/cell.lisp Normal file
View file

@ -0,0 +1,342 @@
;;;; the VM definition of various primitive memory access VOPs for the
;;;; ARM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; Data object ref/set stuff.
(define-vop (slot)
(:args (object :scs (descriptor-reg)))
(:info name offset lowtag)
(:ignore name)
(:results (result :scs (descriptor-reg any-reg)))
(:generator 1
(loadw result object offset lowtag)))
(define-vop (set-slot)
(:args (object :scs (descriptor-reg))
(value :scs (descriptor-reg any-reg)))
(:info name offset lowtag)
(:ignore name)
(:results)
(:generator 1
(storew value object offset lowtag)))
(define-vop (init-slot set-slot))
;;;; Symbol hacking VOPs:
;;; The compiler likes to be able to directly SET symbols.
;;;
(define-vop (set cell-set)
(:variant symbol-value-slot other-pointer-lowtag))
;;; Do a cell ref with an error check for being unbound.
;;;
(define-vop (checked-cell-ref)
(:args (object :scs (descriptor-reg) :target obj-temp))
(:results (value :scs (descriptor-reg any-reg)))
(:policy :fast-safe)
(:vop-var vop)
(:save-p :compute-only)
(:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
;;; With Symbol-Value, we check that the value isn't the trap object. So
;;; Symbol-Value of NIL is NIL.
;;;
(define-vop (symbol-value checked-cell-ref)
(:translate symbol-value)
(:generator 9
(move obj-temp object)
(loadw value obj-temp symbol-value-slot other-pointer-lowtag)
(let ((err-lab (generate-error-code vop 'unbound-symbol-error obj-temp)))
(inst cmp value unbound-marker-widetag)
(inst b :eq err-lab))))
;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
(define-vop (boundp-frob)
(:args (object :scs (descriptor-reg)))
(:conditional)
(:info target not-p)
(:policy :fast-safe)
(:temporary (:scs (descriptor-reg)) value))
(define-vop (boundp boundp-frob)
(:translate boundp)
(:generator 9
(loadw value object symbol-value-slot other-pointer-lowtag)
(inst cmp value unbound-marker-widetag)
(inst b (if not-p :eq :ne) target)))
(define-vop (fast-symbol-value cell-ref)
(:variant symbol-value-slot other-pointer-lowtag)
(:policy :fast)
(:translate symbol-value))
(define-vop (symbol-hash)
(:policy :fast-safe)
(:translate symbol-hash)
(:args (symbol :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (res :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 2
;; The symbol-hash slot of NIL holds NIL because it is also the
;; cdr slot, so we have to strip off the two low bits to make sure
;; it is a fixnum. The lowtag selection magic that is required to
;; ensure this is explained in the comment in objdef.lisp
(loadw temp symbol symbol-hash-slot other-pointer-lowtag)
(inst bic res temp fixnum-tag-mask)))
;;; On unithreaded builds these are just copies of the non-global versions.
(define-vop (%set-symbol-global-value set))
(define-vop (symbol-global-value symbol-value)
(:translate symbol-global-value))
(define-vop (fast-symbol-global-value fast-symbol-value)
(:translate symbol-global-value))
;;;; Fdefinition (fdefn) objects.
(define-vop (fdefn-fun cell-ref)
(:variant fdefn-fun-slot other-pointer-lowtag))
(define-vop (safe-fdefn-fun)
(:args (object :scs (descriptor-reg) :target obj-temp))
(:results (value :scs (descriptor-reg any-reg)))
(:vop-var vop)
(:save-p :compute-only)
(:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
(:generator 10
(move obj-temp object)
(loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
(inst cmp value null-tn)
(let ((err-lab (generate-error-code vop 'undefined-fun-error obj-temp)))
(inst b :eq err-lab))))
(define-vop (set-fdefn-fun)
(:policy :fast-safe)
(:translate (setf fdefn-fun))
(:args (function :scs (descriptor-reg) :target result)
(fdefn :scs (descriptor-reg)))
(:temporary (:scs (interior-reg)) lip)
(:temporary (:scs (non-descriptor-reg)) type)
(:results (result :scs (descriptor-reg)))
(:generator 38
(let ((closure-tramp-fixup (gen-label)))
(assemble (*elsewhere*)
(emit-label closure-tramp-fixup)
(inst word (make-fixup "closure_tramp" :foreign)))
(load-type type function (- fun-pointer-lowtag))
(inst cmp type simple-fun-header-widetag)
(inst mov :eq lip function)
(inst load-from-label :ne lip lip closure-tramp-fixup)
(storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(storew function fdefn fdefn-fun-slot other-pointer-lowtag)
(move result function))))
(define-vop (fdefn-makunbound)
(:policy :fast-safe)
(:translate fdefn-makunbound)
(:args (fdefn :scs (descriptor-reg) :target result))
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:scs (interior-reg)) lip)
(:results (result :scs (descriptor-reg)))
(:generator 38
(let ((undefined-tramp-fixup (gen-label)))
(assemble (*elsewhere*)
(emit-label undefined-tramp-fixup)
(inst word (make-fixup "undefined_tramp" :foreign)))
(storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
(inst load-from-label temp lip undefined-tramp-fixup)
(storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(move result fdefn))))
;;;; Binding and Unbinding.
;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
;;; the symbol on the binding stack and stuff the new value into the
;;; symbol.
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
(symbol :scs (descriptor-reg)))
(:temporary (:scs (descriptor-reg)) value-temp)
(:temporary (:scs (any-reg)) bsp-temp)
(:generator 5
(loadw value-temp symbol symbol-value-slot other-pointer-lowtag)
(load-symbol-value bsp-temp *binding-stack-pointer*)
(inst add bsp-temp bsp-temp (* 2 n-word-bytes))
(store-symbol-value bsp-temp *binding-stack-pointer*)
(storew value-temp bsp-temp (- binding-value-slot binding-size))
(storew symbol bsp-temp (- binding-symbol-slot binding-size))
(storew val symbol symbol-value-slot other-pointer-lowtag)))
(define-vop (unbind)
(:temporary (:scs (descriptor-reg)) symbol value)
(:temporary (:scs (any-reg)) bsp-temp)
(:temporary (:scs (any-reg)) zero-temp)
(:generator 0
(inst mov zero-temp 0)
(load-symbol-value bsp-temp *binding-stack-pointer*)
(loadw symbol bsp-temp (- binding-symbol-slot binding-size))
(loadw value bsp-temp (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
(storew zero-temp bsp-temp (- binding-symbol-slot binding-size))
(storew zero-temp bsp-temp (- binding-value-slot binding-size))
(inst sub bsp-temp bsp-temp (* 2 n-word-bytes))
(store-symbol-value bsp-temp *binding-stack-pointer*)))
(define-vop (unbind-to-here)
(:args (arg :scs (descriptor-reg any-reg) :target where))
(:temporary (:scs (any-reg) :from (:argument 0)) where)
(:temporary (:scs (descriptor-reg)) symbol value)
(:temporary (:scs (any-reg)) bsp-temp zero-temp)
(:generator 0
(load-symbol-value bsp-temp *binding-stack-pointer*)
(inst mov zero-temp 0)
(move where arg)
(inst cmp where bsp-temp)
(inst b :eq DONE)
LOOP
(loadw symbol bsp-temp (- binding-symbol-slot binding-size))
(inst cmp symbol 0)
(loadw value bsp-temp (- binding-value-slot binding-size) 0 :ne)
(storew value symbol symbol-value-slot other-pointer-lowtag :ne)
(storew zero-temp bsp-temp (- binding-symbol-slot binding-size) 0 :ne)
(storew zero-temp bsp-temp (- binding-value-slot binding-size))
(inst sub bsp-temp bsp-temp (* 2 n-word-bytes))
(inst cmp where bsp-temp)
(inst b :ne LOOP)
DONE
(store-symbol-value bsp-temp *binding-stack-pointer*)))
;;;; Closure indexing.
(define-full-reffer closure-index-ref *
closure-info-offset fun-pointer-lowtag
(descriptor-reg any-reg) * %closure-index-ref)
(define-full-setter set-funcallable-instance-info *
funcallable-instance-info-offset fun-pointer-lowtag
(descriptor-reg any-reg null) * %set-funcallable-instance-info)
(define-full-reffer funcallable-instance-info *
funcallable-instance-info-offset fun-pointer-lowtag
(descriptor-reg any-reg) * %funcallable-instance-info)
(define-vop (closure-ref slot-ref)
(:variant closure-info-offset fun-pointer-lowtag))
(define-vop (closure-init slot-set)
(:variant closure-info-offset fun-pointer-lowtag))
(define-vop (closure-init-from-fp)
(:args (object :scs (descriptor-reg)))
(:info offset)
(:generator 4
(storew cfp-tn object (+ closure-info-offset offset) fun-pointer-lowtag)))
;;;; Value Cell hackery.
(define-vop (value-cell-ref cell-ref)
(:variant value-cell-value-slot other-pointer-lowtag))
(define-vop (value-cell-set cell-set)
(:variant value-cell-value-slot other-pointer-lowtag))
;;;; Instance hackery:
(define-vop (instance-length)
(:policy :fast-safe)
(:translate %instance-length)
(:args (struct :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 4
(loadw temp struct 0 instance-pointer-lowtag)
(inst mov res (lsr temp n-widetag-bits))))
(define-full-reffer instance-index-ref * instance-slots-offset
instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref)
(define-full-setter instance-index-set * instance-slots-offset
instance-pointer-lowtag (descriptor-reg any-reg null) * %instance-set)
;;;; Code object frobbing.
(define-full-reffer code-header-ref * 0 other-pointer-lowtag
(descriptor-reg any-reg) * code-header-ref)
(define-full-setter code-header-set * 0 other-pointer-lowtag
(descriptor-reg any-reg null) * code-header-set)
;;;; raw instance slot accessors
(macrolet
((define-raw-slot-vops (name ref-inst set-inst value-primtype value-sc
&key (width 1) use-lip (move-macro 'move))
(labels ((emit-generator (instruction move-result)
`((loadw offset object 0 instance-pointer-lowtag)
(inst mov offset (lsr offset n-widetag-bits))
(inst rsb offset index (lsl offset n-fixnum-tag-bits))
(inst sub offset offset (+ (* (- ,width
instance-slots-offset)
n-word-bytes)
instance-pointer-lowtag))
,@(when use-lip
'((inst add lip object offset)))
(inst ,instruction value ,(if use-lip
'(@ lip)
'(@ object offset)))
,@(when move-result
`((,move-macro result value))))))
(let ((ref-vop (symbolicate "RAW-INSTANCE-REF/" name))
(set-vop (symbolicate "RAW-INSTANCE-SET/" name)))
`(progn
(define-vop (,ref-vop)
(:translate ,(symbolicate "%" ref-vop))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (any-reg)))
(:arg-types * positive-fixnum)
(:results (value :scs (,value-sc)))
(:result-types ,value-primtype)
(:temporary (:scs (non-descriptor-reg)) offset)
,@(when use-lip '((:temporary (:scs (interior-reg)) lip)))
(:generator 5 ,@(emit-generator ref-inst nil)))
(define-vop (,set-vop)
(:translate ,(symbolicate "%" set-vop))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (any-reg))
(value :scs (,value-sc) :target result))
(:arg-types * positive-fixnum ,value-primtype)
(:results (result :scs (,value-sc)))
(:result-types ,value-primtype)
(:temporary (:scs (non-descriptor-reg)) offset)
,@(when use-lip '((:temporary (:scs (interior-reg)) lip)))
(:generator 5 ,@(emit-generator set-inst t))))))))
(define-raw-slot-vops word ldr str unsigned-num unsigned-reg)
(define-raw-slot-vops single flds fsts single-float single-reg
:use-lip t :move-macro move-single)
(define-raw-slot-vops double fldd fstd double-float double-reg
:use-lip t :width 2 :move-macro move-double)
(define-raw-slot-vops complex-single load-complex-single store-complex-single complex-single-float complex-single-reg
:use-lip t :width 2 :move-macro move-complex-single)
(define-raw-slot-vops complex-double load-complex-double store-complex-double complex-double-float complex-double-reg
:use-lip t :width 4 :move-macro move-complex-double))

114
src/compiler/arm64/char.lisp Normal file
View file

@ -0,0 +1,114 @@
;;;; the ARM VM definition of character operations
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; Moves and coercions:
;;; Move a tagged char to an untagged representation.
(define-vop (move-to-character)
(:args (x :scs (any-reg descriptor-reg)))
(:results (y :scs (character-reg)))
(:note "character untagging")
(:generator 1
(inst mov y (lsr x n-widetag-bits))))
(define-move-vop move-to-character :move
(any-reg descriptor-reg) (character-reg))
;;; Move an untagged char to a tagged representation.
(define-vop (move-from-character)
(:args (x :scs (character-reg)))
(:results (y :scs (any-reg descriptor-reg)))
(:note "character tagging")
(:generator 1
(inst mov y (lsl x n-widetag-bits))
(inst orr y y character-widetag)))
(define-move-vop move-from-character :move
(character-reg) (any-reg descriptor-reg))
;;; Move untagged character values.
(define-vop (character-move)
(:args (x :target y
:scs (character-reg)
:load-if (not (location= x y))))
(:results (y :scs (character-reg)
:load-if (not (location= x y))))
(:note "character move")
(:effects)
(:affected)
(:generator 0
(move y x)))
(define-move-vop character-move :move
(character-reg) (character-reg))
;;; Move untagged character arguments/return-values.
(define-vop (move-character-arg)
(:args (x :target y
:scs (character-reg))
(fp :scs (any-reg)
:load-if (not (sc-is y character-reg))))
(:results (y))
(:note "character arg move")
(:generator 0
(sc-case y
(character-reg
(move y x))
(character-stack
(store-stack-offset x fp y)))))
(define-move-vop move-character-arg :move-arg
(any-reg character-reg) (character-reg))
;;; Use standard MOVE-ARG + coercion to move an untagged character
;;; to a descriptor passing location.
(define-move-vop move-arg :move-arg
(character-reg) (any-reg descriptor-reg))
;;;; Other operations:
(define-vop (char-code)
(:translate char-code)
(:policy :fast-safe)
(:args (ch :scs (character-reg) :target res))
(:arg-types character)
(:results (res :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 1
(inst mov res (lsl ch n-fixnum-tag-bits))))
(define-vop (code-char)
(:translate code-char)
(:policy :fast-safe)
(:args (code :scs (any-reg) :target res))
(:arg-types positive-fixnum)
(:results (res :scs (character-reg)))
(:result-types character)
(:generator 1
(inst mov res (lsr code n-fixnum-tag-bits))))
(define-vop (character-compare)
(:args (x :scs (character-reg))
(y :scs (character-reg)))
(:arg-types character character)
(:policy :fast-safe)
(:note "inline comparison")
(:generator 3
(inst cmp x y)))
(define-vop (fast-char=/character character-compare)
(:translate char=)
(:conditional :eq))
(define-vop (fast-char>/character character-compare)
(:translate char>)
(:conditional :gt))
(define-vop (fast-char</character character-compare)
(:translate char<)
(:conditional :lt))

105
src/compiler/arm64/debug.lisp Normal file
View file

@ -0,0 +1,105 @@
;;;; ARM compiler support for the debugger
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(define-vop (debug-cur-sp)
(:translate sb!di::current-sp)
(:policy :fast-safe)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 1
(load-csp res)))
(define-vop (debug-cur-fp)
(:translate sb!di::current-fp)
(:policy :fast-safe)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 1
(move res cfp-tn)))
(define-vop (read-control-stack)
(:translate sb!kernel:stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
(offset :scs (any-reg)))
(:arg-types system-area-pointer positive-fixnum)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 5
(inst ldr result (@ sap offset))))
(define-vop (write-control-stack)
(:translate sb!kernel:%set-stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
(offset :scs (any-reg))
(value :scs (descriptor-reg) :target result))
(:arg-types system-area-pointer positive-fixnum *)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 5
(inst str value (@ sap offset))
(move result value)))
(define-vop (code-from-mumble)
(:policy :fast-safe)
(:args (thing :scs (descriptor-reg)))
(:results (code :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:variant-vars lowtag)
(:generator 5
(loadw temp thing 0 lowtag)
(inst mov temp (lsr temp (- n-widetag-bits word-shift)))
(inst cmp temp 0)
(unless (= lowtag other-pointer-lowtag)
(inst sub :ne temp temp (- other-pointer-lowtag lowtag)))
(inst sub :ne code thing temp)
(inst mov :eq code null-tn)))
(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))
(define-vop (%make-lisp-obj)
(:policy :fast-safe)
(:translate %make-lisp-obj)
(:args (value :scs (unsigned-reg) :target result))
(:arg-types unsigned-num)
(:results (result :scs (descriptor-reg)))
(:generator 1
(move result value)))
(define-vop (get-lisp-obj-address)
(:policy :fast-safe)
(:translate sb!di::get-lisp-obj-address)
(:args (thing :scs (descriptor-reg) :target result))
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(:generator 1
(move result thing)))
(define-vop (fun-word-offset)
(:policy :fast-safe)
(:translate sb!di::fun-word-offset)
(:args (fun :scs (descriptor-reg)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 5
(loadw res fun 0 fun-pointer-lowtag)
(inst mov res (lsr res n-widetag-bits))))

805
src/compiler/arm64/float.lisp Normal file
View file

@ -0,0 +1,805 @@
;;;; floating point support for the ARM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; Move functions:
(define-move-fun (load-single 1) (vop x y)
((single-stack) (single-reg))
(inst flds y (@ (current-nfp-tn vop) (* (tn-offset x) n-word-bytes))))
(define-move-fun (store-single 1) (vop x y)
((single-reg) (single-stack))
(inst fsts x (@ (current-nfp-tn vop) (* (tn-offset y) n-word-bytes))))
(define-move-fun (load-double 2) (vop x y)
((double-stack) (double-reg))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset x) n-word-bytes)))
(inst fldd y (@ nfp offset))))
(define-move-fun (store-double 2) (vop x y)
((double-reg) (double-stack))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset y) n-word-bytes)))
(inst fstd x (@ nfp offset))))
;;;; Move VOPs:
(macrolet ((frob (vop sc move-macro)
`(progn
(define-vop (,vop)
(:args (x :scs (,sc)
:target y
:load-if (not (location= x y))))
(:results (y :scs (,sc)
:load-if (not (location= x y))))
(:note "float move")
(:generator 0
(,move-macro y x)))
(define-move-vop ,vop :move (,sc) (,sc)))))
(frob single-move single-reg move-single)
(frob double-move double-reg move-double))
(define-vop (move-from-float)
(:args (x :to :save))
(:results (y))
(:note "float to pointer coercion")
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:temporary (:sc interior-reg) lip)
(:variant-vars double-p size type data)
(:generator 13
(with-fixed-allocation (y pa-flag type size)
(inst sub lip y other-pointer-lowtag)
(if double-p
(inst fstd x (@ lip (* data n-word-bytes)))
(inst fsts x (@ lip (* data n-word-bytes)))))))
(macrolet ((frob (name sc &rest args)
`(progn
(define-vop (,name move-from-float)
(:args (x :scs (,sc) :to :save))
(:results (y :scs (descriptor-reg)))
(:variant ,@args))
(define-move-vop ,name :move (,sc) (descriptor-reg)))))
(frob move-from-single single-reg
nil single-float-size single-float-widetag single-float-value-slot)
(frob move-from-double double-reg
t double-float-size double-float-widetag double-float-value-slot))
(macrolet ((frob (name sc double-p value)
`(progn
(define-vop (,name)
(:args (x :scs (descriptor-reg)))
(:results (y :scs (,sc)))
(:temporary (:sc interior-reg) lip)
(:note "pointer to float coercion")
(:generator 2
(inst sub lip x other-pointer-lowtag)
(inst ,(if double-p 'fldd 'flds) y
(@ lip (* ,value n-word-bytes)))))
(define-move-vop ,name :move (descriptor-reg) (,sc)))))
(frob move-to-single single-reg nil single-float-value-slot)
(frob move-to-double double-reg t double-float-value-slot))
(macrolet ((frob (name sc stack-sc double-p)
`(progn
(define-vop (,name)
(:args (x :scs (,sc) :target y)
(nfp :scs (any-reg)
:load-if (not (sc-is y ,sc))))
(:results (y))
(:note "float arg move")
(:generator ,(if double-p 2 1)
(sc-case y
(,sc
(,(if double-p 'move-double 'move-single) y x))
(,stack-sc
(let ((offset (* (tn-offset y) n-word-bytes)))
(inst ,(if double-p 'fstd 'fsts) x (@ nfp offset)))))))
(define-move-vop ,name :move-arg
(,sc descriptor-reg) (,sc)))))
(frob move-single-float-arg single-reg single-stack nil)
(frob move-double-float-arg double-reg double-stack t))
;;;; Complex float move functions
(defun complex-single-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
:offset (tn-offset x)))
(defun complex-single-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
:offset (1+ (tn-offset x))))
(defun complex-double-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
:offset (tn-offset x)))
(defun complex-double-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
:offset (+ 2 (tn-offset x))))
(define-move-fun (load-complex-single 2) (vop x y)
((complex-single-stack) (complex-single-reg))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset x) n-word-bytes)))
(inst add lr-tn nfp offset)
(inst load-complex-single y (@ lr-tn))))
(define-move-fun (store-complex-single 2) (vop x y)
((complex-single-reg) (complex-single-stack))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset y) n-word-bytes)))
(inst add lr-tn nfp offset)
(inst store-complex-single x (@ lr-tn))))
(define-move-fun (load-complex-double 4) (vop x y)
((complex-double-stack) (complex-double-reg))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset x) n-word-bytes)))
(inst add lr-tn nfp offset)
(inst load-complex-double y (@ lr-tn))))
(define-move-fun (store-complex-double 4) (vop x y)
((complex-double-reg) (complex-double-stack))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset y) n-word-bytes)))
(inst add lr-tn nfp offset)
(inst store-complex-double x (@ lr-tn))))
;;;
;;; Complex float register to register moves.
;;;
(define-vop (complex-single-move)
(:args (x :scs (complex-single-reg) :target y
:load-if (not (location= x y))))
(:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
(:note "complex single float move")
(:generator 0
(move-complex-single y x)))
(define-move-vop complex-single-move :move
(complex-single-reg) (complex-single-reg))
(define-vop (complex-double-move)
(:args (x :scs (complex-double-reg)
:target y :load-if (not (location= x y))))
(:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
(:note "complex double float move")
(:generator 0
(move-complex-double y x)))
(define-move-vop complex-double-move :move
(complex-double-reg) (complex-double-reg))
;;;
;;; Move from a complex float to a descriptor register allocating a
;;; new complex float object in the process.
;;;
(define-vop (move-from-complex-single)
(:args (x :scs (complex-single-reg) :to :save))
(:results (y :scs (descriptor-reg)))
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:note "complex single float to pointer coercion")
(:generator 13
(with-fixed-allocation (y pa-flag complex-single-float-widetag
complex-single-float-size)
(inst sub pa-flag y (- other-pointer-lowtag
(* complex-single-float-real-slot
n-word-bytes)))
(inst store-complex-single x (@ pa-flag)))))
(define-move-vop move-from-complex-single :move
(complex-single-reg) (descriptor-reg))
(define-vop (move-from-complex-double)
(:args (x :scs (complex-double-reg) :to :save))
(:results (y :scs (descriptor-reg)))
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:note "complex double float to pointer coercion")
(:generator 13
(with-fixed-allocation (y pa-flag complex-double-float-widetag
complex-double-float-size)
(inst add pa-flag y (- (* complex-double-float-real-slot
n-word-bytes)
other-pointer-lowtag))
(inst store-complex-double x (@ pa-flag)))))
(define-move-vop move-from-complex-double :move
(complex-double-reg) (descriptor-reg))
;;;
;;; Move from a descriptor to a complex float register
;;;
(define-vop (move-to-complex-single)
(:args (x :scs (descriptor-reg)))
(:results (y :scs (complex-single-reg)))
(:temporary (:sc interior-reg) lip)
(:note "pointer to complex float coercion")
(:generator 2
(inst sub lip x (- other-pointer-lowtag
(* complex-single-float-real-slot
n-word-bytes)))
(inst load-complex-single y (@ lip))))
(define-move-vop move-to-complex-single :move
(descriptor-reg) (complex-single-reg))
(define-vop (move-to-complex-double)
(:args (x :scs (descriptor-reg)))
(:results (y :scs (complex-double-reg)))
(:temporary (:sc interior-reg) lip)
(:note "pointer to complex float coercion")
(:generator 2
(inst add lip x (- (* complex-double-float-real-slot
n-word-bytes)
other-pointer-lowtag))
(inst load-complex-double y (@ lip))))
(define-move-vop move-to-complex-double :move
(descriptor-reg) (complex-double-reg))
;;;
;;; Complex float move-arg vop
;;;
(define-vop (move-complex-single-float-arg)
(:args (x :scs (complex-single-reg) :target y)
(nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
(:results (y))
(:temporary (:sc interior-reg) lip)
(:note "complex single-float arg move")
(:generator 1
(sc-case y
(complex-single-reg
(move-complex-single y x))
(complex-single-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
(inst add lip nfp offset)
(inst store-complex-single x (@ lip)))))))
(define-move-vop move-complex-single-float-arg :move-arg
(complex-single-reg descriptor-reg) (complex-single-reg))
(define-vop (move-complex-double-float-arg)
(:args (x :scs (complex-double-reg) :target y)
(nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
(:results (y))
(:temporary (:sc interior-reg) lip)
(:note "complex double-float arg move")
(:generator 2
(sc-case y
(complex-double-reg
(move-complex-double y x))
(complex-double-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
(inst add lip nfp offset)
(inst store-complex-double x (@ lip)))))))
(define-move-vop move-complex-double-float-arg :move-arg
(complex-double-reg descriptor-reg) (complex-double-reg))
;;;; Unboxed-to-boxed MOVE-ARG handling:
;; This little gem here says to use the VOP MOVE-ARG to move any float
;; registers to boxed data. MOVE-ARG only takes boxed data as input,
;; which means that the :MOVE VOPs will be used to do the appropriate
;; conversion.
(define-move-vop move-arg :move-arg
(single-reg double-reg complex-single-reg complex-double-reg)
(descriptor-reg))
;;;; Arithmetic VOPs:
(define-vop (float-op)
(:args (x) (y))
(:results (r))
(:policy :fast-safe)
(:note "inline float arithmetic")
(:vop-var vop)
(:save-p :compute-only))
(macrolet ((frob (name sc ptype)
`(define-vop (,name float-op)
(:args (x :scs (,sc))
(y :scs (,sc)))
(:results (r :scs (,sc)))
(:arg-types ,ptype ,ptype)
(:result-types ,ptype))))
(frob single-float-op single-reg single-float)
(frob double-float-op double-reg double-float))
(macrolet ((frob (op sinst sname scost dinst dname dcost)
`(progn
(define-vop (,sname single-float-op)
(:translate ,op)
(:generator ,scost
(inst ,sinst r x y)))
(define-vop (,dname double-float-op)
(:translate ,op)
(:generator ,dcost
(inst ,dinst r x y))))))
(frob + fadds +/single-float 2 faddd +/double-float 2)
(frob - fsubs -/single-float 2 fsubd -/double-float 2)
(frob * fmuls */single-float 4 fmuld */double-float 5)
(frob / fdivs //single-float 12 fdivd //double-float 19))
(macrolet ((frob (name inst translate sc type)
`(define-vop (,name)
(:args (x :scs (,sc)))
(:results (y :scs (,sc)))
(:translate ,translate)
(:policy :fast-safe)
(:arg-types ,type)
(:result-types ,type)
(:note "inline float arithmetic")
(:vop-var vop)
(:save-p :compute-only)
(:generator 1
(note-this-location vop :internal-error)
(inst ,inst y x)))))
(frob abs/single-float fabss abs single-reg single-float)
(frob abs/double-float fabsd abs double-reg double-float)
(frob %negate/single-float fnegs %negate single-reg single-float)
(frob %negate/double-float fnegd %negate double-reg double-float))
(define-vop (fsqrtd)
(:args (x :scs (double-reg)))
(:results (y :scs (double-reg)))
(:translate %sqrt)
(:policy :fast-safe)
(:arg-types double-float)
(:result-types double-float)
(:note "inline float arithmetic")
(:save-p :compute-only)
(:generator 1
(inst fsqrtd y x)))
(define-vop (fsqrts)
(:args (x :scs (single-reg)))
(:results (y :scs (single-reg)))
(:translate %sqrt)
(:policy :fast-safe)
(:arg-types single-float)
(:result-types single-float)
(:note "inline float arithmetic")
(:save-p :compute-only)
(:generator 1
(inst fsqrts y x)))
;;;; Comparison:
(define-vop (float-compare)
(:args (x) (y))
(:variant-vars format is-=)
(:policy :fast-safe)
(:note "inline float comparison")
(:vop-var vop)
(:save-p :compute-only)
(:generator 3
(note-this-location vop :internal-error)
(ecase format
(:single
(if is-=
(inst fcmps x y)
(inst fcmpes x y)))
(:double
(if is-=
(inst fcmpd x y)
(inst fcmped x y))))
(inst fmstat)))
(macrolet ((frob (name sc ptype)
`(define-vop (,name float-compare)
(:args (x :scs (,sc))
(y :scs (,sc)))
(:arg-types ,ptype ,ptype))))
(frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float))
(macrolet ((frob (translate cond sname dname is-=)
`(progn
(define-vop (,sname single-float-compare)
(:translate ,translate)
(:conditional ,cond)
(:variant :single ,is-=))
(define-vop (,dname double-float-compare)
(:translate ,translate)
(:conditional ,cond)
(:variant :double ,is-=)))))
(frob < :mi </single-float </double-float nil)
(frob > :gt >/single-float >/double-float nil)
(frob = :eq eql/single-float eql/double-float t))
(define-vop (float-compare-zero)
(:args (x))
(:info y)
(:ignore y)
(:variant-vars format is-=)
(:policy :fast-safe)
(:note "inline float comparison")
(:vop-var vop)
(:save-p :compute-only)
(:generator 2
(note-this-location vop :internal-error)
(ecase format
(:single
(if is-=
(inst fcmpzs x)
(inst fcmpezs x)))
(:double
(if is-=
(inst fcmpzd x)
(inst fcmpezd x))))
(inst fmstat)))
(macrolet ((frob (name sc ptype constant-type)
`(define-vop (,name float-compare-zero)
(:args (x :scs (,sc)))
(:arg-types ,ptype (:constant, constant-type)))))
(frob single-float-compare-zero single-reg single-float
(single-float -0s0 0s0))
(frob double-float-compare-zero double-reg double-float
(double-float -0d0 0d0)))
(macrolet ((frob (translate cond sname dname is-=)
`(progn
(define-vop (,sname single-float-compare-zero)
(:translate ,translate)
(:conditional ,cond)
(:variant :single ,is-=))
(define-vop (,dname double-float-compare-zero)
(:translate ,translate)
(:conditional ,cond)
(:variant :double ,is-=)))))
(frob < :mi </single-float-zero </double-float-zero nil)
(frob > :gt >/single-float-zero >/double-float-zero nil)
(frob = :eq eql/single-float-zero eql/double-float-zero t))
;;;; Conversion:
(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
`(define-vop (,name)
(:args (x :scs (,from-sc)))
(:temporary (:scs (single-reg)) rtemp)
(:results (y :scs (,to-sc)))
(:arg-types ,from-type)
(:result-types ,to-type)
(:policy :fast-safe)
(:note "inline float coercion")
(:translate ,translate)
(:vop-var vop)
(:save-p :compute-only)
(:generator 5
(inst fmsr rtemp x)
(inst ,inst y rtemp)))))
(frob %single-float/signed %single-float fsitos
signed-reg signed-num single-reg single-float)
(frob %double-float/signed %double-float fsitod
signed-reg signed-num double-reg double-float)
(frob %single-float/unsigned %single-float fuitos
unsigned-reg unsigned-num single-reg single-float)
(frob %double-float/unsigned %double-float fuitod
unsigned-reg unsigned-num double-reg double-float))
(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
`(define-vop (,name)
(:args (x :scs (,from-sc)))
(:results (y :scs (,to-sc)))
(:arg-types ,from-type)
(:result-types ,to-type)
(:policy :fast-safe)
(:note "inline float coercion")
(:translate ,translate)
(:vop-var vop)
(:save-p :compute-only)
(:generator 2
(note-this-location vop :internal-error)
(inst ,inst y x)))))
(frob %single-float/double-float %single-float fcvtsd
double-reg double-float single-reg single-float)
(frob %double-float/single-float %double-float fcvtds
single-reg single-float double-reg double-float))
(macrolet ((frob (trans from-sc from-type inst)
`(define-vop (,(symbolicate trans "/" from-type))
(:args (x :scs (,from-sc) :target temp))
(:temporary (:from (:argument 0) :sc single-reg) temp)
(:results (y :scs (signed-reg)))
(:arg-types ,from-type)
(:result-types signed-num)
(:translate ,trans)
(:policy :fast-safe)
(:note "inline float truncate")
(:vop-var vop)
(:save-p :compute-only)
(:generator 5
(note-this-location vop :internal-error)
(inst ,inst temp x)
(inst fmrs y temp)))))
(frob %unary-truncate/single-float single-reg single-float ftosizs)
(frob %unary-truncate/double-float double-reg double-float ftosizd)
(frob %unary-round single-reg single-float ftosis)
(frob %unary-round double-reg double-float ftosid))
(define-vop (make-single-float)
(:args (bits :scs (signed-reg) :target res
:load-if (not (sc-is bits signed-stack))))
(:results (res :scs (single-reg)
:load-if (not (sc-is res single-stack))))
(:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
(:arg-types signed-num)
(:result-types single-float)
(:translate make-single-float)
(:policy :fast-safe)
(:vop-var vop)
(:generator 4
(sc-case bits
(signed-reg
(sc-case res
(single-reg
(inst fmsr res bits))
(single-stack
(storew bits (current-nfp-tn vop) (tn-offset res)))))
(signed-stack
(sc-case res
(single-reg
(inst flds res
(@ (current-nfp-tn vop)
(* (tn-offset bits) n-word-bytes))))
(single-stack
(unless (location= bits res)
(loadw temp (current-nfp-tn vop) (tn-offset bits))
(storew temp (current-nfp-tn vop) (tn-offset res)))))))))
(define-vop (make-double-float)
(:args (hi-bits :scs (signed-reg))
(lo-bits :scs (unsigned-reg)))
(:results (res :scs (double-reg)
:load-if (not (sc-is res double-stack))))
(:arg-types signed-num unsigned-num)
(:result-types double-float)
(:translate make-double-float)
(:policy :fast-safe)
(:vop-var vop)
(:generator 2
(sc-case res
(double-reg
(inst fmdrr res lo-bits hi-bits))
(double-stack
(cond
((eq *backend-byte-order* :big-endian)
(storew hi-bits (current-nfp-tn vop) (tn-offset res))
(storew lo-bits (current-nfp-tn vop) (1+ (tn-offset res))))
(t
(storew lo-bits (current-nfp-tn vop) (tn-offset res))
(storew hi-bits (current-nfp-tn vop) (1+ (tn-offset res)))))))))
(define-vop (single-float-bits)
(:args (float :scs (single-reg descriptor-reg)
:load-if (not (sc-is float single-stack))))
(:results (bits :scs (signed-reg)
:load-if (or (sc-is float descriptor-reg single-stack)
(not (sc-is bits signed-stack)))))
(:arg-types single-float)
(:result-types signed-num)
(:translate single-float-bits)
(:policy :fast-safe)
(:vop-var vop)
(:generator 4
(sc-case bits
(signed-reg
(sc-case float
(single-reg
(inst fmrs bits float))
(single-stack
(loadw bits (current-nfp-tn vop) (tn-offset float)))
(descriptor-reg
(loadw bits float single-float-value-slot other-pointer-lowtag))))
(signed-stack
(sc-case float
(single-reg
(inst fsts float (@ (current-nfp-tn vop)
(* (tn-offset bits) n-word-bytes))))
((single-stack descriptor-reg)
;; Fun and games: This also affects PPC, silently.
;; Hopefully it's a non-issue, but I'd rather have the
;; explicit error than a silent miscompilation.
(bug "Unable to extract single-float bits from ~S to ~S" float bits)))))))
(define-vop (double-float-high-bits)
(:args (float :scs (double-reg descriptor-reg)
:load-if (not (sc-is float double-stack))))
(:results (hi-bits :scs (signed-reg)))
(:arg-types double-float)
(:result-types signed-num)
(:translate double-float-high-bits)
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case float
(double-reg
(inst fmrdh hi-bits float))
(double-stack
(loadw hi-bits (current-nfp-tn vop)
(+ (tn-offset float)
(if (eq *backend-byte-order* :big-endian)
0 1))))
(descriptor-reg
(loadw hi-bits float (+ double-float-value-slot
(if (eq *backend-byte-order* :big-endian)
0 1))
other-pointer-lowtag)))))
(define-vop (double-float-low-bits)
(:args (float :scs (double-reg descriptor-reg)
:load-if (not (sc-is float double-stack))))
(:results (lo-bits :scs (unsigned-reg)))
(:arg-types double-float)
(:result-types unsigned-num)
(:translate double-float-low-bits)
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case float
(double-reg
(inst fmrdl lo-bits float))
(double-stack
(loadw lo-bits (current-nfp-tn vop)
(+ (tn-offset float)
(if (eq *backend-byte-order* :big-endian)
1 0))))
(descriptor-reg
(loadw lo-bits float (+ double-float-value-slot
(if (eq *backend-byte-order* :big-endian)
1 0))
other-pointer-lowtag)))))
;;;; Float mode hackery:
(sb!xc:deftype float-modes () '(unsigned-byte 32))
(defknown floating-point-modes () float-modes (flushable))
(defknown ((setf floating-point-modes)) (float-modes)
float-modes)
(define-vop (floating-point-modes)
(:results (res :scs (unsigned-reg)))
(:result-types unsigned-num)
(:translate floating-point-modes)
(:policy :fast-safe)
(:generator 3
(inst fmrx res :fpscr)))
(define-vop (set-floating-point-modes)
(:args (new :scs (unsigned-reg) :target res))
(:results (res :scs (unsigned-reg)))
(:arg-types unsigned-num)
(:result-types unsigned-num)
(:translate (setf floating-point-modes))
(:policy :fast-safe)
(:generator 3
(inst fmxr :fpscr new)
(move res new)))
;;;; Complex float VOPs
(define-vop (make-complex-single-float)
(:translate complex)
(:args (real :scs (single-reg) :target r
:load-if (not (location= real r)))
(imag :scs (single-reg) :to :save))
(:arg-types single-float single-float)
(:results (r :scs (complex-single-reg) :from (:argument 0)
:load-if (not (sc-is r complex-single-stack))))
(:result-types complex-single-float)
(:note "inline complex single-float creation")
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case r
(complex-single-reg
(let ((r-real (complex-single-reg-real-tn r)))
(move-single r-real real))
(let ((r-imag (complex-single-reg-imag-tn r)))
(move-single r-imag imag)))
(complex-single-stack
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset r) n-word-bytes)))
(unless (location= real r)
(inst fsts real (@ nfp offset)))
(inst fsts imag (@ nfp (+ offset n-word-bytes))))))))
(define-vop (make-complex-double-float)
(:translate complex)
(:args (real :scs (double-reg) :target r
:load-if (not (location= real r)))
(imag :scs (double-reg) :to :save))
(:arg-types double-float double-float)
(:results (r :scs (complex-double-reg) :from (:argument 0)
:load-if (not (sc-is r complex-double-stack))))
(:result-types complex-double-float)
(:note "inline complex double-float creation")
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case r
(complex-double-reg
(let ((r-real (complex-double-reg-real-tn r)))
(move-double r-real real))
(let ((r-imag (complex-double-reg-imag-tn r)))
(move-double r-imag imag)))
(complex-double-stack
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset r) n-word-bytes)))
(unless (location= real r)
(inst fstd real (@ nfp offset)))
(inst fstd imag (@ nfp (+ offset (* 2 n-word-bytes)))))))))
(define-vop (complex-single-float-value)
(:args (x :scs (complex-single-reg) :target r
:load-if (not (sc-is x complex-single-stack))))
(:arg-types complex-single-float)
(:results (r :scs (single-reg)))
(:result-types single-float)
(:variant-vars slot)
(:policy :fast-safe)
(:vop-var vop)
(:generator 3
(sc-case x
(complex-single-reg
(let ((value-tn (ecase slot
(:real (complex-single-reg-real-tn x))
(:imag (complex-single-reg-imag-tn x)))))
(move-single r value-tn)))
(complex-single-stack
(inst flds r (@ (current-nfp-tn vop)
(* (+ (ecase slot (:real 0) (:imag 1))
(tn-offset x))
n-word-bytes)))))))
(define-vop (realpart/complex-single-float complex-single-float-value)
(:translate realpart)
(:note "complex single float realpart")
(:variant :real))
(define-vop (imagpart/complex-single-float complex-single-float-value)
(:translate imagpart)
(:note "complex single float imagpart")
(:variant :imag))
(define-vop (complex-double-float-value)
(:args (x :scs (complex-double-reg) :target r
:load-if (not (sc-is x complex-double-stack))))
(:arg-types complex-double-float)
(:results (r :scs (double-reg)))
(:result-types double-float)
(:variant-vars slot)
(:policy :fast-safe)
(:vop-var vop)
(:generator 3
(sc-case x
(complex-double-reg
(let ((value-tn (ecase slot
(:real (complex-double-reg-real-tn x))
(:imag (complex-double-reg-imag-tn x)))))
(move-double r value-tn)))
(complex-double-stack
(inst fldd r (@ (current-nfp-tn vop)
(* (+ (ecase slot (:real 0) (:imag 2))
(tn-offset x))
n-word-bytes)))))))
(define-vop (realpart/complex-double-float complex-double-float-value)
(:translate realpart)
(:note "complex double float realpart")
(:variant :real))
(define-vop (imagpart/complex-double-float complex-double-float-value)
(:translate imagpart)
(:note "complex double float imagpart")
(:variant :imag))

1927
src/compiler/arm64/insts.lisp Normal file
View file

File diff suppressed because it is too large Load diff

452
src/compiler/arm64/macros.lisp Normal file
View file

@ -0,0 +1,452 @@
;;;; a bunch of handy macros for the ARM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;; Instruction-like macros.
(defmacro move (dst src &optional (predicate :al))
"Move SRC into DST unless they are location=."
(once-only ((n-dst dst)
(n-src src))
`(unless (location= ,n-dst ,n-src)
(inst mov ,predicate ,n-dst ,n-src))))
(macrolet
((def (type inst)
(let ((real-tn-fn (symbolicate 'complex- type '-reg-real-tn))
(imag-tn-fn (symbolicate 'complex- type '-reg-imag-tn)))
`(progn
(defmacro ,(symbolicate 'move- type)
(dst src &optional (predicate :al))
(once-only ((n-dst dst)
(n-src src))
`(unless (location= ,n-dst ,n-src)
(inst ,',inst ,predicate ,n-dst ,n-src))))
(defmacro ,(symbolicate 'move-complex- type)
(dst src &optional (predicate :al))
(once-only ((n-dst dst)
(n-src src))
`(unless (location= ,n-dst ,n-src)
;; Note that the complex (single and double) float
;; registers are aligned to paired underlying
;; (single and double) registers, so there is no
;; need to worry about overlap.
(let ((src-real (,',real-tn-fn ,n-src))
(dst-real (,',real-tn-fn ,n-dst)))
(inst ,',inst ,predicate dst-real src-real))
(let ((src-imag (,',imag-tn-fn ,n-src))
(dst-imag (,',imag-tn-fn ,n-dst)))
(inst ,', inst ,predicate dst-imag src-imag)))))))))
(def single fcpys)
(def double fcpyd))
(macrolet
((def (op inst shift)
`(defmacro ,op (object base
&optional (offset 0) (lowtag 0) (predicate :al))
`(inst ,',inst ,predicate ,object
(@ ,base (- (ash ,offset ,,shift) ,lowtag))))))
(def loadw ldr word-shift)
(def storew str word-shift))
(defmacro load-symbol (reg symbol)
(once-only ((reg reg) (symbol symbol))
`(progn
(composite-immediate-instruction add ,reg null-tn (static-symbol-offset ,symbol)))))
(defmacro load-symbol-value (reg symbol &optional (predicate :al))
`(inst ldr ,predicate ,reg
(@ null-tn
(+ (static-symbol-offset ',symbol)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))))
(defmacro store-symbol-value (reg symbol &optional (predicate :al))
`(inst str ,predicate ,reg
(@ null-tn
(+ (static-symbol-offset ',symbol)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))))
(defmacro load-type (target source &optional (offset 0) (predicate :al))
"Loads the type bits of a pointer into target independent of
byte-ordering issues."
(once-only ((n-target target)
(n-source source)
(n-offset offset))
(let ((target-offset (ecase *backend-byte-order*
(:little-endian n-offset)
(:big-endian `(+ ,n-offset (1- n-word-bytes))))))
`(inst ldrb ,predicate ,n-target (@ ,n-source ,target-offset)))))
;;; Macros to handle the fact that our stack pointer isn't actually in
;;; a register (or won't be, by the time we're done).
(defmacro load-csp (target &optional (predicate :al))
`(load-symbol-value ,target *control-stack-pointer* ,predicate))
(defmacro store-csp (source &optional (predicate :al))
`(store-symbol-value ,source *control-stack-pointer* ,predicate))
;;; Macros to handle the fact that we cannot use the machine native call and
;;; return instructions.
(defmacro lisp-jump (function)
"Jump to the lisp function FUNCTION."
`(inst add pc-tn ,function
(- (ash simple-fun-code-offset word-shift)
fun-pointer-lowtag)))
(defmacro lisp-return (return-pc return-style)
"Return to RETURN-PC."
`(progn
;; Indicate a single-valued return by clearing all of the status
;; flags, or a multiple-valued return by setting all of the status
;; flags.
,(ecase return-style
(:single-value '(inst msr (cpsr :f) 0))
(:multiple-values '(inst msr (cpsr :f) #xf0000000))
(:known))
#+(or) ;; Doesn't work, can't have a negative immediate value.
(inst add pc-tn ,return-pc (- 4 other-pointer-lowtag))
(inst sub pc-tn ,return-pc (- other-pointer-lowtag 4))))
(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
;;; Move a stack TN to a register and vice-versa.
(defun load-stack-offset (reg stack stack-tn &optional (predicate :al))
(let ((offset (* (tn-offset stack-tn) n-word-bytes)))
(cond ((or (tn-p offset)
(typep offset '(unsigned-byte 12)))
(inst ldr predicate reg (@ stack offset)))
(t
(load-immediate-word reg offset)
(inst ldr predicate reg (@ stack reg))))))
(defmacro load-stack-tn (reg stack &optional (predicate :al))
`(let ((reg ,reg)
(stack ,stack))
(sc-case stack
((control-stack)
(load-stack-offset reg cfp-tn stack ,predicate)))))
(defun store-stack-offset (reg stack stack-tn &optional (predicate :al))
(let ((offset (* (tn-offset stack-tn) n-word-bytes)))
(cond ((or (typep offset '(unsigned-byte 12))
(tn-p offset))
(inst str predicate reg (@ stack offset)))
(t
(let ((low (ldb (byte 12 0) offset))
(high (mask-field (byte 20 12) offset)))
;; KLUDGE:
;; Have to do this because it is used in move vops
;; which do not have temporary registers.
;; The debugger will be not happy.
(composite-immediate-instruction add stack stack high)
(inst str predicate reg (@ stack low))
(composite-immediate-instruction sub stack stack high))))))
(defmacro store-stack-tn (stack reg &optional (predicate :al))
`(let ((stack ,stack)
(reg ,reg))
(sc-case stack
((control-stack)
(store-stack-offset reg cfp-tn stack ,predicate)))))
(defmacro maybe-load-stack-tn (reg reg-or-stack)
"Move the TN Reg-Or-Stack into Reg if it isn't already there."
(once-only ((n-reg reg)
(n-stack reg-or-stack))
`(sc-case ,n-reg
((any-reg descriptor-reg)
(sc-case ,n-stack
((any-reg descriptor-reg)
(move ,n-reg ,n-stack))
((control-stack)
(load-stack-offset ,n-reg cfp-tn ,n-stack)))))))
;;;; Storage allocation:
;;; This is the main mechanism for allocating memory in the lisp heap.
;;;
;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
;;; applied. The amount of space to be allocated is SIZE bytes (which
;;; must be a multiple of the lisp object size).
;;;
;;; Each platform seems to have its own slightly different way to do
;;; heap allocation, taking various different options as parameters.
;;; For ARM, we take the bare minimum parameters, RESULT-TN, SIZE, and
;;; LOWTAG, and we require a single temporary register called FLAG-TN
;;; to emphasize the parallelism with PSEUDO-ATOMIC (which must
;;; surround a call to ALLOCATION anyway), and to indicate that the
;;; P-A FLAG-TN is also acceptable here.
#!+gencgc
(defun allocation-tramp (alloc-tn size back-label)
(let ((fixup (gen-label)))
(when (integerp size)
(load-immediate-word alloc-tn size))
(emit-word sb!assem::**current-segment** (logior #xe92d0000
(ash 1 (if (integerp size)
(tn-offset alloc-tn)
(tn-offset size)))
(ash 1 (tn-offset lr-tn))))
(inst load-from-label alloc-tn alloc-tn fixup)
(inst blx alloc-tn)
(emit-word sb!assem::**current-segment** (logior #xe8bd0000
(ash 1 (tn-offset alloc-tn))
(ash 1 (tn-offset lr-tn))))
(inst b back-label)
(emit-label fixup)
(inst word (make-fixup "alloc_tramp" :foreign))))
(defmacro allocation (result-tn size lowtag &key flag-tn
stack-allocate-p)
;; Normal allocation to the heap.
(once-only ((result-tn result-tn)
(size size)
(lowtag lowtag)
(flag-tn flag-tn)
(stack-allocate-p stack-allocate-p))
`(cond (,stack-allocate-p
(load-csp ,result-tn)
(inst tst ,result-tn lowtag-mask)
(inst add :ne ,result-tn ,result-tn n-word-bytes)
(if (integerp ,size)
(composite-immediate-instruction add ,flag-tn ,result-tn ,size)
(inst add ,flag-tn ,result-tn ,size))
(store-csp ,flag-tn)
;; :ne is from TST above, this needs to be done after the
;; stack pointer has been stored.
(storew null-tn ,result-tn -1 0 :ne)
(inst orr ,result-tn ,result-tn ,lowtag))
#!-gencgc
(t
(load-symbol-value ,flag-tn *allocation-pointer*)
(inst add ,result-tn ,flag-tn ,lowtag)
(if (integerp ,size)
(composite-immediate-instruction add ,flag-tn ,flag-tn ,size)
(inst add ,flag-tn ,flag-tn ,size))
(store-symbol-value ,flag-tn *allocation-pointer*))
#!+gencgc
(t
(let ((fixup (gen-label))
(alloc (gen-label))
(back-from-alloc (gen-label)))
(inst load-from-label ,flag-tn ,flag-tn FIXUP)
(loadw ,result-tn ,flag-tn)
(loadw ,flag-tn ,flag-tn 1)
(if (integerp ,size)
(composite-immediate-instruction add ,result-tn ,result-tn ,size)
(inst add ,result-tn ,result-tn ,size))
(inst cmp ,result-tn ,flag-tn)
(inst b :hi ALLOC)
(inst load-from-label ,flag-tn ,flag-tn FIXUP)
(storew ,result-tn ,flag-tn)
(if (integerp ,size)
(composite-immediate-instruction sub ,result-tn ,result-tn ,size)
(inst sub ,result-tn ,result-tn ,size))
(emit-label BACK-FROM-ALLOC)
(when ,lowtag
(inst orr ,result-tn ,result-tn ,lowtag))
(assemble (*elsewhere*)
(emit-label ALLOC)
(allocation-tramp ,result-tn ,size BACK-FROM-ALLOC)
(emit-label FIXUP)
(inst word (make-fixup "boxed_region" :foreign))))))))
(defmacro with-fixed-allocation ((result-tn flag-tn type-code size
&key (lowtag other-pointer-lowtag)
stack-allocate-p)
&body body)
"Do stuff to allocate an other-pointer object of fixed Size with a single
word header having the specified Type-Code. The result is placed in
Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably
initializes the object."
(once-only ((result-tn result-tn) (flag-tn flag-tn)
(type-code type-code) (size size) (lowtag lowtag))
`(pseudo-atomic (,flag-tn)
(allocation ,result-tn (pad-data-block ,size) ,lowtag
:flag-tn ,flag-tn
:stack-allocate-p ,stack-allocate-p)
(when ,type-code
(inst mov ,flag-tn (ash (1- ,size) n-widetag-bits))
(inst orr ,flag-tn ,flag-tn ,type-code)
(storew ,flag-tn ,result-tn 0 ,lowtag))
,@body)))
;;;; Error Code
(defun emit-error-break (vop kind code values)
(assemble ()
(when vop
(note-this-location vop :internal-error))
;; Use the magic officially-undefined instruction that Linux
;; treats as generating SIGTRAP.
(inst debug-trap)
;; The rest of this is "just" the encoded error details.
(inst byte kind)
(with-adjustable-vector (vector)
(write-var-integer code vector)
(dolist (tn values)
(write-var-integer (make-sc-offset (sc-number (tn-sc tn))
(or (tn-offset tn) 0))
vector))
(inst byte (length vector))
(dotimes (i (length vector))
(inst byte (aref vector i)))
(emit-alignment word-shift))))
(defun error-call (vop error-code &rest values)
#!+sb-doc
"Cause an error. ERROR-CODE is the error to cause."
(emit-error-break vop error-trap (error-number-or-lose error-code) values))
(defun generate-error-code (vop error-code &rest values)
#!+sb-doc
"Generate-Error-Code Error-code Value*
Emit code for an error with the specified Error-Code and context Values."
(assemble (*elsewhere*)
(let ((start-lab (gen-label)))
(emit-label start-lab)
(emit-error-break vop error-trap (error-number-or-lose error-code) values)
start-lab)))
;;;; PSEUDO-ATOMIC
;;; handy macro for making sequences look atomic
;;; With LINK being NIL this doesn't store the next PC in LR when
;;; calling do_pending_interrupt.
;;; This used by allocate-vector-on-heap, there's a comment explaining
;;; why it needs that.
(defmacro pseudo-atomic ((flag-tn &key (link t)) &body forms)
`(progn
(without-scheduling ()
(store-symbol-value pc-tn *pseudo-atomic-atomic*))
(assemble ()
,@forms)
(without-scheduling ()
(store-symbol-value null-tn *pseudo-atomic-atomic*)
(load-symbol-value ,flag-tn *pseudo-atomic-interrupted*)
;; When *pseudo-atomic-interrupted* is not 0 it contains the address of
;; do_pending_interrupt
(inst cmp ,flag-tn 0)
,(if link
`(inst blx :ne ,flag-tn)
`(inst bx :ne ,flag-tn)))))
;;;; memory accessor vop generators
(defmacro define-full-reffer (name type offset lowtag scs el-type
&optional translate)
`(define-vop (,name)
,@(when translate
`((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (any-reg)))
(:arg-types ,type tagged-num)
(:temporary (:scs (interior-reg)) lip)
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 5
(inst add lip object index)
(loadw value lip ,offset ,lowtag))))
(defmacro define-full-setter (name type offset lowtag scs el-type
&optional translate)
`(define-vop (,name)
,@(when translate
`((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (any-reg))
(value :scs ,scs :target result))
(:arg-types ,type tagged-num ,el-type)
(:temporary (:scs (interior-reg)) lip)
(:results (result :scs ,scs))
(:result-types ,el-type)
(:generator 2
(inst add lip object index)
(storew value lip ,offset ,lowtag)
(move result value))))
(defmacro define-partial-reffer (name type size signed offset lowtag scs
el-type &optional translate)
`(define-vop (,name)
,@(when translate
`((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (unsigned-reg)))
(:arg-types ,type positive-fixnum)
(:results (value :scs ,scs))
(:result-types ,el-type)
(:temporary (:scs (interior-reg)) lip)
(:generator 5
,(if (eq size :byte)
'(inst add lip object index)
'(inst add lip object (lsl index 1)))
(inst ,(ecase size
(:byte (if signed 'ldrsb 'ldrb))
(:short (if signed 'ldrsh 'ldrh)))
value (@ lip (- (* ,offset n-word-bytes) ,lowtag))))))
(defmacro define-partial-setter (name type size offset lowtag scs el-type
&optional translate)
`(define-vop (,name)
,@(when translate
`((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (unsigned-reg))
(value :scs ,scs :target result))
(:arg-types ,type positive-fixnum ,el-type)
(:temporary (:scs (interior-reg)) lip)
(:results (result :scs ,scs))
(:result-types ,el-type)
(:generator 5
,(if (eq size :byte)
'(inst add lip object index)
'(inst add lip object (lsl index 1)))
(inst ,(ecase size (:byte 'strb) (:short 'strh))
value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))
(move result value))))
(def!macro with-pinned-objects ((&rest objects) &body body)
"Arrange with the garbage collector that the pages occupied by
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger
garbage collection. This is currently implemented by disabling GC"
#!-gencgc
(declare (ignore objects)) ; should we eval these for side-effect?
#!-gencgc
`(without-gcing
,@body)
#!+gencgc
`(let ((*pinned-objects* (list* ,@objects *pinned-objects*)))
(declare (truly-dynamic-extent *pinned-objects*))
,@body))

55
src/compiler/arm64/memory.lisp Normal file
View file

@ -0,0 +1,55 @@
;;;; the ARM definitions of some general purpose memory reference VOPs
;;;; inherited by basic memory reference operations
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the
;;; offset to be read or written is a property of the VOP used.
(define-vop (cell-ref)
(:args (object :scs (descriptor-reg)))
(:results (value :scs (descriptor-reg any-reg)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
(:generator 4
(loadw value object offset lowtag)))
(define-vop (cell-set)
(:args (object :scs (descriptor-reg))
(value :scs (descriptor-reg any-reg null)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
(:generator 4
(storew value object offset lowtag)))
;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref,
;;; where the offset is constant at compile time, but varies for
;;; different uses.
;;; The PPC backend says "We add in the standard g-vector overhead",
;;; what does this mean? -- AB 2012-Oct-27
(define-vop (slot-ref)
(:args (object :scs (descriptor-reg)))
(:results (value :scs (descriptor-reg any-reg)))
(:variant-vars base lowtag)
(:info offset)
(:generator 4
(loadw value object (+ base offset) lowtag)))
(define-vop (slot-set)
(:args (object :scs (descriptor-reg))
(value :scs (descriptor-reg any-reg)))
(:variant-vars base lowtag)
(:info offset)
(:generator 4
(storew value object (+ base offset) lowtag)))

325
src/compiler/arm64/move.lisp Normal file
View file

@ -0,0 +1,325 @@
;;;; the ARM VM definition of operand loading/saving and the Move VOP
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(defun lowest-set-bit-index (integer-value)
(max 0 (1- (integer-length (logand integer-value (- integer-value))))))
(defun repeating-pattern-p (val)
(declare (type (unsigned-byte 32) val))
(and (= (ldb (byte 16 0) val)
(ldb (byte 16 16) val))
(not (encodable-immediate (ldb (byte 16 16) val)))))
;;; This should be put into composite-immediate-instruction, but that
;;; macro is too scary.
(defun load-repeating-pattern (dest val)
(declare (type (signed-byte 32) val))
(inst mov dest (ldb (byte 8 0) val))
(inst orr dest dest (mask-field (byte 8 8) val))
(inst orr dest dest (lsl dest 16)))
(defun load-immediate-word (y val)
(cond ((let ((unsigned (ldb (byte 32 0) val)))
(when (encodable-immediate unsigned)
(inst mov y unsigned)
t)))
((let ((inverted (ldb (byte 32 0) (lognot val))))
(when (encodable-immediate inverted)
(inst mvn y inverted)
t)))
((< val 0)
(composite-immediate-instruction bic y y val :first-op mvn :first-no-source t :invert-y t))
((repeating-pattern-p val)
(load-repeating-pattern y val))
(t
(composite-immediate-instruction orr y y val :first-op mov :first-no-source t))))
(define-move-fun (load-immediate 1) (vop x y)
((null immediate)
(any-reg descriptor-reg))
(let ((val (tn-value x)))
(etypecase val
(integer
;; This is a FIXNUM, as IMMEDIATE-CONSTANT-SC only
;; accepts integers if they are FIXNUMs.
(load-immediate-word y (fixnumize val)))
(character
(let* ((codepoint (char-code val))
(encoded-character (dpb codepoint (byte 24 8) character-widetag)))
(load-immediate-word y encoded-character)))
(null
(move y null-tn))
(symbol
(load-symbol y val)))))
(define-move-fun (load-number 1) (vop x y)
((immediate)
(signed-reg unsigned-reg))
(load-immediate-word y (tn-value x)))
(define-move-fun (load-character 1) (vop x y)
((immediate) (character-reg))
(load-immediate-word y (char-code (tn-value x))))
(define-move-fun (load-system-area-pointer 1) (vop x y)
((immediate) (sap-reg))
(let ((immediate-label (gen-label)))
(assemble (*elsewhere*)
(emit-label immediate-label)
(inst word (sap-int (tn-value x))))
(inst ldr y (@ immediate-label))))
(define-move-fun (load-constant 5) (vop x y)
((constant) (descriptor-reg))
(let ((offset (- (ash (tn-offset x) 2) other-pointer-lowtag)))
(typecase offset
((unsigned-byte 12)
(inst ldr y (@ code-tn offset)))
(t
;; Y is a descriptor-reg, make sure offset is a fixnum.
(load-immediate-word y (ash offset n-fixnum-tag-bits))
(inst ldr y (@ code-tn (lsr y n-fixnum-tag-bits)))))))
(define-move-fun (load-stack 5) (vop x y)
((control-stack) (any-reg descriptor-reg))
(load-stack-tn y x))
(define-move-fun (load-number-stack 5) (vop x y)
((character-stack) (character-reg)
(sap-stack) (sap-reg)
(signed-stack) (signed-reg)
(unsigned-stack) (unsigned-reg))
(load-stack-offset y (current-nfp-tn vop) x))
(define-move-fun (store-stack 5) (vop x y)
((any-reg descriptor-reg) (control-stack))
(store-stack-tn y x))
(define-move-fun (store-number-stack 5) (vop x y)
((character-reg) (character-stack)
(sap-reg) (sap-stack)
(signed-reg) (signed-stack)
(unsigned-reg) (unsigned-stack))
(store-stack-offset x (current-nfp-tn vop) y))
;;;; The Move VOP:
(define-vop (move)
(:args (x :target y
:scs (any-reg descriptor-reg null)
:load-if (not (location= x y))))
(:results (y :scs (any-reg descriptor-reg)
:load-if (not (location= x y))))
(:effects)
(:affected)
(:generator 0
(move y x)))
(define-move-vop move :move
(any-reg descriptor-reg)
(any-reg descriptor-reg))
;;; Make MOVE the check VOP for T so that type check generation
;;; doesn't think it is a hairy type. This also allows checking of a
;;; few of the values in a continuation to fall out.
(primitive-type-vop move (:check) t)
;;; The MOVE-ARG VOP is used for moving descriptor values into another
;;; frame for argument or known value passing.
(define-vop (move-arg)
(:args (x :target y
:scs (any-reg descriptor-reg null))
(fp :scs (any-reg)
:load-if (not (sc-is y any-reg descriptor-reg))))
(:results (y))
(:generator 0
(sc-case y
((any-reg descriptor-reg)
(move y x))
(control-stack
(store-stack-offset x fp y)))))
;;;
(define-move-vop move-arg :move-arg
(any-reg descriptor-reg)
(any-reg descriptor-reg))
;;;; ILLEGAL-MOVE
;;; This VOP exists just to begin the lifetime of a TN that couldn't
;;; be written legally due to a type error. An error is signalled
;;; before this VOP is so we don't need to do anything (not that there
;;; would be anything sensible to do anyway.)
(define-vop (illegal-move)
(:args (x) (type))
(:results (y))
(:ignore y)
(:vop-var vop)
(:save-p :compute-only)
(:generator 666
(error-call vop 'object-not-type-error x type)))
;;;; Moves and coercions:
;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
;;; to a tagged bignum or fixnum.
;;; ARG is a fixnum, so just shift it. We need a type restriction because some
;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
(define-vop (move-to-word/fixnum)
(:args (x :scs (any-reg descriptor-reg)))
(:results (y :scs (signed-reg unsigned-reg)))
(:arg-types tagged-num)
(:note "fixnum untagging")
(:generator 1
(inst mov y (asr x n-fixnum-tag-bits))))
(define-move-vop move-to-word/fixnum :move
(any-reg descriptor-reg) (signed-reg unsigned-reg))
;;; ARG is a non-immediate constant; load it.
(define-vop (move-to-word-c)
(:args (x :scs (constant)))
(:results (y :scs (signed-reg unsigned-reg)))
(:vop-var vop)
(:note "constant load")
(:generator 1
(cond ((sb!c::tn-leaf x)
(load-immediate-word y (tn-value x)))
(t
(load-constant vop x y)
(inst mov y (asr y n-fixnum-tag-bits))))))
(define-move-vop move-to-word-c :move
(constant) (signed-reg unsigned-reg))
;;; ARG is a fixnum or bignum; figure out which and load if necessary.
(define-vop (move-to-word/integer)
(:args (x :scs (descriptor-reg)))
(:results (y :scs (signed-reg unsigned-reg)))
(:note "integer to untagged word coercion")
(:generator 4
(inst tst x fixnum-tag-mask)
(sc-case y
(signed-reg
(inst mov :eq y (asr x n-fixnum-tag-bits)))
(unsigned-reg
(inst mov :eq y (lsr x n-fixnum-tag-bits))))
(loadw y x bignum-digits-offset other-pointer-lowtag :ne)))
(define-move-vop move-to-word/integer :move
(descriptor-reg) (signed-reg unsigned-reg))
;;; RESULT is a fixnum, so we can just shift. We need the result type
;;; restriction because of the control-stack ambiguity noted above.
(define-vop (move-from-word/fixnum)
(:args (x :scs (signed-reg unsigned-reg)))
(:results (y :scs (any-reg descriptor-reg)))
(:result-types tagged-num)
(:note "fixnum tagging")
(:generator 1
(inst mov y (lsl x n-fixnum-tag-bits))))
(define-move-vop move-from-word/fixnum :move
(signed-reg unsigned-reg) (any-reg descriptor-reg))
;;; RESULT may be a bignum, so we have to check. Use a worst-case
;;; cost to make sure people know they may be number consing.
(define-vop (move-from-signed)
(:args (arg :scs (signed-reg unsigned-reg) :target x))
(:results (y :scs (any-reg descriptor-reg)))
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x)
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:note "signed word to integer coercion")
(:generator 20
(move x arg)
(inst adds pa-flag x x)
(inst adds :vc y pa-flag pa-flag)
(inst b :vc DONE)
(with-fixed-allocation (y pa-flag bignum-widetag (1+ bignum-digits-offset))
(storew x y bignum-digits-offset other-pointer-lowtag))
DONE))
(define-move-vop move-from-signed :move
(signed-reg) (descriptor-reg))
;;; Check for fixnum, and possibly allocate one or two word bignum
;;; result. Use a worst-case cost to make sure people know they may
;;; be number consing.
(define-vop (move-from-unsigned)
(:args (arg :scs (signed-reg unsigned-reg) :target x))
(:results (y :scs (any-reg descriptor-reg)))
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x)
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:note "unsigned word to integer coercion")
(:generator 20
(move x arg)
(inst tst x (ash (1- (ash 1 (- n-word-bits
n-positive-fixnum-bits)))
n-positive-fixnum-bits))
(inst mov y (lsl x n-fixnum-tag-bits))
(inst b :eq DONE)
(with-fixed-allocation
(y pa-flag bignum-widetag (+ 2 bignum-digits-offset))
;; WITH-FIXED-ALLOCATION, when using a supplied type-code,
;; leaves PA-FLAG containing the computed header value. In our
;; case, configured for a 2-word bignum. If the sign bit in the
;; value we're boxing is CLEAR, we need to shrink the bignum by
;; one word, hence the following:
(inst orrs x x 0)
(inst sub :pl pa-flag pa-flag #x100)
(storew pa-flag y 0 other-pointer-lowtag :pl)
(storew x y bignum-digits-offset other-pointer-lowtag))
DONE))
(define-move-vop move-from-unsigned :move
(unsigned-reg) (descriptor-reg))
;;; Move untagged numbers.
(define-vop (word-move)
(:args (x :target y
:scs (signed-reg unsigned-reg)
:load-if (not (location= x y))))
(:results (y :scs (signed-reg unsigned-reg)
:load-if (not (location= x y))))
(:effects)
(:affected)
(:note "word integer move")
(:generator 0
(move y x)))
(define-move-vop word-move :move
(signed-reg unsigned-reg) (signed-reg unsigned-reg))
;;; Move untagged number arguments/return-values.
(define-vop (move-word-arg)
(:args (x :target y
:scs (signed-reg unsigned-reg))
(fp :scs (any-reg)
:load-if (not (sc-is y signed-reg unsigned-reg))))
(:results (y))
(:note "word integer argument move")
(:generator 0
(sc-case y
((signed-reg unsigned-reg)
(move y x))
((signed-stack unsigned-stack)
(store-stack-offset x fp y)))))
(define-move-vop move-word-arg :move-arg
(descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
;;; Use standard MOVE-ARG + coercion to move an untagged number to a
;;; descriptor passing location.
(define-move-vop move-arg :move-arg
(signed-reg unsigned-reg) (any-reg descriptor-reg))

286
src/compiler/arm64/nlx.lisp Normal file
View file

@ -0,0 +1,286 @@
;;;; the ARM definitions of VOPs used for non-local exit (throw,
;;;; lexical exit, etc.)
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;; Make an environment-live stack TN for saving the SP for NLX entry.
(defun make-nlx-sp-tn (env)
(physenv-live-tn
(make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
env))
;;; Make a TN for the argument count passing location for a
;;; non-local entry.
(defun make-nlx-entry-arg-start-location ()
(make-wired-tn *fixnum-primitive-type* immediate-arg-scn r8-offset))
;;; Save and restore dynamic environment.
;;;
;;; These VOPs are used in the reentered function to restore the appropriate
;;; dynamic environment. Currently we only save the Current-Catch and binding
;;; stack pointer. We don't need to save/restore the current unwind-protect,
;;; since unwind-protects are implicitly processed during unwinding. If there
;;; were any additional stacks, then this would be the place to restore the top
;;; pointers.
(define-vop (save-dynamic-state)
(:results (catch :scs (descriptor-reg))
(nfp :scs (descriptor-reg))
(nsp :scs (descriptor-reg)))
(:vop-var vop)
(:generator 13
(load-symbol-value catch *current-catch-block*)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(move nfp cur-nfp)))
(move nsp nsp-tn)))
(define-vop (restore-dynamic-state)
(:args (catch :scs (descriptor-reg))
(nfp :scs (descriptor-reg))
(nsp :scs (descriptor-reg)))
(:vop-var vop)
(:generator 10
(store-symbol-value catch *current-catch-block*)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(move cur-nfp nfp)))
(move nsp-tn nsp)))
(define-vop (current-stack-pointer)
(:results (res :scs (any-reg descriptor-reg)))
(:generator 1
(load-csp res)))
(define-vop (current-binding-pointer)
(:results (res :scs (any-reg descriptor-reg)))
(:generator 1
(load-symbol-value res *binding-stack-pointer*)))
;;;; Unwind block hackery:
;;; Compute the address of the catch block from its TN, then store into the
;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
;;;
(define-vop (make-unwind-block)
(:args (tn))
(:info entry-label)
(:results (block :scs (any-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (interior-reg)) lip)
(:generator 22
(composite-immediate-instruction add block cfp-tn
(* (tn-offset tn) n-word-bytes))
(load-symbol-value temp *current-unwind-protect-block*)
(storew temp block unwind-block-current-uwp-slot)
(storew cfp-tn block unwind-block-current-cont-slot)
(storew code-tn block unwind-block-current-code-slot)
(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
;;; link the block into the Current-Catch list.
;;;
(define-vop (make-catch-block)
(:args (tn) (tag :scs (any-reg descriptor-reg)))
(:info entry-label)
(: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
(composite-immediate-instruction
add result cfp-tn (* (tn-offset tn) n-word-bytes))
(load-symbol-value temp *current-unwind-protect-block*)
(storew temp result catch-block-current-uwp-slot)
(storew cfp-tn result catch-block-current-cont-slot)
(storew code-tn result catch-block-current-code-slot)
(inst compute-lra temp lip entry-label)
(storew temp result catch-block-entry-pc-slot)
(storew tag result catch-block-tag-slot)
(load-symbol-value temp *current-catch-block*)
(storew temp result catch-block-previous-catch-slot)
(store-symbol-value result *current-catch-block*)
(move block result)))
;;; Just set the current unwind-protect to TN's address. This
;;; instantiates an unwind block as an unwind-protect.
(define-vop (set-unwind-protect)
(:args (tn))
(:temporary (:scs (descriptor-reg)) new-uwp)
(:generator 7
(composite-immediate-instruction
add new-uwp cfp-tn (* (tn-offset tn) n-word-bytes))
(store-symbol-value new-uwp *current-unwind-protect-block*)))
(define-vop (unlink-catch-block)
(:temporary (:scs (any-reg)) block)
(:policy :fast-safe)
(:translate %catch-breakup)
(:generator 17
(load-symbol-value block *current-catch-block*)
(loadw block block catch-block-previous-catch-slot)
(store-symbol-value block *current-catch-block*)))
(define-vop (unlink-unwind-protect)
(:temporary (:scs (any-reg)) block)
(:policy :fast-safe)
(:translate %unwind-protect-breakup)
(:generator 17
(load-symbol-value block *current-unwind-protect-block*)
(loadw block block unwind-block-current-uwp-slot)
(store-symbol-value block *current-unwind-protect-block*)))
;;;; NLX entry VOPs:
(define-vop (nlx-entry)
(:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
; would be inserted before the LRA.
(start)
(count))
(:results (values :more t))
(:temporary (:scs (descriptor-reg)) move-temp)
(:info label nvals)
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-return-pc label)
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
((= nvals 1)
(inst cmp count 0)
(move (tn-ref-tn values) null-tn :eq)
(loadw (tn-ref-tn values) start 0 0 :ne))
(t
(do ((i 0 (1+ i))
(tn-ref values (tn-ref-across tn-ref)))
((null tn-ref))
(let ((tn (tn-ref-tn tn-ref)))
(inst subs count count (fixnumize 1))
(sc-case tn
((descriptor-reg any-reg)
(loadw tn start i 0 :ge)
(move tn null-tn :lt))
(control-stack
(loadw move-temp start i 0 :ge)
(store-stack-tn tn move-temp :ge)
(store-stack-tn tn null-tn :lt)))))))
(load-stack-tn move-temp sp)
(store-csp move-temp)))
(define-vop (nlx-entry-multiple)
(:args (top :target result) (src) (count))
;; Again, no SC restrictions for the args, 'cause the loading would
;; happen before the entry label.
(:info label)
(:temporary (:scs (any-reg)) dst)
(:temporary (:scs (descriptor-reg)) temp)
(:results (result :scs (any-reg) :from (:argument 0))
(num :scs (any-reg) :from (:argument 0)))
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-return-pc label)
(note-this-location vop :non-local-entry)
;; Setup results, and test for the zero value case.
(load-stack-tn result top)
(inst cmp count 0)
(inst mov num 0)
(inst b :eq DONE)
;; Compute dst as one slot down from result, because we inc the index
;; before we use it.
(inst sub dst result 4)
;; Copy stuff down the stack.
LOOP
(inst ldr temp (@ src num))
(inst add num num (fixnumize 1))
(inst cmp num count)
(inst str temp (@ dst num))
(inst b :ne LOOP)
;; Reset the CSP.
DONE
(inst add temp result num)
(store-csp temp)))
;;; This VOP is just to force the TNs used in the cleanup onto the stack.
;;;
(define-vop (uwp-entry)
(:info label)
(:save-p :force-to-stack)
(:results (block) (start) (count))
(:ignore block start count)
(:vop-var vop)
(:generator 0
(emit-return-pc label)
(note-this-location vop :non-local-entry)))
(define-vop (unwind-to-frame-and-call)
(:args (ofp :scs (descriptor-reg))
(uwp :scs (descriptor-reg))
(function :scs (descriptor-reg) :to :load :target saved-function))
(:arg-types system-area-pointer system-area-pointer t)
(:temporary (:sc unsigned-reg) temp)
(:temporary (:sc descriptor-reg :offset r8-offset) saved-function)
(:temporary (:sc unsigned-reg :offset r0-offset) block)
(:temporary (:sc descriptor-reg :offset lexenv-offset) lexenv)
(:temporary (:scs (interior-reg)) lip)
(:temporary (:sc descriptor-reg :offset nargs-offset) nargs)
(:vop-var vop)
(:generator 22
(let ((uwp-label (gen-label))
(entry-label (gen-label)))
;; Store the function into a non-stack location, since we'll be
;; unwinding the stack and destroying register contents before we
;; use it. It turns out that R8 is preserved as part of the
;; normal multiple-value handling of an unwind, so use that.
(move saved-function function)
;; Allocate space for magic UWP block.
(load-csp block)
(inst add temp block (* unwind-block-size n-word-bytes))
(store-csp temp)
;; Set up magic catch / UWP block.
(loadw temp uwp sap-pointer-slot other-pointer-lowtag)
(storew temp block unwind-block-current-uwp-slot)
(loadw temp ofp sap-pointer-slot other-pointer-lowtag)
(storew temp block unwind-block-current-cont-slot)
;; Don't need to save code at unwind-block-current-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)
(storew temp block catch-block-entry-pc-slot)
;; Run any required UWPs.
(assemble (*elsewhere* vop)
(emit-label uwp-label)
(inst word (make-fixup 'unwind :assembly-routine)))
(inst load-from-label pc-tn lr-tn uwp-label)
(emit-label ENTRY-LABEL)
;; KLUDGE: either COMPUTE-LRA computes or UNWIND jumps one
;; instruction further.
(inst mov nargs 0)
(inst mov nargs 0)
(move lexenv saved-function)
(loadw saved-function lexenv closure-fun-slot fun-pointer-lowtag)
(lisp-jump saved-function))))

180
src/compiler/arm64/parms.lisp Normal file
View file

@ -0,0 +1,180 @@
;;;; This file contains some parameterizations of various VM
;;;; attributes for the ARM. This file is separate from other stuff so
;;;; that it can be compiled and loaded earlier.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;; number of bits per word where a word holds one lisp descriptor
(def!constant n-word-bits 32)
;;; the natural width of a machine word (as seen in e.g. register width,
;;; address space)
(def!constant n-machine-word-bits 32)
;;; number of bits per byte where a byte is the smallest addressable
;;; object
(def!constant n-byte-bits 8)
;;; Floating-point related constants, both format descriptions and FPU
;;; control register descriptions. These don't exactly match up with
;;; what the machine manuals say because the Common Lisp standard
;;; defines floating-point values somewhat differently than the IEEE
;;; standard does.
(def!constant float-sign-shift 31)
(def!constant single-float-bias 126)
(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp)
(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp)
(def!constant single-float-normal-exponent-min 1)
(def!constant single-float-normal-exponent-max 254)
(def!constant single-float-hidden-bit (ash 1 23))
(def!constant single-float-trapping-nan-bit (ash 1 22))
(def!constant double-float-bias 1022)
(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equalp)
(defconstant-eqx double-float-significand-byte (byte 20 0) #'equalp)
(def!constant double-float-normal-exponent-min 1)
(def!constant double-float-normal-exponent-max #x7FE)
(def!constant double-float-hidden-bit (ash 1 20))
(def!constant double-float-trapping-nan-bit (ash 1 19))
(def!constant single-float-digits
(+ (byte-size single-float-significand-byte) 1))
(def!constant double-float-digits
(+ (byte-size double-float-significand-byte) n-word-bits 1))
#!+arm-vfp
(progn
(def!constant float-invalid-trap-bit (ash 1 0))
(def!constant float-divide-by-zero-trap-bit (ash 1 1))
(def!constant float-overflow-trap-bit (ash 1 2))
(def!constant float-underflow-trap-bit (ash 1 3))
(def!constant float-inexact-trap-bit (ash 1 4))
(def!constant float-input-denormal-trap-bit (ash 1 7))
(def!constant float-round-to-nearest 0)
(def!constant float-round-to-positive 1)
(def!constant float-round-to-negative 2)
(def!constant float-round-to-zero 3)
(defconstant-eqx float-rounding-mode (byte 2 22) #'equalp)
(defconstant-eqx float-sticky-bits (byte 8 0) #'equalp)
(defconstant-eqx float-traps-byte (byte 8 8) #'equalp)
(defconstant-eqx float-exceptions-byte (byte 8 0) #'equalp)
(def!constant float-fast-bit (ash 1 24))) ;; Flush-to-zero mode
;; NOTE: As with the FLOAT-REGISTERS SB in vm.lisp, if you define this
;; for non-VFP systems, please use a specific positive feature
;; conditional.
#!-arm-vfp
(error "Don't know how to set the FPU control word layout on non-VFP systems")
;;;; Where to put the different spaces.
;;; On non-gencgc we need large dynamic and static spaces for PURIFY
#!-gencgc
(progn
(def!constant read-only-space-start #x04000000)
(def!constant read-only-space-end #x07ff8000)
(def!constant static-space-start #x08000000)
(def!constant static-space-end #x097fff00)
(def!constant linkage-table-space-start #x0a000000)
(def!constant linkage-table-space-end #x0b000000))
#!+gencgc
(progn
(def!constant linkage-table-space-start #x0a000000)
(def!constant linkage-table-space-end #x0b000000)
(def!constant read-only-space-start #x04000000)
(def!constant read-only-space-end #x07ff8000)
(def!constant static-space-start #x08000000)
(def!constant static-space-end #x097fff00)
(def!constant dynamic-space-start #x4f000000)
(def!constant dynamic-space-end (!configure-dynamic-space-end)))
(def!constant linkage-table-entry-size 16)
#!+linux
(progn
#!-gencgc
(progn
(def!constant dynamic-0-space-start #x4f000000)
(def!constant dynamic-0-space-end #x66fff000)
(def!constant dynamic-1-space-start #x67000000)
(def!constant dynamic-1-space-end #x7efff000)))
;;;; other miscellaneous constants
(defenum (:start 8)
halt-trap
pending-interrupt-trap
error-trap
cerror-trap
breakpoint-trap
fun-end-breakpoint-trap
single-step-around-trap
single-step-before-trap)
;;;; Static symbols.
;;; These symbols are loaded into static space directly after NIL so
;;; that the system can compute their address by adding a constant
;;; amount to NIL.
;;;
;;; The fdefn objects for the static functions are loaded into static
;;; space directly after the static symbols. That way, the raw-addr
;;; can be loaded directly out of them by indirecting relative to NIL.
;;;
(defparameter *static-symbols*
(append
*common-static-symbols*
*c-callable-static-symbols*
'(*allocation-pointer*
*control-stack-pointer*
*binding-stack-pointer*
*interrupted-control-stack-pointer*
;; interrupt handling
*pseudo-atomic-atomic*
*pseudo-atomic-interrupted*
;; Needed for callbacks to work across saving cores. see
;; ALIEN-CALLBACK-ASSEMBLER-WRAPPER in c-call.lisp for gory
;; details.
sb!alien::*enter-alien-callback*
#!+gencgc *restart-lisp-function*)))
(defparameter *static-funs*
'(two-arg-gcd two-arg-lcm
two-arg-+ two-arg-- two-arg-* two-arg-/
two-arg-< two-arg-> two-arg-=
two-arg-and two-arg-ior two-arg-xor two-arg-eqv
eql
sb!kernel:%negate))
;;;; Assembler parameters:
;;; The number of bits per element in the assemblers code vector.
;;;
(defparameter *assembly-unit-length* 8)
(defvar *allocation-pointer*)

69
src/compiler/arm64/pred.lisp Normal file
View file

@ -0,0 +1,69 @@
;;;; predicate VOPs for the ARM VM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; The Branch VOP.
;;; The unconditional branch, emitted when we can't drop through to the desired
;;; destination. Dest is the continuation we transfer control to.
;;;
(define-vop (branch)
(:info dest)
(:generator 5
(inst b dest)))
;;;; Generic conditional VOPs
;;; The generic conditional branch, emitted immediately after test
;;; VOPs that only set flags.
;;; FIXME: Unlike the PPC (from whence this was cribbed), ARM actually
;;; has flags. We should take advantage of them here.
(define-vop (branch-if)
(:info dest flags not-p)
(:generator 0
(flet ((negate-condition (name)
(let ((code (logxor 1 (conditional-opcode name))))
(aref *condition-name-vec* code))))
(aver (null (rest flags)))
(inst b
(if not-p
(negate-condition (first flags))
(first flags))
dest))))
(defun convert-conditional-move-p (node dst-tn x-tn y-tn)
(declare (ignore node dst-tn x-tn y-tn))
nil)
;;;; Conditional VOPs:
(define-vop (if-eq)
(:args (x :scs (any-reg descriptor-reg null))
(y :scs (any-reg descriptor-reg null)))
(:conditional)
(:info target not-p)
(:policy :fast-safe)
(:translate eq)
(:generator 3
(inst cmp
(sc-case x
(null null-tn) ;; FIXME: should it really be like that?
(t x))
(sc-case y
(null null-tn)
(t y)))
(inst b (if not-p :ne :eq) target)))

29
src/compiler/arm64/sanctify.lisp Normal file
View file

@ -0,0 +1,29 @@
;;;; Do whatever is necessary to make the given code component
;;;; executable.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
(in-package "SB!VM")
;;; Do whatever is necessary to make the given code component
;;; executable. This isn't always strictly necessary (some ARM
;;; systems have coherent caches, for example), but it covers the
;;; general case.
(defun sanctify-for-execution (component)
(without-gcing
(alien-funcall (extern-alien "os_flush_icache"
(function void
system-area-pointer
unsigned-long))
(code-instructions component)
(%code-code-size component)))
nil)

285
src/compiler/arm64/sap.lisp Normal file
View file

@ -0,0 +1,285 @@
;;;; the ARM VM definition of SAP operations
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; Moves and coercions:
;;; Move a tagged SAP to an untagged representation.
(define-vop (move-to-sap)
(:args (x :scs (any-reg descriptor-reg)))
(:results (y :scs (sap-reg)))
(:note "pointer to SAP coercion")
(:generator 1
(loadw y x sap-pointer-slot other-pointer-lowtag)))
(define-move-vop move-to-sap :move
(descriptor-reg) (sap-reg))
;;; Move an untagged SAP to a tagged representation.
(define-vop (move-from-sap)
(:args (sap :scs (sap-reg) :to :save))
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
(:results (res :scs (descriptor-reg)))
(:note "SAP to pointer coercion")
(:generator 20
(with-fixed-allocation (res pa-flag sap-widetag sap-size)
(storew sap res sap-pointer-slot other-pointer-lowtag))))
(define-move-vop move-from-sap :move
(sap-reg) (descriptor-reg))
;;; Move untagged sap values.
(define-vop (sap-move)
(:args (x :target y
:scs (sap-reg)
:load-if (not (location= x y))))
(:results (y :scs (sap-reg)
:load-if (not (location= x y))))
(:note "SAP move")
(:effects)
(:affected)
(:generator 0
(move y x)))
(define-move-vop sap-move :move
(sap-reg) (sap-reg))
;;; Move untagged sap arguments/return-values.
(define-vop (move-sap-arg)
(:args (x :target y
:scs (sap-reg))
(fp :scs (any-reg)
:load-if (not (sc-is y sap-reg))))
(:results (y))
(:note "SAP argument move")
(:generator 0
(sc-case y
(sap-reg
(move y x))
(sap-stack
(store-stack-offset x fp y)))))
(define-move-vop move-sap-arg :move-arg
(descriptor-reg sap-reg) (sap-reg))
;;; Use standard MOVE-ARG + coercion to move an untagged sap to a
;;; descriptor passing location.
(define-move-vop move-arg :move-arg
(sap-reg) (descriptor-reg))
;;;; SAP-INT and INT-SAP
(define-vop (sap-int)
(:args (sap :scs (sap-reg) :target int))
(:arg-types system-area-pointer)
(:results (int :scs (unsigned-reg)))
(:result-types unsigned-num)
(:translate sap-int)
(:policy :fast-safe)
(:generator 1
(move int sap)))
(define-vop (int-sap)
(:args (int :scs (unsigned-reg) :target sap))
(:arg-types unsigned-num)
(:results (sap :scs (sap-reg)))
(:result-types system-area-pointer)
(:translate int-sap)
(:policy :fast-safe)
(:generator 1
(move sap int)))
;;;; POINTER+ and POINTER-
(define-vop (pointer+)
(:translate sap+)
(:args (ptr :scs (sap-reg))
(offset :scs (signed-reg)))
(:arg-types system-area-pointer signed-num)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:policy :fast-safe)
(:generator 2
(inst add res ptr offset)))
(define-vop (pointer+-unsigned-c)
(:translate sap+)
(:args (ptr :scs (sap-reg)))
(:info offset)
(:arg-types system-area-pointer (:constant (unsigned-byte 8)))
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:policy :fast-safe)
(:generator 1
(inst add res ptr offset)))
(define-vop (pointer+-signed-c)
(:translate sap+)
(:args (ptr :scs (sap-reg)))
(:info offset)
(:arg-types system-area-pointer (:constant (integer -255 -1)))
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:policy :fast-safe)
(:generator 1
(inst sub res ptr (- offset))))
(define-vop (pointer-)
(:translate sap-)
(:args (ptr1 :scs (sap-reg))
(ptr2 :scs (sap-reg)))
(:arg-types system-area-pointer system-area-pointer)
(:policy :fast-safe)
(:results (res :scs (signed-reg)))
(:result-types signed-num)
(:generator 1
(inst sub res ptr1 ptr2)))
;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
(macrolet ((def-system-ref-and-set
;; NOTE: The -C VOPs have been disabled, as the allowed
;; displacements for memory references vary by
;; instruction, are confusing to figure out, and might
;; be sign-magnitude encoded. FIXME: Figure these
;; things out, and re-enable the VOPs.
(ref-name set-name sc type size &key signed use-lip)
(let ((ref-name-c (symbolicate ref-name "-C"))
(set-name-c (symbolicate set-name "-C")))
`(progn
(define-vop (,ref-name)
(:translate ,ref-name)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
(offset :scs (signed-reg)))
(:arg-types system-area-pointer signed-num)
(:results (result :scs (,sc)))
(:result-types ,type)
,@(when use-lip
'((:temporary (:sc interior-reg) lip)))
(:generator 5
,@(when use-lip
'((inst add lip sap offset)))
(inst ,(ecase size
(:byte (if signed 'ldrsb 'ldrb))
(:short (if signed 'ldrsh 'ldrh))
(:long 'ldr)
(:single 'flds)
(:double 'fldd))
result ,(if use-lip
'(@ lip)
'(@ sap offset)))))
#+(or)
(define-vop (,ref-name-c)
(:translate ,ref-name)
(:policy :fast-safe)
(:args (sap :scs (sap-reg)))
(:arg-types system-area-pointer (:constant (signed-byte 16)))
(:info offset)
(:results (result :scs (,sc)))
(:result-types ,type)
(:generator 4
(inst ,(ecase size
(:byte (if signed 'ldrsb 'ldrb))
(:short (if signed 'ldrsh 'ldrh))
(:long 'ldr)
(:single 'flds)
(:double 'fldd))
result (@ sap offset))))
(define-vop (,set-name)
(:translate ,set-name)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
(offset :scs (signed-reg))
(value :scs (,sc) :target result))
(:arg-types system-area-pointer signed-num ,type)
(:results (result :scs (,sc)))
(:result-types ,type)
,@(when use-lip
'((:temporary (:sc interior-reg) lip)))
(:generator 5
,@(when use-lip
'((inst add lip sap offset)))
(inst ,(ecase size
(:byte 'strb)
(:short 'strh)
(:long 'str)
(:single 'fsts)
(:double 'fstd))
value ,(if use-lip
'(@ lip)
'(@ sap offset)))
(unless (location= result value)
,@(case size
(:single
'((inst fcpys result value)))
(:double
'((inst fcpyd result value)))
(t
'((inst mov result value)))))))
#+(or)
(define-vop (,set-name-c)
(:translate ,set-name)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
(value :scs (,sc) :target result))
(:arg-types system-area-pointer (:constant (signed-byte 16)) ,type)
(:info offset)
(:results (result :scs (,sc)))
(:result-types ,type)
(:generator 4
(inst ,(ecase size
(:byte 'strb)
(:short 'strh)
(:long 'str)
(:single 'fsts)
(:double 'fstd))
value (@ sap offset))
(unless (location= result value)
,@(case size
(:single
'((inst fcpys result value)))
(:double
'((inst fcpyd result value)))
(t
'((inst mov result value)))))))))))
(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
unsigned-reg positive-fixnum :byte :signed nil)
(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
signed-reg tagged-num :byte :signed t)
(def-system-ref-and-set sap-ref-16 %set-sap-ref-16
unsigned-reg positive-fixnum :short :signed nil)
(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
signed-reg tagged-num :short :signed t)
(def-system-ref-and-set sap-ref-32 %set-sap-ref-32
unsigned-reg unsigned-num :long :signed nil)
(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
signed-reg signed-num :long :signed t)
(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
sap-reg system-area-pointer :long)
(def-system-ref-and-set sap-ref-lispobj %set-sap-ref-lispobj
descriptor-reg * :long)
(def-system-ref-and-set sap-ref-single %set-sap-ref-single
single-reg single-float :single :use-lip t)
(def-system-ref-and-set sap-ref-double %set-sap-ref-double
double-reg double-float :double :use-lip t))
;;; Noise to convert normal lisp data objects into SAPs.
(define-vop (vector-sap)
(:translate vector-sap)
(:policy :fast-safe)
(:args (vector :scs (descriptor-reg)))
(:results (sap :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2
(inst add sap vector
(- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))

44
src/compiler/arm64/show.lisp Normal file
View file

@ -0,0 +1,44 @@
;;;; VOPs which are useful for following the progress of the system
;;;; early in boot
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(define-vop (print)
(:args (object :scs (descriptor-reg any-reg) :target ocfp))
(:results (result :scs (descriptor-reg)))
(:save-p t)
(:temporary (:sc any-reg :offset ocfp-offset :from (:argument 0)) ocfp)
(:temporary (:sc any-reg :offset r8-offset) cfunc)
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:sc non-descriptor-reg :offset nargs-offset) nargs)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:temporary (:sc interior-reg) lip)
(:vop-var vop)
(:generator 100
(let ((call-into-c-fixup (gen-label))
(debug-print-fixup (gen-label))
(cur-nfp (current-nfp-tn vop)))
(assemble (*elsewhere*)
(emit-label call-into-c-fixup)
(inst word (make-fixup "call_into_c" :foreign))
(emit-label debug-print-fixup)
(inst word (make-fixup "debug_print" :foreign)))
(when cur-nfp
(store-stack-tn nfp-save cur-nfp))
(move ocfp object)
(inst load-from-label temp lip call-into-c-fixup)
(inst load-from-label cfunc lip debug-print-fixup)
(inst blx temp)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save))
(move result nargs))))

144
src/compiler/arm64/static-fn.lisp Normal file
View file

@ -0,0 +1,144 @@
;;;; VOPs and macro magic for calling static functions
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(define-vop (static-fun-template)
(:save-p t)
(:policy :safe)
(:variant-vars symbol)
(:vop-var vop)
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:scs (descriptor-reg)) move-temp)
(:temporary (:scs (descriptor-reg)) function)
(:temporary (:sc any-reg :offset nargs-offset) nargs)
(:temporary (:sc interior-reg) lip)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun static-fun-template-name (num-args num-results)
(intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
num-args num-results)))
(defun moves (dst src)
(collect ((moves))
(do ((dst dst (cdr dst))
(src src (cdr src)))
((or (null dst) (null src)))
(moves `(move ,(car dst) ,(car src))))
(moves)))
(defun static-fun-template-vop (num-args num-results)
(unless (and (<= num-args register-arg-count)
(<= num-results register-arg-count))
(error "either too many args (~W) or too many results (~W); max = ~W"
num-args num-results register-arg-count))
(let ((num-temps (max num-args num-results)))
(collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
(dotimes (i num-results)
(let ((result-name (intern (format nil "RESULT-~D" i))))
(result-names result-name)
(results `(,result-name :scs (any-reg descriptor-reg)))))
(dotimes (i num-temps)
(let ((temp-name (intern (format nil "TEMP-~D" i))))
(temp-names temp-name)
(temps `(:temporary (:sc descriptor-reg
:offset ,(nth i *register-arg-offsets*)
,@(when (< i num-args)
`(:from (:argument ,i)))
,@(when (< i num-results)
`(:to (:result ,i)
:target ,(nth i (result-names)))))
,temp-name))))
(dotimes (i num-args)
(let ((arg-name (intern (format nil "ARG-~D" i))))
(arg-names arg-name)
(args `(,arg-name
:scs (any-reg descriptor-reg)
:target ,(nth i (temp-names))))))
`(define-vop (,(static-fun-template-name num-args num-results)
static-fun-template)
(:args ,@(args))
,@(temps)
(:temporary (:sc any-reg) csp-temp)
(:results ,@(results))
(:generator ,(+ 50 num-args num-results)
(let ((lra-label (gen-label))
(cur-nfp (current-nfp-tn vop)))
,@(moves (temp-names) (arg-names))
(inst ldr function (@ null-tn (static-fun-offset symbol)))
(inst mov nargs (fixnumize ,num-args))
(when cur-nfp
(store-stack-tn nfp-save cur-nfp))
;; This is a somewhat ideosyncratic way to build a new
;; stack frame, pushing a value and updating CSP, finding
;; the new CFP, then pushing another value on CSP, but it
;; works for this situation.
(inst compute-lra lip lip lra-label)
(load-csp csp-temp)
(inst add csp-temp csp-temp 8)
(store-csp csp-temp)
(inst str cfp-tn (@ csp-temp -8))
(inst str lip (@ csp-temp -4))
(inst sub cfp-tn csp-temp 8)
(note-this-location vop :call-site)
(lisp-jump function)
(emit-return-pc lra-label)
,(collect ((bindings) (links))
(do ((temp (temp-names) (cdr temp))
(name 'values (gensym))
(prev nil name)
(i 0 (1+ i)))
((= i num-results))
(bindings `(,name
(make-tn-ref ,(car temp) nil)))
(when prev
(links `(setf (tn-ref-across ,prev) ,name))))
`(let ,(bindings)
,@(links)
(default-unknown-values vop
,(if (zerop num-results) nil 'values)
,num-results move-temp temp lip lra-label)))
(when cur-nfp
(load-stack-tn cur-nfp nfp-save))
,@(moves (result-names) (temp-names))))))))
) ; EVAL-WHEN
(macrolet ((frob (num-args num-res)
(static-fun-template-vop (eval num-args) (eval num-res))))
;; Other backends cover options from zero through
;; register-arg-count. It turns out, however, that only the 1 and 2
;; arg cases are actually used.
(frob 1 1)
(frob 2 1))
(defmacro define-static-fun (name args &key (results '(x)) translate
policy cost arg-types result-types)
`(define-vop (,name
,(static-fun-template-name (length args)
(length results)))
(:variant ',name)
(:note ,(format nil "static-fun ~@(~S~)" name))
,@(when translate
`((:translate ,translate)))
,@(when policy
`((:policy ,policy)))
,@(when cost
`((:generator-cost ,cost)))
,@(when arg-types
`((:arg-types ,@arg-types)))
,@(when result-types
`((:result-types ,@result-types)))))

50
src/compiler/arm64/subprim.lisp Normal file
View file

@ -0,0 +1,50 @@
;;;; linkage information for standard static functions, and
;;;; miscellaneous VOPs
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(define-vop (length/list)
(:translate length)
(:args (object :scs (descriptor-reg) :target ptr))
(:arg-types list)
(:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
count)
(:results (result :scs (any-reg descriptor-reg)))
(:policy :fast-safe)
(:vop-var vop)
(:save-p :compute-only)
(:generator 50
(let ((done (gen-label))
(loop (gen-label))
(not-list (gen-label)))
(move ptr object)
(inst eor count count count)
(emit-label loop)
(inst cmp ptr null-tn)
(inst b :eq done)
(test-type ptr not-list t (list-pointer-lowtag) :temp temp)
(loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
(inst add count count (fixnumize 1))
(test-type ptr loop nil (list-pointer-lowtag) :temp temp)
(emit-label not-list)
(error-call vop 'object-not-list-error ptr)
(emit-label done)
(move result count))))

259
src/compiler/arm64/system.lisp Normal file
View file

@ -0,0 +1,259 @@
;;;; ARM VM definitions of various system hacking operations
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; Type frobbing VOPs
(define-vop (lowtag-of)
(:translate lowtag-of)
(:policy :fast-safe)
(:args (object :scs (any-reg descriptor-reg)))
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 1
(inst and result object lowtag-mask)))
(define-vop (widetag-of)
(:translate widetag-of)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 1)))
(:results (result :scs (unsigned-reg) :from (:eval 0)))
(:result-types positive-fixnum)
(:generator 6
;; First, pick off the immediate types, starting with FIXNUM.
(inst ands result object fixnum-tag-mask)
;; If it wasn't a fixnum, start with the full widetag.
(inst and :ne result object widetag-mask)
;; Now, we have our result for an immediate type, but we might
;; have a pointer object instead, in which case we need to do more
;; work. Check for a pointer type.
;; KLUDGE: We're a 32-bit port, so all pointer lowtags have the
;; low bit set, but there's no obvious named constant for this.
;; On 64-bit ports, all pointer lowtags have the low two bits set,
;; so this wouldn't work as easily.
(inst tst object 1)
;; If we have a pointer type, we need to compute a different
;; answer. For lists and instances, we just need the lowtag. For
;; functions and "other", we need to load the widetag from the
;; object header. In both cases, having just the widetag
;; available is handy.
(inst and :ne result object lowtag-mask)
;; We now have the correct answer for list-pointer-lowtag and
;; instance-pointer-lowtag, but need to pick off the case for the
;; other two pointer types. KLUDGE: FUN-POINTER-LOWTAG and
;; OTHER-POINTER-LOWTAG are both in the upper half of the lowtag
;; space, while LIST-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG
;; are in the lower half, so we distinguish with a bit test.
(inst tst :ne object 4)
;; We can't use both register and immediate offsets in the same
;; load/store instruction, so we need to bias our register offset
;; on big-endian systems.
(when (eq *backend-byte-order* :big-endian)
(inst sub :ne result (1- n-word-bytes)))
;; And, finally, pick out the widetag from the header.
(inst ldrb :ne result (@ object (- result)))))
(define-vop (fun-subtype)
(:translate fun-subtype)
(:policy :fast-safe)
(:args (function :scs (descriptor-reg)))
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
(load-type result function (- fun-pointer-lowtag))))
(define-vop (set-fun-subtype)
(:translate (setf fun-subtype))
(:policy :fast-safe)
(:args (type :scs (unsigned-reg) :target result)
(function :scs (descriptor-reg)))
(:arg-types positive-fixnum *)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
(inst strb type (@ function (- (ecase *backend-byte-order*
(:little-endian 0)
(:big-endian (1- n-word-bytes)))
fun-pointer-lowtag)))
(move result type)))
(define-vop (get-header-data)
(:translate get-header-data)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
(loadw res x 0 other-pointer-lowtag)
(inst mov res (lsr res n-widetag-bits))))
(define-vop (get-closure-length)
(:translate get-closure-length)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
(loadw res x 0 fun-pointer-lowtag)
(inst mov res (lsr res n-widetag-bits))))
(define-vop (set-header-data)
(:translate set-header-data)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg) :target res)
(data :scs (any-reg immediate)))
(:arg-types * positive-fixnum)
(:results (res :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) t1)
(:generator 6
(load-type t1 x (- other-pointer-lowtag))
(sc-case data
(any-reg
(inst orr t1 t1 (lsl data (- n-widetag-bits n-fixnum-tag-bits))))
(immediate
;; FIXME: This will break if DATA has bits spread over more
;; than an eight bit range aligned on an even bit position.
;; See SYS:SRC;COMPILER;ARM;MOVE.LISP for a partial fix... And
;; maybe it should be promoted to an instruction-macro?
(inst orr t1 t1 (ash (tn-value data) n-widetag-bits))))
(storew t1 x 0 other-pointer-lowtag)
(move res x)))
(define-vop (pointer-hash)
(:translate pointer-hash)
(:args (ptr :scs (any-reg descriptor-reg)))
(:results (res :scs (any-reg descriptor-reg)))
(:policy :fast-safe)
(:generator 1
(inst bic res ptr lowtag-mask)
(inst mov res (lsr res 1))))
;;;; Allocation
(define-vop (dynamic-space-free-pointer)
(:results (int :scs (sap-reg)))
(:result-types system-area-pointer)
(:translate dynamic-space-free-pointer)
(:policy :fast-safe)
(:generator 1
(load-symbol-value int *allocation-pointer*)))
(define-vop (binding-stack-pointer-sap)
(:results (int :scs (sap-reg)))
(:result-types system-area-pointer)
(:translate binding-stack-pointer-sap)
(:policy :fast-safe)
(:generator 1
(load-symbol-value int *binding-stack-pointer*)))
(define-vop (control-stack-pointer-sap)
(:results (int :scs (sap-reg)))
(:result-types system-area-pointer)
(:translate control-stack-pointer-sap)
(:policy :fast-safe)
(:generator 1
(load-csp int)))
;;;; Code object frobbing.
(define-vop (code-instructions)
(:translate code-instructions)
(:policy :fast-safe)
(:args (code :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:results (sap :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 10
(loadw ndescr code 0 other-pointer-lowtag)
;; CODE-HEADER-WIDETAG is #x38, which has the top two bits clear,
;; so we don't to clear the low bits here. If we do, use BIC.
(inst mov ndescr (lsr ndescr (- n-widetag-bits word-shift)))
(inst sub ndescr ndescr other-pointer-lowtag)
(inst add sap code ndescr)))
(define-vop (compute-fun)
(:args (code :scs (descriptor-reg))
(offset :scs (signed-reg unsigned-reg)))
(:arg-types * positive-fixnum)
(:results (func :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:generator 10
(loadw ndescr code 0 other-pointer-lowtag)
;; CODE-HEADER-WIDETAG is #x38, which has the top two bits clear,
;; so we don't to clear the low bits here. If we do, use BIC.
(inst add ndescr offset (lsr ndescr (- n-widetag-bits word-shift)))
(inst sub ndescr ndescr (- other-pointer-lowtag fun-pointer-lowtag))
(inst add func code ndescr)))
;;;
#!+symbol-info-vops
(define-vop (symbol-info-vector)
(:policy :fast-safe)
(:translate symbol-info-vector)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) temp)
(:generator 1
(loadw res x symbol-info-slot other-pointer-lowtag)
;; If RES has list-pointer-lowtag, take its CDR. If not, use it as-is.
(inst and temp res lowtag-mask)
(inst cmp temp list-pointer-lowtag)
(loadw res res cons-cdr-slot list-pointer-lowtag :eq)))
#!+symbol-info-vops
(define-vop (symbol-plist)
(:policy :fast-safe)
(:translate symbol-plist)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:generator 1
(loadw res x symbol-info-slot other-pointer-lowtag)
;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x)
;; so if the info slot holds a vector, this gets a fixnum- it's not a plist.
(loadw res res cons-car-slot list-pointer-lowtag)
(inst tst res fixnum-tag-mask)
(inst mov :eq res null-tn)))
;;;; other miscellaneous VOPs
(defknown sb!unix::receive-pending-interrupt () (values))
(define-vop (sb!unix::receive-pending-interrupt)
(:policy :fast-safe)
(:translate sb!unix::receive-pending-interrupt)
(:generator 1
(inst debug-trap)
(inst byte pending-interrupt-trap)
(emit-alignment word-shift)))
(define-vop (halt)
(:temporary (:sc non-descriptor-reg :offset ocfp-offset) error-temp)
(:generator 1
;; See macros.lisp, EMIT-ERROR-BREAK, for an explanation.
(inst mov error-temp #x000f0000)
(inst add error-temp error-temp 1)
(inst swi 0)
(inst byte halt-trap)
;; Re-align to the next instruction boundary.
(emit-alignment word-shift)))
;;;; Dummy definition for a spin-loop hint VOP
(define-vop (spin-loop-hint)
(:translate spin-loop-hint)
(:policy :fast-safe)
(:generator 0))

3
src/compiler/arm64/target-insts.lisp Normal file
View file

@ -0,0 +1,3 @@
(in-package "SB!VM")
;;; Let's see if an empty file works here. It does on the Alpha.

422
src/compiler/arm64/type-vops.lisp Normal file
View file

@ -0,0 +1,422 @@
;;;; type testing and checking VOPs for the ARM VM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(defun %test-fixnum (value target not-p &key temp)
(declare (ignore temp))
(assemble ()
(inst tst value fixnum-tag-mask)
(inst b (if not-p :ne :eq) target)))
(defun %test-fixnum-and-headers (value target not-p headers &key temp)
(let ((drop-through (gen-label)))
(assemble ()
(inst ands temp value fixnum-tag-mask)
(inst b :eq (if not-p drop-through target)))
(%test-headers value target not-p nil headers
:drop-through drop-through :temp temp)))
(defun %test-immediate (value target not-p immediate &key temp)
(assemble ()
(inst and temp value widetag-mask)
(inst cmp temp immediate)
(inst b (if not-p :ne :eq) target)))
(defun %test-lowtag (value target not-p lowtag &key temp)
(assemble ()
(inst and temp value lowtag-mask)
(inst cmp temp lowtag)
(inst b (if not-p :ne :eq) target)))
(defun %test-headers (value target not-p function-p headers
&key temp (drop-through (gen-label)))
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind (when-true when-false)
(if not-p
(values drop-through target)
(values target drop-through))
(assemble ()
(%test-lowtag value when-false t lowtag :temp temp)
(load-type temp value (- lowtag))
(do ((remaining headers (cdr remaining)))
((null remaining))
(let ((header (car remaining))
(last (null (cdr remaining))))
(cond
((atom header)
(cond
((and (not last) (null (cddr remaining))
(atom (cadr remaining))
(= (logcount (logxor header (cadr remaining))) 1))
(inst and temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
(inst cmp temp (ldb (byte 8 0) (logand header (cadr remaining))))
(inst b (if not-p :ne :eq) target)
(return))
(t
(inst cmp temp header)
(if last
(inst b (if not-p :ne :eq) target)
(inst b :eq when-true)))))
(t
(let ((start (car header))
(end (cdr header)))
(cond
((and last (not (= start bignum-widetag))
(= (+ start 4) end)
(= (logcount (logxor start end)) 1))
(inst and temp temp (ldb (byte 8 0) (logeqv start end)))
(inst cmp temp (ldb (byte 8 0) (logand start end)))
(inst b (if not-p :ne :eq) target))
((and (not last) (null (cddr remaining))
(= (+ start 4) end) (= (logcount (logxor start end)) 1)
(listp (cadr remaining))
(= (+ (caadr remaining) 4) (cdadr remaining))
(= (logcount (logxor (caadr remaining) (cdadr remaining))) 1)
(= (logcount (logxor (caadr remaining) start)) 1))
(inst and temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
(inst cmp temp (ldb (byte 8 0) (logand start (cdadr remaining))))
(inst b (if not-p :ne :eq) target)
(return))
(t
(unless (= start bignum-widetag)
(inst cmp temp start)
(if (= end complex-array-widetag)
(progn
(aver last)
(inst b (if not-p :lt :ge) target))
(inst b :lt when-false)))
(unless (= end complex-array-widetag)
(inst cmp temp end)
(if last
(inst b (if not-p :gt :le) target)
(inst b :le when-true))))))))))
(emit-label drop-through)))))
;;; Type checking and testing (see also the use of !DEFINE-TYPE-VOPS
;;; in src/compiler/generic/late-type-vops.lisp):
;;;
;;; [FIXME: Like some of the other comments in this file, this one
;;; really belongs somewhere else]
(define-vop (check-type)
(:args (value :target result :scs (any-reg descriptor-reg)))
(:results (result :scs (any-reg descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)
:to (:result 0)
:offset ocfp-offset)
temp)
(:vop-var vop)
(:save-p :compute-only))
(define-vop (type-predicate)
(:args (value :scs (any-reg descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:conditional)
(:info target not-p)
(:policy :fast-safe))
(defun cost-to-test-types (type-codes)
(+ (* 2 (length type-codes))
(if (> (apply #'max type-codes) lowtag-limit) 7 2)))
(defmacro !define-type-vops (pred-name check-name ptype error-code
(&rest type-codes)
&key &allow-other-keys)
(let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
`(progn
,@(when pred-name
`((define-vop (,pred-name type-predicate)
(:translate ,pred-name)
(:generator ,cost
(test-type value target not-p (,@type-codes)
:temp temp)))))
,@(when check-name
`((define-vop (,check-name check-type)
(:generator ,cost
(let ((err-lab
(generate-error-code vop ',error-code value)))
(test-type value err-lab t (,@type-codes)
:temp temp)
(move result value))))))
,@(when ptype
`((primitive-type-vop ,check-name (:check) ,ptype))))))
;;;; Other integer ranges.
;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
;;; exactly one digit.
(defun signed-byte-32-test (value temp not-p target not-target)
(multiple-value-bind
(yep nope)
(if not-p
(values not-target target)
(values target not-target))
(assemble ()
(inst ands temp value fixnum-tag-mask)
(inst b :eq yep)
(test-type value nope t (other-pointer-lowtag) :temp temp)
(loadw temp value 0 other-pointer-lowtag)
;; (+ (ash 1 n-widetag-bits) bignum-widetag) does not fit into a single immediate
(inst eor temp temp (ash 1 n-widetag-bits))
(inst eors temp temp bignum-widetag)
(inst b (if not-p :ne :eq) target)))
(values))
(define-vop (signed-byte-32-p type-predicate)
(:translate signed-byte-32-p)
(:generator 45
(let ((not-target (gen-label)))
(signed-byte-32-test value temp not-p target not-target)
(emit-label not-target))))
(define-vop (check-signed-byte-32 check-type)
(:generator 45
(let ((nope (generate-error-code vop 'object-not-signed-byte-32-error value))
(yep (gen-label)))
(signed-byte-32-test value temp t nope yep)
(emit-label yep)
(move result value))))
;;; An (UNSIGNED-BYTE 32) can be represented with either a positive
;;; fixnum, a bignum with exactly one positive digit, or a bignum with
;;; exactly two digits and the second digit all zeros.
(defun unsigned-byte-32-test (value temp not-p target not-target)
(let ((single-word (gen-label))
(fixnum (gen-label)))
(multiple-value-bind (yep nope)
(if not-p
(values not-target target)
(values target not-target))
(assemble ()
;; Is it a fixnum?
(move temp value)
(%test-fixnum temp fixnum nil)
;; If not, is it an other pointer?
(test-type value nope t (other-pointer-lowtag) :temp temp)
;; Get the header.
(loadw temp value 0 other-pointer-lowtag)
;; Is it one?
;; (+ (ash 1 n-widetag-bits) bignum-widetag) does not fit into a single immediate
(inst eor temp temp (ash 1 n-widetag-bits))
(inst eors temp temp bignum-widetag)
(inst b :eq single-word)
;; If it's other than two, we can't be an (unsigned-byte 32)
(inst eors temp temp (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
(+ (ash 2 n-widetag-bits) bignum-widetag)))
(inst b :ne nope)
;; Get the second digit.
(loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
;; All zeros, its an (unsigned-byte 32).
(inst cmp temp 0)
(inst b :eq yep)
(inst b nope)
(emit-label single-word)
;; Get the single digit.
(loadw temp value bignum-digits-offset other-pointer-lowtag)
;; positive implies (unsigned-byte 32).
(emit-label fixnum)
(inst cmp temp 0)
(if not-p
(inst b :lt target)
(inst b :ge target))))
(values)))
(define-vop (unsigned-byte-32-p type-predicate)
(:translate unsigned-byte-32-p)
(:generator 45
(let ((not-target (gen-label)))
(unsigned-byte-32-test value temp not-p target not-target)
(emit-label not-target))))
(define-vop (check-unsigned-byte-32 check-type)
(:generator 45
(let ((lose (generate-error-code vop 'object-not-unsigned-byte-32-error value))
(okay (gen-label)))
(unsigned-byte-32-test value temp t lose okay)
(emit-label okay)
(move result value))))
;;; MOD type checks
(defun power-of-two-limit-p (x)
(and (fixnump x)
(= (logcount (1+ x)) 1)
;; Immediate encodable
(> x (expt 2 23))))
(define-vop (test-fixnum-mod-power-of-two)
(:args (value :scs (any-reg descriptor-reg
unsigned-reg signed-reg
immediate)))
(:arg-types *
(:constant (satisfies power-of-two-limit-p)))
(:translate fixnum-mod-p)
(:conditional :eq)
(:info hi)
(:save-p :compute-only)
(:policy :fast-safe)
(:generator 2
(aver (not (sc-is value immediate)))
(let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
hi
(fixnumize hi))))
(inst tst value (lognot fixnum-hi)))))
(define-vop (test-fixnum-mod-tagged-unsigned-imm)
(:args (value :scs (any-reg descriptor-reg
unsigned-reg signed-reg
immediate)))
(:arg-types (:or tagged-num unsigned-num signed-num)
(:constant (satisfies encodable-immediate)))
(:translate fixnum-mod-p)
(:conditional :ls)
(:info hi)
(:save-p :compute-only)
(:policy :fast-safe)
(:generator 3
(aver (not (sc-is value immediate)))
(let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
hi
(fixnumize hi))))
(inst cmp value fixnum-hi))))
(defun encodable-immediate+1 (x)
(encodable-immediate (1+ x)))
;;; Adding 1 and changing the codntions from <= to < allows to encode
;;; more immediates.
(define-vop (test-fixnum-mod-tagged-unsigned-imm+1)
(:args (value :scs (any-reg descriptor-reg
unsigned-reg signed-reg
immediate)))
(:arg-types (:or tagged-num unsigned-num signed-num)
(:constant (satisfies encodable-immediate+1)))
(:translate fixnum-mod-p)
(:conditional :cc)
(:info hi)
(:save-p :compute-only)
(:policy :fast-safe)
(:generator 3
(aver (not (sc-is value immediate)))
(let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
(1+ hi)
(fixnumize (1+ hi)))))
(inst cmp value fixnum-hi))))
(define-vop (test-fixnum-mod-tagged-unsigned)
(:args (value :scs (any-reg descriptor-reg
unsigned-reg signed-reg
immediate)))
(:arg-types (:or tagged-num unsigned-num signed-num)
(:constant fixnum))
(:temporary (:scs (non-descriptor-reg)) temp)
(:translate fixnum-mod-p)
(:conditional :ls)
(:info hi)
(:save-p :compute-only)
(:policy :fast-safe)
(:generator 4
(aver (not (sc-is value immediate)))
(let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
hi
(fixnumize hi))))
(load-immediate-word temp fixnum-hi)
(inst cmp value temp))))
(defun encodable-immediate/+1 (x)
(or (encodable-immediate x)
(encodable-immediate (1+ x))))
(define-vop (test-fixnum-mod-*-imm)
(:args (value :scs (any-reg descriptor-reg)))
(:arg-types * (:constant (satisfies encodable-immediate/+1)))
(:translate fixnum-mod-p)
(:conditional)
(:info target not-p hi)
(:save-p :compute-only)
(:policy :fast-safe)
(:generator 5
(let* ((1+ (not (encodable-immediate hi)))
(fixnum-hi (fixnumize (if 1+
(1+ hi)
hi)))
(skip (gen-label)))
(inst tst value fixnum-tag-mask)
(inst b :ne (if not-p target skip))
(inst cmp value fixnum-hi)
(inst b (if not-p
(if 1+ :cs :hi)
(if 1+ :cc :ls))
target)
(emit-label SKIP))))
(define-vop (test-fixnum-mod-*)
(:args (value :scs (any-reg descriptor-reg)))
(:arg-types * (:constant fixnum))
(:translate fixnum-mod-p)
(:temporary (:scs (any-reg)) temp)
(:conditional)
(:info target not-p hi)
(:save-p :compute-only)
(:policy :fast-safe)
(:generator 6
(inst tst value fixnum-tag-mask)
(inst b :ne (if not-p target skip))
(let ((condition (if not-p :hi :ls)))
(load-immediate-word temp (fixnumize hi))
(inst cmp value temp)
(inst b condition target))
SKIP))
;;;; List/symbol types:
;;;
;;; symbolp (or symbol (eq nil))
;;; consp (and list (not (eq nil)))
(define-vop (symbolp type-predicate)
(:translate symbolp)
(:generator 12
(let* ((drop-thru (gen-label))
(is-symbol-label (if not-p drop-thru target)))
(inst cmp value null-tn)
(inst b :eq is-symbol-label)
(test-type value target not-p (symbol-header-widetag) :temp temp)
(emit-label drop-thru))))
(define-vop (check-symbol check-type)
(:generator 12
(let ((drop-thru (gen-label))
(error (generate-error-code vop 'object-not-symbol-error value)))
(inst cmp value null-tn)
(inst b :eq drop-thru)
(test-type value error t (symbol-header-widetag) :temp temp)
(emit-label drop-thru)
(move result value))))
(define-vop (consp type-predicate)
(:translate consp)
(:generator 8
(let* ((drop-thru (gen-label))
(is-not-cons-label (if not-p target drop-thru)))
(inst cmp value null-tn)
(inst b :eq is-not-cons-label)
(test-type value target not-p (list-pointer-lowtag) :temp temp)
(emit-label drop-thru))))
(define-vop (check-cons check-type)
(:generator 8
(let ((error (generate-error-code vop 'object-not-cons-error value)))
(inst cmp value null-tn)
(inst b :eq error)
(test-type value error t (list-pointer-lowtag) :temp temp)
(move result value))))

153
src/compiler/arm64/values.lisp Normal file
View file

@ -0,0 +1,153 @@
;;;; unknown-values VOPs for the ARM VM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(define-vop (reset-stack-pointer)
(:args (ptr :scs (any-reg)))
(:generator 1
(store-csp ptr)))
(define-vop (%%nip-values)
(:args (last-nipped-ptr :scs (any-reg) :target dest)
(last-preserved-ptr :scs (any-reg) :target src)
(moved-ptrs :scs (any-reg) :more t))
(:results (r-moved-ptrs :scs (any-reg) :more t))
(:temporary (:sc any-reg) src)
(:temporary (:sc any-reg) dest)
(:temporary (:sc non-descriptor-reg) temp)
(:temporary (:sc any-reg) stack-pointer)
(:ignore r-moved-ptrs)
(:generator 1
(move src last-preserved-ptr)
(move dest last-nipped-ptr)
(load-csp stack-pointer)
(inst cmp stack-pointer src)
(inst b :le DONE)
LOOP
(loadw temp src)
(inst add dest dest n-word-bytes)
(inst add src src n-word-bytes)
(storew temp dest -1)
(inst cmp stack-pointer src)
(inst b :gt LOOP)
DONE
(store-csp dest)
(inst sub src src dest)
(loop for moved = moved-ptrs then (tn-ref-across moved)
while moved
do (sc-case (tn-ref-tn moved)
((descriptor-reg any-reg)
(inst sub (tn-ref-tn moved) (tn-ref-tn moved) src))
((control-stack)
(load-stack-tn temp (tn-ref-tn moved))
(inst sub temp temp src)
(store-stack-tn (tn-ref-tn moved) temp))))))
;;; Push some values onto the stack, returning the start and number of values
;;; pushed as results. It is assumed that the Vals are wired to the standard
;;; argument locations. Nvals is the number of values to push.
;;;
;;; The generator cost is pseudo-random. We could get it right by defining a
;;; bogus SC that reflects the costs of the memory-to-memory moves for each
;;; operand, but this seems unworthwhile.
;;;
(define-vop (push-values)
(:args (vals :more t))
(:results (start :scs (any-reg) :from :load)
(count :scs (any-reg)))
(:info nvals)
(:temporary (:scs (descriptor-reg)) temp)
(:generator 20
(load-csp start)
(inst add temp start (* nvals n-word-bytes))
(store-csp temp)
(do ((val vals (tn-ref-across val))
(i 0 (1+ i)))
((null val))
(let ((tn (tn-ref-tn val)))
(sc-case tn
(descriptor-reg
(storew tn start i))
(control-stack
(load-stack-tn temp tn)
(storew temp start i)))))
(inst mov count (fixnumize nvals))))
;;; Push a list of values on the stack, returning Start and Count as used in
;;; unknown values continuations.
;;;
(define-vop (values-list)
(:args (arg :scs (descriptor-reg) :target list))
(:arg-types list)
(:policy :fast-safe)
(:results (start :scs (any-reg))
(count :scs (any-reg)))
(:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:sc any-reg) csp-temp)
(:vop-var vop)
(:save-p :compute-only)
(:generator 0
(move list arg)
(load-csp start)
(move csp-temp start)
LOOP
(inst cmp list null-tn)
(loadw temp list cons-car-slot list-pointer-lowtag)
(inst b :eq DONE)
(loadw list list cons-cdr-slot list-pointer-lowtag)
(inst add csp-temp csp-temp n-word-bytes)
(store-csp csp-temp)
(storew temp csp-temp -1)
(test-type list LOOP nil (list-pointer-lowtag) :temp ndescr)
(error-call vop 'bogus-arg-to-values-list-error list)
DONE
(inst sub count csp-temp start)))
;;; Copy the more arg block to the top of the stack so we can use them
;;; as function arguments.
;;;
(define-vop (%more-arg-values)
(:args (context :scs (descriptor-reg any-reg) :target src)
(skip :scs (any-reg immediate))
(num :scs (any-reg) :target count))
(:arg-types * positive-fixnum positive-fixnum)
(:temporary (:sc any-reg :from (:argument 0)) src)
(:temporary (:sc any-reg :from (:argument 2)) dst)
(:temporary (:sc descriptor-reg :from (:argument 1)) temp)
(:temporary (:sc any-reg) i)
(:results (start :scs (any-reg))
(count :scs (any-reg)))
(:generator 20
(sc-case skip
(immediate
(inst add src context (* (tn-value skip) n-word-bytes)))
(any-reg
(inst add src context skip)))
(inst adds count num 0)
(load-csp start)
(inst b :eq DONE)
(inst mov dst start)
(inst add i start count)
(store-csp i)
(inst mov i count)
LOOP
(inst cmp i 4)
(inst sub i i 4)
(inst ldr temp (@ src i))
(inst str temp (@ dst i))
(inst b :ne LOOP)
DONE))

327
src/compiler/arm64/vm.lisp Normal file
View file

@ -0,0 +1,327 @@
;;;; miscellaneous VM definition noise for the ARM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; register specs
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *register-names* (make-array 16 :initial-element nil)))
(macrolet ((defreg (name offset)
(let ((offset-sym (symbolicate name "-OFFSET")))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(def!constant ,offset-sym ,offset)
(setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
(defregset (name &rest regs)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter ,name
(list ,@(mapcar #'(lambda (name)
(symbolicate name "-OFFSET")) regs))))))
(defreg r0 0)
(defreg r1 1)
(defreg r2 2)
(defreg lexenv 3)
(defreg nl2 4)
(defreg code 5)
(defreg nl3 6)
(defreg ocfp 7)
(defreg r8 8)
(defreg nfp 9)
(defreg null 10)
(defreg cfp 11)
(defreg nargs 12)
(defreg nsp 13)
(defreg lr 14)
(defreg pc 15) ;; Yes, the program counter.
(defregset system-regs
null cfp nsp lr pc code)
(defregset descriptor-regs
r0 r1 r2 lexenv r8)
(defregset non-descriptor-regs
ocfp nfp nargs nl2 nl3)
;; registers used to pass arguments
;;
;; the number of arguments/return values passed in registers
(def!constant register-arg-count 3)
;; names and offsets for registers used to pass arguments
(defregset *register-arg-offsets* r0 r1 r2)
(defparameter *register-arg-names* '(r0 r1 r2)))
;;;; SB and SC definition:
(define-storage-base registers :finite :size 16)
(define-storage-base control-stack :unbounded :size 2 :size-increment 1)
(define-storage-base non-descriptor-stack :unbounded :size 0)
(define-storage-base constant :non-packed)
(define-storage-base immediate-constant :non-packed)
#!+arm-vfp
(define-storage-base float-registers :finite :size 32)
;; NOTE: If you fix the following, please to so with its own feature
;; conditional, and also adjust the definitions of the
;; {,COMPLEX-}{SINGLE,DOUBLE}-REG SCs below.
#!-arm-vfp
(error "Don't know how many float registers for non-VFP systems")
;;;
;;; Handy macro so we don't have to keep changing all the numbers whenever
;;; we insert a new storage class.
;;;
(defmacro define-storage-classes (&rest classes)
(do ((forms (list 'progn)
(let* ((class (car classes))
(sc-name (car class))
(constant-name (intern (concatenate 'simple-string
(string sc-name)
"-SC-NUMBER"))))
(list* `(define-storage-class ,sc-name ,index
,@(cdr class))
`(def!constant ,constant-name ,index)
forms)))
(index 0 (1+ index))
(classes classes (cdr classes)))
((null classes)
(nreverse forms))))
(define-storage-classes
;; Non-immediate contstants in the constant pool
(constant constant)
;; NULL is in a register.
(null immediate-constant)
;; Anything else that can be an immediate.
(immediate immediate-constant)
;; **** The stacks.
;; The control stack. (Scanned by GC)
(control-stack control-stack)
;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
;; is small and therefore the error trap information is smaller.
;; Moving them up here from their previous place down below saves
;; ~250K in core file size. --njf, 2006-01-27
;; Immediate descriptor objects. Don't have to be seen by GC, but nothing
;; bad will happen if they are. (fixnums, characters, header values, etc).
(any-reg
registers
:locations #.(append non-descriptor-regs descriptor-regs)
:constant-scs (immediate)
:save-p t
:alternate-scs (control-stack))
;; Pointer descriptor objects. Must be seen by GC.
(descriptor-reg registers
:locations #.descriptor-regs
:constant-scs (constant null immediate)
:save-p t
:alternate-scs (control-stack))
;; The non-descriptor stacks.
(signed-stack non-descriptor-stack) ; (signed-byte 32)
(unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
(character-stack non-descriptor-stack) ; non-descriptor characters.
(sap-stack non-descriptor-stack) ; System area pointers.
(single-stack non-descriptor-stack) ; single-floats
(double-stack non-descriptor-stack
:element-size 2 :alignment 2) ; double floats.
(complex-single-stack non-descriptor-stack :element-size 2)
(complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
;; **** Things that can go in the integer registers.
;; Non-Descriptor characters
(character-reg registers
:locations #.non-descriptor-regs
:constant-scs (immediate)
:save-p t
:alternate-scs (character-stack))
;; Non-Descriptor SAP's (arbitrary pointers into address space)
(sap-reg registers
:locations #.non-descriptor-regs
:constant-scs (immediate)
:save-p t
:alternate-scs (sap-stack))
;; Non-Descriptor (signed or unsigned) numbers.
(signed-reg registers
:locations #.non-descriptor-regs
:constant-scs (immediate)
:save-p t
:alternate-scs (signed-stack))
(unsigned-reg registers
:locations #.non-descriptor-regs
:constant-scs (immediate)
:save-p t
:alternate-scs (unsigned-stack))
;; Random objects that must not be seen by GC. Used only as temporaries.
(non-descriptor-reg registers
:locations #.non-descriptor-regs)
;; Pointers to the interior of objects. Used only as a temporary.
(interior-reg registers
:locations (#.lr-offset))
;; **** Things that can go in the floating point registers.
;; Non-Descriptor single-floats.
(single-reg float-registers
:locations #.(loop for i below 32 collect i)
:constant-scs ()
:save-p t
:alternate-scs (single-stack))
;; Non-Descriptor double-floats.
(double-reg float-registers
:locations #.(loop for i below 32 by 2 collect i)
:element-size 2
:constant-scs ()
:save-p t
:alternate-scs (double-stack))
(complex-single-reg float-registers
:locations #.(loop for i from 0 below 32 by 2 collect i)
:element-size 2
:constant-scs ()
:save-p t
:alternate-scs (complex-single-stack))
(complex-double-reg float-registers
:locations #.(loop for i from 0 below 32 by 4 collect i)
:element-size 4
:constant-scs ()
:save-p t
:alternate-scs (complex-double-stack))
;; A catch or unwind block.
(catch-block control-stack :element-size catch-block-size))
;;;; Make some random tns for important registers.
(macrolet ((defregtn (name sc)
(let ((offset-sym (symbolicate name "-OFFSET"))
(tn-sym (symbolicate name "-TN")))
`(defparameter ,tn-sym
(make-random-tn :kind :normal
:sc (sc-or-lose ',sc)
:offset ,offset-sym)))))
(defregtn null descriptor-reg)
(defregtn code descriptor-reg)
(defregtn nargs any-reg)
(defregtn ocfp any-reg)
(defregtn nsp any-reg)
(defregtn cfp any-reg)
(defregtn lr interior-reg)
(defregtn pc any-reg))
;;; If VALUE can be represented as an immediate constant, then return the
;;; appropriate SC number, otherwise return NIL.
(defun immediate-constant-sc (value)
(typecase value
(null
(sc-number-or-lose 'null))
((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
character)
(sc-number-or-lose 'immediate))
(symbol
(if (static-symbol-p value)
(sc-number-or-lose 'immediate)
nil))))
(defun boxed-immediate-sc-p (sc)
(or (eql sc (sc-number-or-lose 'null))
(eql sc (sc-number-or-lose 'immediate))))
;;;; function call parameters
;;; the SC numbers for register and stack arguments/return values
(def!constant register-arg-scn (sc-number-or-lose 'descriptor-reg))
(def!constant immediate-arg-scn (sc-number-or-lose 'any-reg))
(def!constant control-stack-arg-scn (sc-number-or-lose 'control-stack))
;;; offsets of special stack frame locations
(def!constant ocfp-save-offset 0)
(def!constant lra-save-offset 1)
(def!constant nfp-save-offset 2)
;;; This is used by the debugger.
;;; < nyef> Ah, right. So, SINGLE-VALUE-RETURN-BYTE-OFFSET doesn't apply to x86oids or ARM.
(def!constant single-value-return-byte-offset 0)
;;; A list of TN's describing the register arguments.
;;;
(defparameter *register-arg-tns*
(mapcar #'(lambda (n)
(make-random-tn :kind :normal
:sc (sc-or-lose 'descriptor-reg)
:offset n))
*register-arg-offsets*))
;;; This function is called by debug output routines that want a pretty name
;;; for a TN's location. It returns a thing that can be printed with PRINC.
(defun location-print-name (tn)
(declare (type tn tn))
(let ((sb (sb-name (sc-sb (tn-sc tn))))
(offset (tn-offset tn)))
(ecase sb
(registers (or (svref *register-names* offset)
(format nil "R~D" offset)))
(control-stack (format nil "CS~D" offset))
(non-descriptor-stack (format nil "NS~D" offset))
(constant (format nil "Const~D" offset))
(immediate-constant "Immed")
(float-registers (format nil "F~D" offset)))))
(defun combination-implementation-style (node)
(flet ((valid-funtype (args result)
(sb!c::valid-fun-use node
(sb!c::specifier-type
`(function ,args ,result)))))
(case (sb!c::combination-fun-source-name node)
(logtest
(cond
((valid-funtype '(fixnum fixnum) '*)
(values :maybe nil))
((valid-funtype '((signed-byte 32) (signed-byte 32)) '*)
(values :maybe nil))
((valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*)
(values :maybe nil))
(t (values :default nil))))
(logbitp
(cond
((or (valid-funtype '((constant-arg (integer 0 29)) fixnum) '*)
(valid-funtype '((constant-arg (integer 0 31)) (signed-byte 32)) '*)
(valid-funtype '((constant-arg (integer 0 31)) (unsigned-byte 32)) '*))
(values :transform '(lambda (index integer)
(%logbitp integer index))))
(t (values :default nil))))
(t (values :default nil)))))
(defun primitive-type-indirect-cell-type (ptype)
(declare (ignore ptype))
nil)

2
src/compiler/fndb.lisp
View file

@ -87,7 +87,7 @@
(movable foldable flushable commutative))
(defknown (equal equalp) (t t) boolean (foldable flushable recursive))
#!+(or x86 x86-64 arm)
#!+(or x86 x86-64 arm arm64)
(defknown fixnum-mod-p (t fixnum) boolean
(movable foldable flushable always-translatable))

2
src/compiler/generic/vm-tran.lisp
View file

@ -641,7 +641,7 @@
;; don't have a true Alpha64 port yet, we'll have to stick to
;; SB!VM:N-MACHINE-WORD-BITS for the time being. --njf, 2004-08-14
#.`(progn
#!+(or x86 x86-64 arm)
#!+(or x86 x86-64 arm arm64)
(def sb!vm::ash-left-modfx
:tagged ,(- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits) t)
(def ,(intern (format nil "ASH-LEFT-MOD~D" sb!vm:n-machine-word-bits)

615
src/compiler/x86-64/#type-vops.lisp# Normal file
View file

@ -0,0 +1,615 @@
;;;; type testing and checking VOPs for the x86-64 VM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; test generation utilities
;;; Optimize the case of moving a 64-bit value into RAX when not caring
;;; about the upper 32 bits: often the REX prefix can be spared.
(defun move-qword-to-eax (value)
(if (and (sc-is value any-reg descriptor-reg)
(< (tn-offset value) r8-offset))
(move eax-tn (reg-in-size value :dword))
(move rax-tn value)))
(defun generate-fixnum-test (value)
#!+sb-doc
"Set the Z flag if VALUE is fixnum"
(inst test
(cond ((sc-is value any-reg descriptor-reg)
(reg-in-size value :byte))
;; This is hooey. None of the type-vops presently allow
;; control-stack as a storage class.
((sc-is value control-stack)
(make-ea :byte :base rbp-tn
:disp (frame-byte-offset (tn-offset value))))
(t
value))
fixnum-tag-mask))
(defun %test-fixnum (value target not-p)
(generate-fixnum-test value)
(inst jmp (if not-p :nz :z) target))
;;; General FIXME: it's fine that we wire these to use rAX which has
;;; the shortest encoding, but for goodness sake can we pass the TN
;;; from the VOP like every other backend does? Freely referencing the
;;; permanent globals RAX-TN,EAX-TN,AL-TN is a bad way to go about it.
(defun %lea-for-lowtag-test (target value lowtag)
(inst lea target (make-ea :dword :base value :disp (- lowtag))))
;; Numerics including fixnum, excluding short-float. (INTEGER,RATIONAL)
(defun %test-fixnum-and-headers (value target not-p headers)
(let ((drop-through (gen-label)))
(case n-fixnum-tag-bits
(1 (%lea-for-lowtag-test eax-tn value other-pointer-lowtag)
(inst test al-tn 1)
(inst jmp :nz (if not-p drop-through target)) ; inverted
(%test-headers value target not-p nil headers
:drop-through drop-through :compute-eax nil))
(t
(generate-fixnum-test value)
(inst jmp :z (if not-p drop-through target))
(%test-headers value target not-p nil headers
:drop-through drop-through)))))
;; I can see no reason this would ever be used.
;; (or fixnum character|unbound-marker) is implausible.
(defun %test-fixnum-and-immediate (value target not-p immediate)
(let ((drop-through (gen-label)))
(generate-fixnum-test value)
(inst jmp :z (if not-p drop-through target))
(%test-immediate value target not-p immediate drop-through)))
;; Numerics
(defun %test-fixnum-immediate-and-headers (value target not-p immediate
headers)
(let ((drop-through (gen-label)))
(case n-fixnum-tag-bits
(1 (%lea-for-lowtag-test eax-tn value other-pointer-lowtag)
(inst test al-tn 1)
(inst jmp :nz (if not-p drop-through target)) ; inverted
(inst cmp al-tn (- immediate other-pointer-lowtag))
(inst jmp :e (if not-p drop-through target))
(%test-headers value target not-p nil headers
:drop-through drop-through :compute-eax nil))
(t (generate-fixnum-test value)
(inst jmp :z (if not-p drop-through target))
(%test-immediate-and-headers value target not-p immediate headers
drop-through)))))
(defun %test-immediate (value target not-p immediate
&optional (drop-through (gen-label)))
;; Code a single instruction byte test if possible.
(cond ((sc-is value any-reg descriptor-reg)
(inst cmp (reg-in-size value :byte) immediate))
(t
(move rax-tn value)
(inst cmp al-tn immediate)))
(inst jmp (if not-p :ne :e) target)
(emit-label drop-through))
;; Numerics including short-float, excluding fixnum
(defun %test-immediate-and-headers (value target not-p immediate headers
&optional (drop-through (gen-label)))
;; Code a single instruction byte test if possible.
(cond ((sc-is value any-reg descriptor-reg)
(inst cmp (reg-in-size value :byte) immediate))
(t
(move rax-tn value)
(inst cmp al-tn immediate)))
(inst jmp :e (if not-p drop-through target))
(%test-headers value target not-p nil headers :drop-through drop-through))
(defun %test-lowtag (value target not-p lowtag)
(%lea-for-lowtag-test eax-tn value lowtag)
(inst test al-tn lowtag-mask)
(inst jmp (if not-p :nz :z) target))
(defun %test-headers (value target not-p function-p headers
&key except
(drop-through (gen-label))
(compute-eax t))
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind (equal less-or-equal greater-or-equal when-true
when-false)
;; EQUAL, LESS-OR-EQUAL, and GREATER-OR-EQUAL are the conditions
;; for branching to TARGET. WHEN-TRUE and WHEN-FALSE are the
;; labels to branch to when we know it's true and when we know
;; it's false respectively.
(if not-p
(values :ne :a :b drop-through target)
(values :e :na :nb target drop-through))
(when compute-eax
(%lea-for-lowtag-test eax-tn value lowtag))
(inst test al-tn lowtag-mask)
(inst jmp :nz when-false)
;; FIXME: this backend seems to be missing the special logic for
;; testing exactly two widetags differing only in a single bit,
;; which through evolution is almost totally unworkable anyway...
(do ((remaining headers (cdr remaining))
;; It is preferable (smaller and faster code) to directly
;; compare the value in memory instead of loading it into
;; a register first. Find out if this is possible and set
;; WIDETAG-TN accordingly. If impossible, generate the
;; register load.
;; Compared to x86 we additionally optimize the cases of a
;; range starting with BIGNUM-WIDETAG (= min widetag)
;; or ending with COMPLEX-ARRAY-WIDETAG (= max widetag)
(widetag-tn (if (and (null (cdr headers))
(not except)
(or (atom (car headers))
(= (caar headers) bignum-widetag)
(= (cdar headers) complex-array-widetag)))
(make-ea :byte :base value :disp (- lowtag))
(progn
(inst mov eax-tn (make-ea :dword :base value
:disp (- lowtag)))
al-tn))))
((null remaining))
(dolist (widetag except) ; only after loading widetag-tn
(inst cmp al-tn widetag)
(inst jmp :e when-false))
(setq except nil)
(let ((header (car remaining))
(last (null (cdr remaining))))
(cond
((atom header)
(inst cmp widetag-tn header)
(if last
(inst jmp equal target)
(inst jmp :e when-true)))
(t
(let ((start (car header))
(end (cdr header)))
(cond
((= start bignum-widetag)
(inst cmp widetag-tn end)
(if last
(inst jmp less-or-equal target)
(inst jmp :be when-true)))
((= end complex-array-widetag)
(inst cmp widetag-tn start)
(if last
(inst jmp greater-or-equal target)
(inst jmp :b when-false)))
((not last)
(inst cmp al-tn start)
(inst jmp :b when-false)
(inst cmp al-tn end)
(inst jmp :be when-true))
(t
(inst sub al-tn start)
(inst cmp al-tn (- end start))
(inst jmp less-or-equal target))))))))
(emit-label drop-through))))
;;;; type checking and testing
(define-vop (check-type)
(:args (value :target result :scs (any-reg descriptor-reg)))
(:results (result :scs (any-reg descriptor-reg)))
(:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
(:ignore eax)
(:vop-var vop)
(:save-p :compute-only))
(define-vop (type-predicate)
(:args (value :scs (any-reg descriptor-reg)))
(:temporary (:sc unsigned-reg :offset eax-offset) eax)
(:ignore eax)
(:conditional)
(:info target not-p)
(:policy :fast-safe))
;;; simpler VOP that don't need a temporary register
(define-vop (simple-check-type)
(:args (value :target result :scs (any-reg descriptor-reg)))
(:results (result :scs (any-reg descriptor-reg)
:load-if (not (and (sc-is value any-reg descriptor-reg)
(sc-is result control-stack)))))
(:vop-var vop)
(:save-p :compute-only))
(define-vop (simple-type-predicate)
(:args (value :scs (any-reg descriptor-reg control-stack)))
(:conditional)
(:info target not-p)
(:policy :fast-safe))
(defmacro !define-type-vops (pred-name check-name ptype error-code
(&rest type-codes)
&key (variant nil variant-p) &allow-other-keys)
;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the
;; expansion?
(flet ((cost-to-test-types (type-codes)
(+ (* 2 (length type-codes))
(if (> (apply #'max type-codes) lowtag-limit) 7 2))))
(let* ((cost (cost-to-test-types (mapcar #'eval type-codes)))
(prefix (if variant-p
(concatenate 'string (string variant) "-")
"")))
`(progn
,@(when pred-name
`((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE")))
(:translate ,pred-name)
(:generator ,cost
(test-type value target not-p (,@type-codes))))))
,@(when check-name
`((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE")))
(:generator ,cost
(let ((err-lab
(generate-error-code vop ',error-code value)))
(test-type value err-lab t (,@type-codes))
(move result value))))))
,@(when ptype
`((primitive-type-vop ,check-name (:check) ,ptype)))))))
;;;; other integer ranges
(define-vop (fixnump/unsigned-byte-64 simple-type-predicate)
(:args (value :scs (unsigned-reg)))
(:arg-types unsigned-num)
(:translate fixnump)
(:temporary (:sc unsigned-reg :from (:argument 0)) tmp)
(:info)
(:conditional :z)
(:generator 5
(move tmp value)
(inst shr tmp n-positive-fixnum-bits)))
#-#.(cl:if (cl:= sb!vm:n-fixnum-tag-bits 1) '(:and) '(:or))
(define-vop (fixnump/signed-byte-64 simple-type-predicate)
(:args (value :scs (signed-reg)))
(:info)
(:conditional :z)
(:temporary (:sc unsigned-reg) temp)
(:arg-types signed-num)
(:translate fixnump)
(:generator 5
;; Hackers Delight, p. 53: signed
;; a <= x <= a + 2^n - 1
;; is equivalent to unsigned
;; ((x-a) >> n) = 0
(inst mov temp #.(- sb!xc:most-negative-fixnum))
(inst add temp value)
(inst shr temp n-fixnum-bits)))
#+#.(cl:if (cl:= sb!vm:n-fixnum-tag-bits 1) '(:and) '(:or))
(define-vop (fixnump/signed-byte-64 simple-type-predicate)
(:args (value :scs (signed-reg) :target temp))
(:info)
(:conditional :no)
(:temporary (:sc unsigned-reg :from (:argument 0)) temp)
(:arg-types signed-num)
(:translate fixnump)
(:generator 5
(move temp value)
;; The overflow flag will be set if the reg's sign bit changes.
(inst shl temp 1)))
;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with
;;; exactly one digit.
(define-vop (signed-byte-64-p type-predicate)
(:translate signed-byte-64-p)
(:generator 45
(multiple-value-bind (yep nope)
(if not-p
(values not-target target)
(values target not-target))
#.(case n-fixnum-tag-bits
(1 '(progn
(%lea-for-lowtag-test eax-tn value other-pointer-lowtag)
(inst test al-tn fixnum-tag-mask) ; 0th bit = 1 => fixnum
(inst jmp :nz yep)
(inst test al-tn lowtag-mask)))
(t '(progn
(move-qword-to-eax value)
(inst test al-tn fixnum-tag-mask)
(inst jmp :e yep)
(inst and al-tn lowtag-mask)
(inst cmp al-tn other-pointer-lowtag))))
(inst jmp :ne nope)
(inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag)
(+ (ash 1 n-widetag-bits) bignum-widetag))
(inst jmp (if not-p :ne :e) target))
NOT-TARGET))
;; FIXME: this vop is never emitted. I suspect that is because whenever
;; we have something which needs to be asserted as (SIGNED-BYTE 64) and
;; then moved to a signed-reg, the signed-byte-64-p vop is used and then
;; move-to-word. We apparently never want to both assert the type and
;; keep it as a tagged object. Anyway if it ever were emitted before,
;; GENERATE-ERROR-CODE would have failed since OBJECT-NOT-SIGNED-BYTE-64
;; did not have an error number.
(define-vop (check-signed-byte-64 check-type)
(:generator 45
(let ((nope (generate-error-code vop
'object-not-signed-byte-64-error
value)))
(generate-fixnum-test value)
(inst jmp :e yep)
(move-qword-to-eax value)
(inst and al-tn lowtag-mask)
(inst cmp al-tn other-pointer-lowtag)
(inst jmp :ne nope)
(inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag)
(+ (ash 1 n-widetag-bits) bignum-widetag))
(inst jmp :ne nope))
YEP
(move result value)))
;;; An (unsigned-byte 64) can be represented with either a positive
;;; fixnum, a bignum with exactly one positive digit, or a bignum with
;;; exactly two digits and the second digit all zeros.
(define-vop (unsigned-byte-64-p type-predicate)
(:translate unsigned-byte-64-p)
(:generator 45
(let ((not-target (gen-label))
(single-word (gen-label))
(fixnum (gen-label)))
(multiple-value-bind (yep nope)
(if not-p
(values not-target target)
(values target not-target))
;; Is it a fixnum?
(move rax-tn value)
(inst test al-tn fixnum-tag-mask)
(inst jmp :e fixnum)
;; If not, is it an other pointer?
(inst and al-tn lowtag-mask)
(inst cmp al-tn other-pointer-lowtag)
(inst jmp :ne nope)
;; Get the header.
(loadw rax-tn value 0 other-pointer-lowtag)
;; Is it one?
(inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
(inst jmp :e single-word)
;; If it's other than two, we can't be an (unsigned-byte 64)
(inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
(inst jmp :ne nope)
;; Get the second digit.
(loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
;; All zeros, its an (unsigned-byte 64).
(inst test rax-tn rax-tn)
(inst jmp :z yep)
(inst jmp nope)
(emit-label single-word)
;; Get the single digit.
(loadw rax-tn value bignum-digits-offset other-pointer-lowtag)
;; positive implies (unsigned-byte 64).
(emit-label fixnum)
(inst test rax-tn rax-tn)
(inst jmp (if not-p :s :ns) target)
(emit-label not-target)))))
(define-vop (check-unsigned-byte-64 check-type)
(:generator 45
(let ((nope
(generate-error-code vop 'object-not-unsigned-byte-64-error value))
(yep (gen-label))
(fixnum (gen-label))
(single-word (gen-label)))
;; Is it a fixnum?
(generate-fixnum-test value)
(move rax-tn value)
(inst jmp :e fixnum)
;; If not, is it an other pointer?
(inst and al-tn lowtag-mask)
(inst cmp al-tn other-pointer-lowtag)
(inst jmp :ne nope)
;; Get the header.
(loadw rax-tn value 0 other-pointer-lowtag)
;; Is it one?
(inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
(inst jmp :e single-word)
;; If it's other than two, we can't be an (unsigned-byte 64)
(inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
(inst jmp :ne nope)
;; Get the second digit.
(loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
;; All zeros, its an (unsigned-byte 64).
(inst test rax-tn rax-tn)
(inst jmp :z yep)
(inst jmp nope)
(emit-label single-word)
;; Get the single digit.
(loadw rax-tn value bignum-digits-offset other-pointer-lowtag)
;; positive implies (unsigned-byte 64).
(emit-label fixnum)
(inst test rax-tn rax-tn)
(inst jmp :s nope)
(emit-label yep)
(move result value))))
(defun power-of-two-limit-p (x)
(and (fixnump x)
(= (logcount (1+ x)) 1)))
(define-vop (test-fixnum-mod-power-of-two)
(:args (value :scs (any-reg descriptor-reg
unsigned-reg signed-reg
immediate)))
(:arg-types *
(:constant (satisfies power-of-two-limit-p)))
(:translate fixnum-mod-p)
(:conditional :e)
(:info hi)
(:save-p :compute-only)
(:policy :fast-safe)
(:generator 4
(aver (not (sc-is value immediate)))
(let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
hi
(fixnumize hi))))
(inst test value (constantize (lognot fixnum-hi))))))
(define-vop (test-fixnum-mod-tagged-unsigned)
(:args (value :scs (any-reg descriptor-reg
unsigned-reg signed-reg
immediate)))
(:arg-types (:or tagged-num unsigned-num signed-num)
(:constant fixnum))
(:translate fixnum-mod-p)
(:conditional :be)
(:info hi)
(:save-p :compute-only)
(:policy :fast-safe)
(:generator 5
(aver (not (sc-is value immediate)))
(let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
hi
(fixnumize hi))))
(inst cmp value (constantize fixnum-hi)))))
(define-vop (test-fixnum-mod-*)
(:args (value :scs (any-reg descriptor-reg)))
(:arg-types * (:constant fixnum))
(:translate fixnum-mod-p)
(:conditional)
(:info target not-p hi)
(:save-p :compute-only)
(:policy :fast-safe)
(:generator 6
(let* ((fixnum-hi (fixnumize hi))
(skip (gen-label)))
(generate-fixnum-test value)
(inst jmp :ne (if not-p target skip))
(inst cmp value (constantize fixnum-hi))
(inst jmp (if not-p :a :be) target)
(emit-label skip))))
;;;; list/symbol types
;;;
;;; symbolp (or symbol (eq nil))
;;; consp (and list (not (eq nil)))
(define-vop (symbolp type-predicate)
(:translate symbolp)
(:generator 12
(let ((is-symbol-label (if not-p DROP-THRU target)))
(inst cmp value nil-value)
(inst jmp :e is-symbol-label)
(test-type value target not-p (symbol-header-widetag)))
DROP-THRU))
(define-vop (check-symbol check-type)
(:generator 12
(let ((error (generate-error-code vop 'object-not-symbol-error value)))
(inst cmp value nil-value)
(inst jmp :e DROP-THRU)
(test-type value error t (symbol-header-widetag)))
DROP-THRU
(move result value)))
(define-vop (consp type-predicate)
(:translate consp)
(:generator 8
(let ((is-not-cons-label (if not-p target DROP-THRU)))
(inst cmp value nil-value)
(inst jmp :e is-not-cons-label)
(test-type value target not-p (list-pointer-lowtag)))
DROP-THRU))
(define-vop (check-cons check-type)
(:generator 8
(let ((error (generate-error-code vop 'object-not-cons-error value)))
(inst cmp value nil-value)
(inst jmp :e error)
(test-type value error t (list-pointer-lowtag))
(move result value))))
;; A vop that accepts a computed set of widetags.
(define-vop (%other-pointer-subtype-p type-predicate)
(:translate %other-pointer-subtype-p)
(:info target not-p widetags)
(:arg-types * (:constant t)) ; voodoo - 'target' and 'not-p' are absent
(:generator 15 ; arbitrary
(multiple-value-bind (headers exceptions)
(canonicalize-headers-and-exceptions widetags)
(%test-headers value target not-p nil headers
:except exceptions))))
#!+sb-simd-pack
(progn
(!define-type-vops simd-pack-p nil nil nil (simd-pack-widetag))
(define-vop (check-simd-pack check-type)
(:args (value :target result
:scs (any-reg descriptor-reg
int-sse-reg single-sse-reg double-sse-reg
int-sse-stack single-sse-stack double-sse-stack)))
(:results (result :scs (any-reg descriptor-reg
int-sse-reg single-sse-reg double-sse-reg)))
(:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
(:ignore eax)
(:vop-var vop)
(:node-var node)
(:save-p :compute-only)
(:generator 50
(sc-case value
((int-sse-reg single-sse-reg double-sse-reg
int-sse-stack single-sse-stack double-sse-stack)
(sc-case result
((int-sse-reg single-sse-reg double-sse-reg)
(move result value))
((any-reg descriptor-reg)
(with-fixed-allocation (result
simd-pack-widetag
simd-pack-size
node)
;; see *simd-pack-element-types*
(storew (fixnumize
(sc-case value
((int-sse-reg int-sse-stack) 0)
((single-sse-reg single-sse-stack) 1)
((double-sse-reg double-sse-stack) 2)))
result simd-pack-tag-slot other-pointer-lowtag)
(let ((ea (make-ea-for-object-slot
result simd-pack-lo-value-slot other-pointer-lowtag)))
(if (float-simd-pack-p value)
(inst movaps ea value)
(inst movdqa ea value)))))))
((any-reg descriptor-reg)
(let ((leaf (sb!c::tn-leaf value)))
(unless (and (sb!c::lvar-p leaf)
(csubtypep (sb!c::lvar-type leaf)
(specifier-type 'simd-pack)))
(test-type
value
(generate-error-code vop 'object-not-simd-pack-error value)
t (simd-pack-widetag))))
(sc-case result
((int-sse-reg)
(let ((ea (make-ea-for-object-slot
value simd-pack-lo-value-slot other-pointer-lowtag)))
(inst movdqa result ea)))
((single-sse-reg double-sse-reg)
(let ((ea (make-ea-for-object-slot
value simd-pack-lo-value-slot other-pointer-lowtag)))
(inst movaps result ea)))
((any-reg descriptor-reg)
(move result value)))))))
(primitive-type-vop check-simd-pack (:check) simd-pack-int simd-pack-single simd-pack-double))

1
src/compiler/x86-64/.#type-vops.lisp Symbolic link
View file

@ -0,0 +1 @@
stas@debian.6597:1440612832

40
src/runtime/Config.arm64-linux Normal file
View file

@ -0,0 +1,40 @@
# -*- makefile -*- for the C-level run-time support for SBCL
# This software is part of the SBCL system. See the README file for
# more information.
#
# This software is derived from the CMU CL system, which was
# written at Carnegie Mellon University and released into the
# public domain. The software is in the public domain and is
# provided with absolutely no warranty. See the COPYING and CREDITS
# files for more information.
CFLAGS = -g
#LINKFLAGS += -v -rdynamic -m32
NM = ./linux-nm
ASSEM_SRC = arm64-assem.S ldso-stubs.S
ARCH_SRC = arm64-arch.c
OS_SRC = linux-os.c arm64-linux-os.c
OS_LIBS = -ldl
ifdef LISP_FEATURE_GENCGC
GC_SRC = gencgc.c
else
GC_SRC = cheneygc.c
endif
ifdef LISP_FEATURE_SB_THREAD
OS_LIBS += -lpthread
endif
ifdef LISP_FEATURE_SB_CORE_COMPRESSION
OS_LIBS += -lz
endif
ifdef LISP_FEATURE_LARGEFILE
CFLAGS += -D_LARGEFILE_SOURCE -D_LARGEFILE64_SOURCE -D_FILE_OFFSET_BITS=64
endif
# Nothing to do for after-grovel-headers.
.PHONY: after-grovel-headers
after-grovel-headers:

0
src/runtime/a.out Normal file
View file

200
src/runtime/arm64-arch.c Normal file
View file

@ -0,0 +1,200 @@
/*
* This software is part of the SBCL system. See the README file for
* more information.
*
* This software is derived from the CMU CL system, which was
* written at Carnegie Mellon University and released into the
* public domain. The software is in the public domain and is
* provided with absolutely no warranty. See the COPYING and CREDITS
* files for more information.
*/
#include <stdio.h>
#include "sbcl.h"
#include "runtime.h"
#include "arch.h"
#include "globals.h"
#include "validate.h"
#include "os.h"
#include "lispregs.h"
#include "signal.h"
#include "alloc.h"
#include "interrupt.h"
#include "interr.h"
#include "breakpoint.h"
#include "monitor.h"
void arch_init(void)
{
return;
}
os_vm_address_t arch_get_bad_addr(int sig, siginfo_t *code, os_context_t *context)
{
return (os_vm_address_t)code->si_addr;
}
void arch_skip_instruction(os_context_t *context)
{
/* KLUDGE: Other platforms check for trap codes and skip inlined
* trap/error parameters. We should too. */
/* Note that we're doing integer arithmetic here, not pointer. So
* the value that the return value of os_context_pc_addr() points
* to will be incremented by 4, not 16.
*/
*os_context_pc_addr(context) += 4;
}
unsigned char *arch_internal_error_arguments(os_context_t *context)
{
return (unsigned char *)(*os_context_pc_addr(context) + 5);
}
boolean arch_pseudo_atomic_atomic(os_context_t *context)
{
/* FIXME: this foreign_function_call_active test is dubious at
* best. If a foreign call is made in a pseudo atomic section
* (?) or more likely a pseudo atomic section is in a foreign
* call then an interrupt is executed immediately. Maybe it
* has to do with C code not maintaining pseudo atomic
* properly. MG - 2005-08-10
*
* The foreign_function_call_active used to live at each call-site
* to arch_pseudo_atomic_atomic, but this seems clearer.
* --NS 2007-05-15 */
#ifdef LISP_FEATURE_GENCGC
return SymbolValue(PSEUDO_ATOMIC_ATOMIC, 0) != NIL;
#else
return (!foreign_function_call_active)
&& (NIL != SymbolValue(PSEUDO_ATOMIC_ATOMIC,0));
#endif
}
void arch_set_pseudo_atomic_interrupted(os_context_t *context)
{
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, do_pending_interrupt, 0);
}
void arch_clear_pseudo_atomic_interrupted(os_context_t *context)
{
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, 0, 0);
}
unsigned int arch_install_breakpoint(void *pc)
{
/* FIXME: Implement. */
return 0;
}
void arch_remove_breakpoint(void *pc, unsigned int orig_inst)
{
/* FIXME: Implement. */
}
void arch_do_displaced_inst(os_context_t *context, unsigned int orig_inst)
{
/* FIXME: Implement. */
}
void
arch_handle_breakpoint(os_context_t *context)
{
handle_breakpoint(context);
}
void
arch_handle_fun_end_breakpoint(os_context_t *context)
{
*os_context_pc_addr(context) = (int) handle_fun_end_breakpoint(context);
}
void
arch_handle_single_step_trap(os_context_t *context, int trap)
{
unsigned char register_offset =
*((unsigned char *)(*os_context_pc_addr(context))+5);
handle_single_step_trap(context, trap, register_offset);
/* KLUDGE: arch_skip_instruction() only skips one instruction, and
* there is a following word to deal with as well, so skip
* twice. */
arch_skip_instruction(context);
arch_skip_instruction(context);
}
static void
sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context)
{
unsigned int code = *((unsigned char *)(4+*os_context_pc_addr(context)));
u32 trap_instruction = *((u32 *)*os_context_pc_addr(context));
if (trap_instruction != 0xe7f001f0) {
lose("Unrecognized trap instruction %08lx in sigtrap_handler()",
trap_instruction);
}
if (code == trap_PendingInterrupt) {
arch_skip_instruction(context);
}
handle_trap(context, code);
}
void arch_install_interrupt_handlers()
{
undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler);
}
#ifdef LISP_FEATURE_LINKAGE_TABLE
/* Linkage tables
*
* Linkage entry size is 16, because we need 4 instructions.
*/
#define LINKAGE_TEMP_REG reg_NFP
void arch_write_linkage_table_jmp(void* reloc_addr, void *target_addr)
{
/*
ldr reg, [pc, #4]
bx reg
nop
address
BX is needed for thumb interworking, without it it could take just two words with
ldr pc, [pc, #-4]
address
*/
int* inst_ptr;
unsigned inst;
inst_ptr = (int*) reloc_addr;
// ldr reg, [pc, #4]
inst = 0xe59f0000 | LINKAGE_TEMP_REG << 12 | 4;
*inst_ptr++ = inst;
// bx reg
inst = 0xe12fff10 | LINKAGE_TEMP_REG;
*inst_ptr++ = inst;
// nop aka mov r0, r0
inst = 0xe1a00000;
*inst_ptr++ = inst;
// address
*inst_ptr++ = target_addr;
os_flush_icache((os_vm_address_t) reloc_addr, (char*) inst_ptr - (char*) reloc_addr);
}
void
arch_write_linkage_table_ref(void * reloc_addr, void *target_addr)
{
*(unsigned long *)reloc_addr = (unsigned long)target_addr;
}
#endif

36
src/runtime/arm64-arch.h Normal file
View file

@ -0,0 +1,36 @@
#ifndef _ARM_ARCH_H
#define _ARM_ARCH_H
#define ALIEN_STACK_GROWS_DOWNWARD
static inline long
get_spinlock(lispobj *word,long value)
{
#ifdef LISP_FEATURE_SB_THREAD
#error "get_spinlock not defined for threads"
#else
*word=value;
return 0;
#endif
}
static inline void
release_spinlock(lispobj *word)
{
#ifdef LISP_FEATURE_SB_THREAD
#error "release_spinlock not defined for threads"
#endif
*word=0;
}
#ifdef LISP_FEATURE_SB_THREAD
static inline lispobj
swap_lispobjs(volatile lispobj *dest, lispobj value)
{
#error "swap_lispobjs not defined for threads"
}
#endif
#define ARCH_HAS_LINK_REGISTER
#endif /* _ARM_ARCH_H */

480
src/runtime/arm64-assem.S Normal file
View file

@ -0,0 +1,480 @@
#define LANGUAGE_ASSEMBLY
#include "lispregs.h"
#include "globals.h"
#include "sbcl.h"
#include "genesis/closure.h"
#include "genesis/funcallable-instance.h"
#include "genesis/fdefn.h"
#include "genesis/static-symbols.h"
#include "genesis/simple-fun.h"
#include "genesis/symbol.h"
#define STATIC_SYMBOL_VALUE(sym) [reg_NULL, #(((sym)-NIL)+SYMBOL_VALUE_OFFSET)]
.align
.global call_into_lisp
.type call_into_lisp, %function
call_into_lisp:
// At this point, we have:
// X0 - function
// X1 - pointer to args
// X2 - number of args (unboxed)
// There will be no more than three args, so we don't need to
// worry about parameters to be passed on the stack.
// All registers other than X0-X3 and X12 are callee-saves.
// Save X3 to get 8-byte alignemnt.
stmfd sp!, {x3-x11, lr}
fstmfdd sp!, {d8-d15}
// Start by finding NIL.
ldr reg_NULL, .known_nil
// Set up NARGS.
mov reg_NARGS, x2, lsl #2
// Move args pointer out of the way of the args to be loaded.
mov reg_X8, x1
// Move the function to its passing location.
mov reg_LEXENV, x0
// Clear the boxed registers that don't already have something
// in them.
mov reg_CODE, #0
mov reg_X2, #0
// Find the lisp stack and frame pointers. We're allocating a
// new lisp stack frame, so load the stack pointer into CFP.
// And we need the frame pointer, but OCFP is in use, so use
// NFP instead.
ldr reg_NFP, .frame_pointer_address
ldr reg_CFP, .stack_pointer_address
ldr reg_NFP, [reg_NFP]
ldr reg_CFP, [reg_CFP]
// Enter PSEUDO-ATOMIC.
str pc, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_ATOMIC)
#ifndef LISP_FEATURE_GENCGC
// Copy the current allocation pointer into the symbol.
ldr reg_OCFP, =dynamic_space_free_pointer
ldr reg_OCFP, [reg_OCFP]
str reg_OCFP, STATIC_SYMBOL_VALUE(ALLOCATION_POINTER)
#endif
// Clear FFCA, so the runtime knows that we're "in lisp".
ldr reg_OCFP, =foreign_function_call_active
str reg_X2, [reg_OCFP]
// We need to set up the lisp stack pointer and the basics of
// our stack frame while we're still in P-A. Any sooner and
// our stack frame can be clobbered by a stray interrupt, any
// later and we can end up with a half-configured stack frame
// when we catch a stray interrupt.
// Allocate our frame and set up the Lisp stack pointer
add reg_OCFP, reg_CFP, #8
str reg_OCFP, STATIC_SYMBOL_VALUE(CONTROL_STACK_POINTER)
// Set up the "frame link"
str reg_NFP, [reg_OCFP, #-8]
// Set up the return address
ldr reg_NL3, =.lra
str reg_NL3, [reg_OCFP, #-4]
// Leave PSEUDO-ATOMIC and check for interrupts.
str reg_NULL, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_ATOMIC)
ldr reg_OCFP, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_INTERRUPTED)
cmp reg_OCFP, #0
blxne reg_OCFP
// Load our function args. Cleverness abounds!
rsb reg_NL3, reg_NARGS, #8
add pc, pc, reg_NL3
ldr reg_X2, [reg_X8, #8]
ldr reg_X1, [reg_X8, #4]
ldr reg_X0, [reg_X8]
// 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]
// And, finally, call into Lisp!
add reg_PC, reg_CODE, #SIMPLE_FUN_CODE_OFFSET
.align 3
.equ .lra, .+OTHER_POINTER_LOWTAG
.word RETURN_PC_HEADER_WIDETAG
// Correct stack pointer for return processing.
streq reg_OCFP, STATIC_SYMBOL_VALUE(CONTROL_STACK_POINTER)
// Enter PSEUDO-ATOMIC.
str pc, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_ATOMIC)
// Save the lisp stack and frame pointers.
ldr reg_NFP, .frame_pointer_address
str reg_CFP, [reg_NFP]
ldr reg_NFP, STATIC_SYMBOL_VALUE(CONTROL_STACK_POINTER)
ldr reg_OCFP, .stack_pointer_address
str reg_NFP, [reg_OCFP]
// Set FFCA, so the runtime knows that we're not "in lisp".
ldr reg_OCFP, =foreign_function_call_active
str pc, [reg_OCFP]
#ifndef LISP_FEATURE_GENCGC
// Copy the current allocation pointer out from the symbol.
ldr reg_OCFP, =dynamic_space_free_pointer
ldr reg_NFP, STATIC_SYMBOL_VALUE(ALLOCATION_POINTER)
str reg_NFP, [reg_OCFP]
#endif
// Leave PSEUDO-ATOMIC and check for interrupts.
str reg_NULL, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_ATOMIC)
ldr reg_OCFP, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_INTERRUPTED)
cmp reg_OCFP, #0
blxne reg_OCFP
// Restore saved registers.
fldmfdd sp!, {d8-d15}
ldmfd sp!, {x3-x11, lr}
bx lr
.size call_into_lisp, .-call_into_lisp
.frame_pointer_address: .word current_control_frame_pointer
.stack_pointer_address: .word current_control_stack_pointer
.align
.global call_into_c
.type call_into_c, %function
call_into_c:
// At this point, we have:
// X8 -- C function to call. This routine doesn't support
// thumb interworking, but linkage-table does, so we
// don't have to.
// LR -- Return address within the code component.
// OCFP -- First C register argument.
// NARGS -- Second C register argument.
// NL2 -- Third C register argument.
// NL3 -- Fourth C register argument.
// 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.
// We have ONE unboxed scratch register: NFP. Use it as a
// temporary while we convert the (unboxed) return address to
// a (fixnum) offset within the component.
sub reg_NFP, reg_LR, reg_CODE
add reg_NFP, reg_NFP, #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). The stack is aligned, so
// we can use X0 (a boxed register) as our temporary.
ldr reg_X0, STATIC_SYMBOL_VALUE(CONTROL_STACK_POINTER)
add reg_X0, reg_X0, #12
str reg_X0, STATIC_SYMBOL_VALUE(CONTROL_STACK_POINTER)
str reg_CFP, [reg_X0, #-12]
str reg_NFP, [reg_X0, #-8]
str reg_CODE, [reg_X0, #-4]
// Enter PSEUDO-ATOMIC.
str pc, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_ATOMIC)
// Save the lisp stack and frame pointers.
ldr reg_NFP, .stack_pointer_address
str reg_X0, [reg_NFP]
sub reg_X0, reg_X0, #12
ldr reg_NFP, .frame_pointer_address
str reg_X0, [reg_NFP]
// We're done with X0, and we need to use OCFP when leaving
// pseudo-atomic, so move the first of the C register
// arguments to its final resting place now.
mov x0, reg_OCFP
// Set FFCA, so the runtime knows that we're not "in lisp".
ldr reg_NFP, =foreign_function_call_active
str pc, [reg_NFP]
#ifndef LISP_FEATURE_GENCGC
// Copy the current allocation pointer out from the symbol.
ldr reg_OCFP, =dynamic_space_free_pointer
ldr reg_NFP, STATIC_SYMBOL_VALUE(ALLOCATION_POINTER)
str reg_NFP, [reg_OCFP]
#endif
// Leave PSEUDO-ATOMIC and check for interrupts.
str reg_NULL, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_ATOMIC)
ldr reg_OCFP, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_INTERRUPTED)
cmp reg_OCFP, #0
blxne reg_OCFP
// Now that we're in C mode, move the remaining register args
// into place.
mov x1, reg_NARGS
mov x2, reg_NL2
mov x3, reg_NL3
// And call the C function. We don't support interworking
// here because we have to be able to pass the function
// pointer in a boxed register, but the linkage-table is quite
// capable of doing a tail-call to a Thumb routine.
//
// X8 is important for undefined_alien_function.
blx reg_X8
// We're back. Our main tasks are to move the C return value
// to where Lisp expects it, and to re-establish the Lisp
// environment.
// Stash the return value into NARGS for Lisp.
mov reg_NARGS, x0
// For returning long-long, and doubles with softfp.
mov reg_NL3, x1
// Re-establish NIL.
ldr reg_NULL, .known_nil
// Blank the boxed registers.
mov reg_X0, #0
mov reg_X1, #0
mov reg_X2, #0
mov reg_LEXENV, #0
mov reg_X8, #0
mov reg_CODE, #0
// Enter PSEUDO-ATOMIC.
str pc, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_ATOMIC)
// Clear FFCA, so the runtime knows that we're "in lisp".
ldr reg_OCFP, =foreign_function_call_active
str reg_X2, [reg_OCFP]
#ifndef LISP_FEATURE_GENCGC
// Copy the current allocation pointer into the symbol.
ldr reg_OCFP, =dynamic_space_free_pointer
ldr reg_OCFP, [reg_OCFP]
str reg_OCFP, STATIC_SYMBOL_VALUE(ALLOCATION_POINTER)
#endif
// Restore the Lisp stack and frame pointers, but store the
// control frame pointer in reg_NFP (saving a register move
// later).
ldr reg_NFP, .stack_pointer_address
ldr reg_CFP, [reg_NFP]
str reg_CFP, STATIC_SYMBOL_VALUE(CONTROL_STACK_POINTER)
ldr reg_NFP, .frame_pointer_address
ldr reg_NFP, [reg_NFP]
// Leave PSEUDO-ATOMIC and check for interrupts.
str reg_NULL, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_ATOMIC)
ldr reg_OCFP, STATIC_SYMBOL_VALUE(PSEUDO_ATOMIC_INTERRUPTED)
cmp reg_OCFP, #0
blxne reg_OCFP
// Restore our caller state from our stack frame.
ldr reg_CODE, [reg_NFP, #8]
ldr reg_NL2, [reg_NFP, #4]
ldr reg_CFP, [reg_NFP]
str reg_NFP, STATIC_SYMBOL_VALUE(CONTROL_STACK_POINTER)
// Restore our return address... into the program counter.
sub reg_NL2, reg_NL2, #OTHER_POINTER_LOWTAG
add reg_PC, reg_NL2, reg_CODE
.size call_into_c, .-call_into_c
/* Trampolines, like on SPARC, use Lisp calling conventions. */
.align 3
.global undefined_tramp
.type undefined_tramp, %object
.word SIMPLE_FUN_HEADER_WIDETAG
.equ undefined_tramp, .+1
.word undefined_tramp
.known_nil:
.word NIL
.word NIL
.word NIL
.word NIL
.word NIL
// As in ppc-assem.S, point reg_CODE to the header with a
// function lowtag... Which the address already has.
ldr reg_CODE, =undefined_tramp
// The magic (undefined) "BREAK_POINT" instruction.
.word 0xe7f001f0
// Error arguments for an undefined function.
.byte trap_Error
.byte .error_args_end - . - 1
.byte UNDEFINED_FUN_ERROR
// Need to indicate reg_LEXENV here, which is X3. Encoding
// rules are to produce an "sc-offset" with the SC number in
// the low six bits and the offset (3 in our case) in the
// high $n$ bits. sc_DescriptorReg happens to be 5, but we
// should use the constant for it. So long as the overall
// value of the sc-offset is less than 254, we can use a
// single byte. Overflowing that will take having the SC
// number being 30 or 31, and as of this writing the highest
// SC number is sc_CatchBlock at 16. It would also take an
// offset of 7, not the 3 that we use for LEXENV.
.byte sc_DescriptorReg + (0x40 * 3)
.error_args_end:
.align 3
.global undefined_alien_function
.type undefined_alien_function, %object
.word SIMPLE_FUN_HEADER_WIDETAG
.equ undefined_alien_function, .+1
.word undefined_alien_function
.word NIL
.word NIL
.word NIL
.word NIL
.word NIL
undefined_alien_function:
ldr reg_CODE, = undefined_alien_function
// The magic (undefined) "BREAK_POINT" instruction.
.word 0xe7f001f0
// Error arguments for an undefined function.
.byte trap_Error
.byte 4
.byte UNDEFINED_ALIEN_FUN_ERROR
// Encode unsigned X8, which comes from call_into_c
.byte 0xFE
.byte 0x11
.byte 0x02
.align 3
.global closure_tramp
.type closure_tramp, %object
.word SIMPLE_FUN_HEADER_WIDETAG
.equ closure_tramp, .+1
.word closure_tramp
.word NIL
.word NIL
.word NIL
.word NIL
.word NIL
ldr reg_LEXENV, [reg_LEXENV, #FDEFN_FUN_OFFSET]
ldr reg_CODE, [reg_LEXENV, #CLOSURE_FUN_OFFSET]
add reg_PC, reg_CODE, #SIMPLE_FUN_CODE_OFFSET
.align 3
.global funcallable_instance_tramp
.type funcallable_instance_tramp, %object
.word SIMPLE_FUN_HEADER_WIDETAG
.equ funcallable_instance_tramp, .+1
.word funcallable_instance_tramp
.word NIL
.word NIL
.word NIL
.word NIL
.word NIL
ldr reg_LEXENV, [reg_LEXENV, #FUNCALLABLE_INSTANCE_FUNCTION_OFFSET]
ldr reg_CODE, [reg_LEXENV, #CLOSURE_FUN_OFFSET]
add reg_PC, reg_CODE, #SIMPLE_FUN_CODE_OFFSET
// FIXME-ARM: The following is random garbage, to make
// code/debug-int compile. To get the debugger working, this
// needs to be implemented.
.align
.global fun_end_breakpoint_guts
.type fun_end_breakpoint_guts, %object
fun_end_breakpoint_guts:
.global fun_end_breakpoint_trap
.type fun_end_breakpoint_trap, %function
fun_end_breakpoint_trap:
b fun_end_breakpoint_trap
.global fun_end_breakpoint_end
fun_end_breakpoint_end:
#ifdef LISP_FEATURE_GENCGC
.align
.global alloc_tramp
.type alloc_tramp, %function
alloc_tramp:
stmfd sp!, {x4, x6, x12, lr}
ldr x4, =foreign_function_call_active
str pc, [x4]
ldr x4, STATIC_SYMBOL_VALUE(CONTROL_STACK_POINTER)
add x6, x4, #8*4
str x6, STATIC_SYMBOL_VALUE(CONTROL_STACK_POINTER)
// Create a new frame and save descriptor regs on the stack
// for the GC to see.
str reg_CFP, [x4, #0]
str reg_NULL, [x4, #4]
str reg_CODE, [x4, #8]
add x4, x4, #3*4
stmea x4, {x0-reg_LEXENV, x8}
ldr x0, [sp, #4*4]
fstmfdd sp!, {d0-d7}
mov lr, pc
ldr pc,=alloc
fldmfdd sp!, {d0-d7}
str x0, [sp, #4*4]
ldr x4, STATIC_SYMBOL_VALUE(CONTROL_STACK_POINTER)
ldmea x4, {x0-reg_LEXENV, x8}
sub x4, x4, #8*4
str x4, STATIC_SYMBOL_VALUE(CONTROL_STACK_POINTER)
ldr x4, =foreign_function_call_active
mov x6, #0
str x6, [x4]
ldmfd sp!, {x4, x6, x12, lr}
bx lr
.align
.global fpu_save
.type fpu_save, %function
fpu_save:
fstmiad x0, {d0-d7}
bx lr
.align
.global fpu_restore
.type fpu_restore, %function
fpu_restore:
add x0, x0, #16
fldmiad x0, {d0-d7}
bx lr
.align
.global do_pending_interrupt
.type do_pending_interrupt, %function
do_pending_interrupt:
.word 0xe7f001f0
.byte trap_PendingInterrupt
.byte 0
.byte 0
.byte 0
bx lr
#endif

100
src/runtime/arm64-linux-os.c Normal file
View file

@ -0,0 +1,100 @@
/*
* This is the ARM Linux incarnation of arch-dependent OS-dependent
* routines. See also "linux-os.c".
*/
/*
* This software is part of the SBCL system. See the README file for
* more information.
*
* This software is derived from the CMU CL system, which was
* written at Carnegie Mellon University and released into the
* public domain. The software is in the public domain and is
* provided with absolutely no warranty. See the COPYING and CREDITS
* files for more information.
*/
#include <stdio.h>
#include <sys/param.h>
#include <sys/file.h>
#include "sbcl.h"
#include "./signal.h"
#include "os.h"
#include "arch.h"
#include "globals.h"
#include "interrupt.h"
#include "interr.h"
#include "lispregs.h"
#include <sys/socket.h>
#include <sys/utsname.h>
#include <sys/types.h>
#include <signal.h>
#include <sys/time.h>
#include <sys/stat.h>
#include <unistd.h>
#include <errno.h>
#include "validate.h"
size_t os_vm_page_size;
#ifdef LISP_FEATURE_SB_THREAD
#error "Define threading support functions"
#else
int arch_os_thread_init(struct thread *thread) {
stack_t sigstack;
/* Signal handlers are normally run on the main stack, but we've
* swapped stacks, require that the control stack contain only
* boxed data, and expands upwards while the C stack expands
* downwards. */
sigstack.ss_sp=((void *) thread)+dynamic_values_bytes;
sigstack.ss_flags=0;
sigstack.ss_size = 32*SIGSTKSZ;
if(sigaltstack(&sigstack,0)<0)
lose("Cannot sigaltstack: %s\n",strerror(errno));
return 1; /* success */
}
int arch_os_thread_cleanup(struct thread *thread) {
return 1; /* success */
}
#endif
os_context_regis
ter_t *
os_context_register_addr(os_context_t *context, int offset)
{
return &(context->uc_mcontext.regs[offset]);
}
os_context_register_t *
os_context_pc_addr(os_context_t *context)
{
return &(context->uc_mcontext.pc);
}
os_context_register_t *
os_context_lr_addr(os_context_t *context)
{
return os_context_register_addr(context, reg_LR);
}
sigset_t *
os_context_sigmask_addr(os_context_t *context)
{
return &(context->uc_sigmask);
}
void
os_restore_fp_control(os_context_t *context)
{
/* FIXME: Implement. */
}
void
os_flush_icache(os_vm_address_t address, os_vm_size_t length)
{
os_vm_address_t end_address
= (os_vm_address_t)(((pointer_sized_uint_t) address) + length);
__clear_cache(address, end_address);
}

16
src/runtime/arm64-linux-os.h Normal file
View file

@ -0,0 +1,16 @@
#ifndef _ARM_LINUX_OS_H
#define _ARM_LINUX_OS_H
typedef struct ucontext os_context_t;
typedef long os_context_register_t;
static inline os_context_t *arch_os_get_context(void **void_context)
{
return (os_context_t *) *void_context;
}
unsigned long os_context_fp_control(os_context_t *context);
#define RESTORE_FP_CONTROL_FROM_CONTEXT
void os_restore_fp_control(os_context_t *context);
#endif /* _ARM_LINUX_OS_H */

46
src/runtime/arm64-lispregs.h Normal file
View file

@ -0,0 +1,46 @@
/*
* This software is part of the SBCL system. See the README file for
* more information.
*
* This software is derived from the CMU CL system, which was
* written at Carnegie Mellon University and released into the
* public domain. The software is in the public domain and is
* provided with absolutely no warranty. See the COPYING and CREDITS
* files for more information.
*/
#define NREGS (31)
#ifdef LANGUAGE_ASSEMBLY
# define REG(num) w##num
#else
# define REG(num) (num)
#endif
#define reg_R0 REG(0)
#define reg_R1 REG(1)
#define reg_R2 REG(2)
#define reg_LEXENV REG(3)
#define reg_NL2 REG(4)
#define reg_CODE REG(5)
#define reg_NL3 REG(6)
#define reg_OCFP REG(7)
#define reg_R8 REG(8)
#define reg_NFP REG(9)
#define reg_NULL REG(10)
#define reg_CFP REG(11)
#define reg_NARGS REG(12)
#define reg_NSP REG(13)
#define reg_LR REG(30)
#define reg_PC REG(15)
#define REGNAMES \
"R0", "R1", "R2", "LEXENV", \
"NL2", "CODE", "NL3", "OCFP", \
"R8", "NFP", "NULL", "CFP", \
"NARGS", "NSP", "LR", "PC"
#define BOXED_REGISTERS { \
reg_R0, reg_R1, reg_R2, reg_LEXENV, reg_R8, reg_CODE \
}

2
src/runtime/backtrace.c
View file

@ -130,7 +130,7 @@ call_info_from_context(struct call_info *info, os_context_t *context)
uword_t pc;
info->interrupted = 1;
#if !defined(LISP_FEATURE_ARM)
#if !defined(LISP_FEATURE_ARM) && !defined(LISP_FEATURE_ARM64)
if (lowtag_of(*os_context_register_addr(context, reg_CODE))
== FUN_POINTER_LOWTAG) {
/* We tried to call a function, but crapped out before $CODE could

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

@ -823,7 +823,7 @@ size_tiny_boxed(lispobj *where)
/* Note: on the sparc we don't have to do anything special for fdefns, */
/* 'cause the raw-addr has a function lowtag. */
#if (!defined(LISP_FEATURE_SPARC)) && (!defined(LISP_FEATURE_ARM))
#if !defined(LISP_FEATURE_SPARC) && !defined(LISP_FEATURE_ARM) && !defined(LISP_FEATURE_ARM64)
static sword_t
scav_fdefn(lispobj *where, lispobj object)
{
@ -2179,7 +2179,7 @@ gc_init_tables(void)
scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
#if defined(LISP_FEATURE_SPARC) || defined(LISP_FEATURE_ARM)
#if defined(LISP_FEATURE_SPARC) || defined(LISP_FEATURE_ARM) || defined(LISP_FEATURE_ARM64)
scavtab[FDEFN_WIDETAG] = scav_boxed;
#else
scavtab[FDEFN_WIDETAG] = scav_fdefn;

2
src/runtime/gc-internal.h
View file

@ -73,7 +73,7 @@ NWORDS(uword_t x, uword_t n_bits)
/* FIXME: Shouldn't this be defined in sbcl.h? */
#if defined(LISP_FEATURE_SPARC) || defined(LISP_FEATURE_ARM)
#if defined(LISP_FEATURE_SPARC) || defined(LISP_FEATURE_ARM) || defined(LISP_FEATURE_ARM64)
#define FUN_RAW_ADDR_OFFSET 0
#else
#define FUN_RAW_ADDR_OFFSET (offsetof(struct simple_fun, code) - FUN_POINTER_LOWTAG)

3
src/runtime/gencgc.c
View file

@ -507,6 +507,9 @@ write_generation_stats(FILE *file)
#elif defined(LISP_FEATURE_ARM)
#define FPU_STATE_SIZE 8
long long fpu_state[FPU_STATE_SIZE];
#elif defined(LISP_FEATURE_ARM64)
#define FPU_STATE_SIZE 32
long fpu_state[FPU_STATE_SIZE];
#endif
/* This code uses the FP instructions which may be set up for Lisp

2
src/runtime/globals.c
View file

@ -38,7 +38,7 @@ lispobj *current_binding_stack_pointer;
/* ALLOCATION_POINTER is x86 or RT. Anyone want to do an RT port? */
# if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) && !defined(LISP_FEATURE_ARM)
# if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) && !defined(LISP_FEATURE_ARM) && !defined(LISP_FEATURE_ARM64)
/* The Object Formerly Known As current_dynamic_space_free_pointer */
lispobj *dynamic_space_free_pointer;
#endif

2
src/runtime/globals.h
View file

@ -113,7 +113,7 @@ extern void globals_init(void);
# define EXTERN(name,bytes) .global name
# endif
/**/
# ifdef LISP_FEATURE_ARM
# if defined(LISP_FEATURE_ARM) || defined(LISP_FEATURE_ARM64)
# define EXTERN(name,bytes) .global name
# endif

10
src/runtime/interrupt.c
View file

@ -641,7 +641,7 @@ build_fake_control_stack_frames(struct thread *th,os_context_t *context)
/* Build a fake stack frame or frames */
#if !defined(LISP_FEATURE_ARM)
#if !defined(LISP_FEATURE_ARM) && !defined(LISP_FEATURE_ARM64)
access_control_frame_pointer(th) =
(lispobj *)(uword_t)
(*os_context_register_addr(context, reg_CSP));
@ -732,7 +732,7 @@ fake_foreign_function_call(os_context_t *context)
*os_context_register_addr(context, reg_BSP));
#endif
#ifdef LISP_FEATURE_ARM
#if defined(LISP_FEATURE_ARM) || defined LISP_FEATURE_ARM64
/* Stash our control stack pointer */
bind_variable(INTERRUPTED_CONTROL_STACK_POINTER,
SymbolValue(CONTROL_STACK_POINTER, thread),
@ -778,7 +778,7 @@ undo_fake_foreign_function_call(os_context_t *context)
/* Undo dynamic binding of FREE_INTERRUPT_CONTEXT_INDEX */
unbind(thread);
#ifdef LISP_FEATURE_ARM
#if defined(LISP_FEATURE_ARM) || defined LISP_FEATURE_ARM64
/* Restore our saved control stack pointer */
SetSymbolValue(CONTROL_STACK_POINTER,
SymbolValue(INTERRUPTED_CONTROL_STACK_POINTER,
@ -1581,7 +1581,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)
#if defined(LISP_FEATURE_SPARC) || defined(LISP_FEATURE_ARM) || defined(LISP_FEATURE_ARM64)
*os_context_register_addr(context,reg_CODE) =
(os_context_register_t)(fun + FUN_POINTER_LOWTAG);
#endif
@ -1600,7 +1600,7 @@ arrange_return_to_lisp_function(os_context_t *context, lispobj function)
}
// These have undefined_alien_function tramp in x-assem.S
#if !(defined(LISP_FEATURE_X86_64) || defined(LISP_FEATURE_ARM))
#if !(defined(LISP_FEATURE_X86_64) || defined(LISP_FEATURE_ARM) || defined(LISP_FEATURE_ARM64))
/* KLUDGE: Theoretically the approach we use for undefined alien
* variables should work for functions as well, but on PPC/Darwin
* we get bus error at bogus addresses instead, hence this workaround,

2
src/runtime/pseudo-atomic.h
View file

@ -93,7 +93,7 @@ clear_pseudo_atomic_interrupted(struct thread *thread)
#undef LISPOBJ_ASM_SUFFIX
#elif defined(LISP_FEATURE_ARM)
#elif defined(LISP_FEATURE_ARM) || defined LISP_FEATURE_ARM64
static inline int
get_pseudo_atomic_atomic(struct thread *thread)
{

2
tools-for-build/ldso-stubs.lisp
View file

@ -63,7 +63,7 @@ ldso_stub__~A: ; \\
#endif
#include \"sbcl.h\""
#!+arm "
#!+ (or arm arm64) "
#define LDSO_STUBIFY(fct) \\
.align ; \\
.global ldso_stub__ ## fct ; \\