Raymond Toy pushed to branch arm64-dev-1 at cmucl / cmucl Commits: 6a127772 by Raymond Toy at 2026-03-22T20:30:05-07:00 Add support for the system counter registers - - - - - ec11d793 by Raymond Toy at 2026-03-22T21:35:22-07:00 First cut at arm64 system.lisp based on sparc version [skip-ci] - - - - - 09a8de46 by Raymond Toy at 2026-03-22T21:40:18-07:00 Add emit-not-implemented [skip-ci] - - - - - d6a05caf by Raymond Toy at 2026-03-22T21:53:37-07:00 First cut at arm64 char.lisp based on sparc version [skip-ci] - - - - - 3 changed files: - + src/compiler/arm64/char.lisp - src/compiler/arm64/insts.lisp - + src/compiler/arm64/system.lisp Changes: ===================================== src/compiler/arm64/char.lisp ===================================== @@ -0,0 +1,180 @@ +;;; -*- Package: ARM64 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/compiler/arm64/char.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the ARM64 VM definition of character operations. +;;; +;;; Written by Raymond Toy. +;;; Derived from the SPARC port by William Lott. +;;; +(in-package "ARM64") +(intl:textdomain "cmucl-arm64-vm") + + + +;;;; Moves and coercions: + +;;; Move a tagged char to an untagged representation. +;;; +(define-vop (move-to-base-char) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (base-char-reg))) + (:note _N"character untagging") + (:generator 1 + (emit-not-implemented))) +;;; +(define-move-vop move-to-base-char :move + (any-reg descriptor-reg) (base-char-reg)) + + +;;; Move an untagged char to a tagged representation. +;;; +(define-vop (move-from-base-char) + (:args (x :scs (base-char-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:note _N"character tagging") + (:generator 1 + (emit-not-implemented))) +;;; +(define-move-vop move-from-base-char :move + (base-char-reg) (any-reg descriptor-reg)) + +;;; Move untagged base-char values. +;;; +(define-vop (base-char-move) + (:args (x :target y + :scs (base-char-reg) + :load-if (not (location= x y)))) + (:results (y :scs (base-char-reg) + :load-if (not (location= x y)))) + (:note _N"character move") + (:effects) + (:affected) + (:generator 0 + (emit-not-implemented))) +;;; +(define-move-vop base-char-move :move + (base-char-reg) (base-char-reg)) + + +;;; Move untagged base-char arguments/return-values. +;;; +(define-vop (move-base-char-argument) + (:args (x :target y + :scs (base-char-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y base-char-reg)))) + (:results (y)) + (:temporary (:sc non-descriptor-reg) temp) + (:note _N"character arg move") + (:generator 0 + (emit-not-implemented))) +;;; +(define-move-vop move-base-char-argument :move-argument + (any-reg base-char-reg) (base-char-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char +;;; to a descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (base-char-reg) (any-reg descriptor-reg)) + + + +;;;; Other operations: + +(define-vop (char-code) + (:translate char-code) + (:policy :fast-safe) + (:args (ch :scs (base-char-reg) :target res)) + (:arg-types base-char) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:generator 1 + (emit-not-implemented))) + +(define-vop (code-char) + (:translate code-char) + (:policy :fast-safe) + (:args (code :scs (any-reg) :target res)) + (:arg-types positive-fixnum) + (:results (res :scs (base-char-reg))) + (:result-types base-char) + (:generator 1 + (emit-not-implemented))) + + +;;; Comparison of base-chars. +;;; +;;; ARM64 branch conditions for unsigned character ordering: +;;; :lo = unsigned less-than (SPARC :ltu) +;;; :hs = unsigned >= (SPARC :geu) +;;; :hi = unsigned greater-than (SPARC :gtu) +;;; :ls = unsigned <= (SPARC :leu) +;;; :eq = equal +;;; :ne = not equal +;;; +;;; Characters are always non-negative integers so unsigned conditions +;;; are correct and consistent with the SPARC port. +;;; +(define-vop (base-char-compare) + (:args (x :scs (base-char-reg)) + (y :scs (base-char-reg))) + (:arg-types base-char base-char) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note _N"inline comparison") + (:variant-vars condition not-condition) + (:generator 3 + (emit-not-implemented))) + +(define-vop (fast-char=/base-char base-char-compare) + (:translate char=) + (:variant :eq :ne)) + +(define-vop (fast-char</base-char base-char-compare) + (:translate char<) + (:variant :lo :hs)) + +(define-vop (fast-char>/base-char base-char-compare) + (:translate char>) + (:variant :hi :ls)) + +;;; Comparison against a compile-time constant character. +;;; +;;; ARM64 CMP accepts only a 12-bit unsigned immediate (0-4095), but +;;; char-code-limit is 65536. MOVZ handles a full 16-bit unsigned +;;; immediate, covering the entire valid char-code range in one instruction. +;;; +(define-vop (base-char-compare-c) + (:args (x :scs (base-char-reg))) + (:arg-types base-char (:constant base-char)) + (:conditional) + (:info target not-p y) + (:policy :fast-safe) + (:note _N"inline comparison") + (:temporary (:scs (non-descriptor-reg)) temp) + (:variant-vars condition not-condition) + (:generator 2 + (emit-not-implemented))) + +(define-vop (fast-char=-c/base-char base-char-compare-c) + (:translate char=) + (:variant :eq :ne)) + +(define-vop (fast-char<-c/base-char base-char-compare-c) + (:translate char<) + (:variant :lo :hs)) + +(define-vop (fast-char>-c/base-char base-char-compare-c) + (:translate char>) + (:variant :hi :ls)) ===================================== src/compiler/arm64/insts.lisp ===================================== @@ -615,11 +615,15 @@ ;;; These all share op1[31:22] = 1101010100. (defconstant +sysreg-keyword-map+ - '((:fpcr . #b1101101000100000) ; op0=3 op1=3 CRn=4 CRm=4 op2=0 - (:fpsr . #b1101101000100001) ; op0=3 op1=3 CRn=4 CRm=4 op2=1 - (:nzcv . #b1101101000010000) ; op0=3 op1=3 CRn=4 CRm=2 op2=0 - (:tpidr-el0 . #b1101111010000010) ; op0=3 op1=3 CRn=13 CRm=0 op2=2 - (:ctr-el0 . #b1100000000000001))) ; op0=3 op1=0 CRn=0 CRm=0 op2=1 + '((:fpcr . #b1101101000100000) ; op0=3 op1=3 CRn=4 CRm=4 op2=0 FP control + (:fpsr . #b1101101000100001) ; op0=3 op1=3 CRn=4 CRm=4 op2=1 FP status + (:nzcv . #b1101101000010000) ; op0=3 op1=3 CRn=4 CRm=2 op2=0 condition flags + (:tpidr-el0 . #b1101111010000010) ; op0=3 op1=3 CRn=13 CRm=0 op2=2 thread pointer + (:ctr-el0 . #b1100000000000001) ; op0=3 op1=0 CRn=0 CRm=0 op2=1 cache type + ;; System counter registers (read-only from EL0 when CNTKCTL_EL1 permits) + (:cntfrq-el0 . #b1101111100000000) ; op0=3 op1=3 CRn=14 CRm=0 op2=0 counter frequency (Hz) + (:cntvct-el0 . #b1101111100000010) ; op0=3 op1=3 CRn=14 CRm=0 op2=2 virtual counter value + (:cntvctss-el0 . #b1101111100000110))) (defun encode-sysreg (sysreg) "Return the 16-bit op0:op1f:CRn:CRm:op2 encoding for SYSREG. ===================================== src/compiler/arm64/system.lisp ===================================== @@ -0,0 +1,360 @@ +;;; -*- Package: ARM64 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/compiler/arm64/system.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; ARM64 VM definitions of various system hacking operations. +;;; +;;; Written by Rob MacLachlan +;;; +;;; SPARC conversion by William Lott and Christopher Hoover. +;;; ARM64 conversion derived from the SPARC port. +;;; +(in-package "ARM64") +(intl:textdomain "cmucl-arm64-vm") + + +;;;; Type frobbing VOPs + +(define-vop (get-lowtag) + (:translate get-lowtag) + (:policy :fast-safe) + (:args (object :scs (any-reg descriptor-reg))) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + (emit-not-implemented) + (inst and result object vm:lowtag-mask))) + +(define-vop (get-type) + (:translate get-type) + (: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 + (emit-not-implemented) + ;; Grab the lowtag. + (inst and result object lowtag-mask) + ;; Check for various pointer types. + (inst cmp result list-pointer-type) + (inst b :eq done) + (inst cmp result other-pointer-type) + (inst b :eq other-pointer) + (inst cmp result function-pointer-type) + (inst b :eq function-pointer) + (inst cmp result instance-pointer-type) + (inst b :eq done) + ;; Okay, it is an immediate. If fixnum, we want zero. Otherwise, + ;; we want the low 8 bits. + ;; + ;; AArch64: TST sets flags without writing a result (ANDS Xd=XZR). + ;; No delay slot exists on ARM64, so the fixnum zero materialisation + ;; must be done explicitly before the branch. + (inst tst object vm:fixnum-tag-mask) + (inst movz result 0) ; pre-load zero; harmless if not taken + (inst b :eq done) + ;; Not a fixnum: fetch the low 8 type bits. + (inst and result object type-mask) + (inst b done) + + FUNCTION-POINTER + (load-type result object (- function-pointer-type)) + (inst b done) + + OTHER-POINTER + (load-type result object (- other-pointer-type)) + + DONE)) + + +(define-vop (function-subtype) + (:translate function-subtype) + (:policy :fast-safe) + (:args (function :scs (descriptor-reg))) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (emit-not-implemented) + (load-type result function (- vm:function-pointer-type)))) + +(define-vop (set-function-subtype) + (:translate (setf function-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 + (emit-not-implemented) + ;; AArch64 is little-endian: the type byte is at byte offset 0 of + ;; the header word (i.e. the lowest-address byte), adjusted for the + ;; function-pointer tag. We use STURB (unscaled store byte). + (inst sturb type function (- vm:function-pointer-type)) + (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 + (emit-not-implemented) + (loadw res x 0 vm:other-pointer-type) + (inst lsr res res vm:type-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 + (emit-not-implemented) + (loadw res x 0 vm:function-pointer-type) + (inst lsr res res vm:type-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 zero))) + (:arg-types * positive-fixnum) + (:results (res :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) t1 t2) + (:generator 6 + (emit-not-implemented) + (loadw t1 x 0 vm:other-pointer-type) + (inst and t1 t1 vm:type-mask) + ;; Load DATA into t2 (untagging fixnums from any-reg/immediate, or + ;; zero from the zero SC), then shift into the header data field and + ;; add. Using ADD rather than ORR avoids the bitmask-immediate + ;; encoding restriction, and is safe here because t1 holds only the + ;; low type-bits with the data field already cleared. + (sc-case data + (any-reg + ;; DATA is a fixnum-tagged integer; remove the fixnum tag first. + (inst asr t2 data vm:fixnum-tag-bits)) + (immediate + (inst li t2 (tn-value data))) + (zero + (inst li t2 0))) + (inst add t1 t1 (shift t2 :lsl vm:type-bits)) + (storew t1 x 0 vm:other-pointer-type) + (move res x))) + + +(define-vop (make-fixnum) + (:args (ptr :scs (any-reg descriptor-reg))) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (emit-not-implemented) + ;; + ;; Some code (the hash table code) depends on this returning a + ;; positive number so make sure it does. + ;; + ;; LSL by lowtag-bits then LSR by 1 gives a net left shift of + ;; (lowtag-bits - 1), converting a tagged pointer into a positive + ;; fixnum value. AND with a mask cannot replicate this because the + ;; two low fixnum-tag bits must also be cleared -- BIC/AND would + ;; only clear the lowtag bits, leaving bits that should be zero. + (inst lsl res ptr vm:lowtag-bits) + (inst lsr res res 1))) + +(define-vop (make-other-immediate-type) + (:args (val :scs (any-reg descriptor-reg)) + (type :scs (any-reg descriptor-reg immediate) + :target temp)) + (:results (res :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 2 + (emit-not-implemented) + (sc-case type + (immediate + (inst lsl temp val vm:type-bits) + (inst orr res temp (tn-value type))) + (t + ;; TYPE is a fixnum-tagged integer; un-tag it with ASR, then + ;; shift VAL up and OR the pieces together. + (inst asr temp type vm:fixnum-tag-bits) + (inst lsl res val (- vm:type-bits vm:fixnum-tag-bits)) + (inst orr res res temp))))) + + +;;;; 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 + (emit-not-implemented) + (move int alloc-tn))) + +(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 + (emit-not-implemented) + (move int bsp-tn))) + +(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 + (emit-not-implemented) + (move int csp-tn))) + + +;;;; 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 + (emit-not-implemented) + ;; Read the header word, extract the word count (top bits above + ;; type-bits), scale to bytes, then subtract the other-pointer tag + ;; to get the byte displacement from CODE to the first instruction. + (loadw ndescr code 0 vm:other-pointer-type) + ;; Extract the word count and scale to bytes in one shift: + ;; LSR by (type-bits - word-shift) = LSR by 5. + (inst lsr ndescr ndescr (- vm:type-bits vm:word-shift)) + (inst sub ndescr ndescr vm:other-pointer-type) + (inst add sap code ndescr))) + +(define-vop (compute-function) + (: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 + (emit-not-implemented) + ;; Compute the byte offset from CODE to the start of the code vector, + ;; add the caller-supplied byte OFFSET, adjust for the tag difference + ;; between other-pointer and function-pointer, then add to CODE. + (loadw ndescr code 0 vm:other-pointer-type) + ;; Extract the word count and scale to bytes in one shift: + ;; LSR by (type-bits - word-shift) = LSR by 5. + (inst lsr ndescr ndescr (- vm:type-bits vm:word-shift)) + (inst add ndescr ndescr offset) + (inst sub ndescr ndescr (- vm:other-pointer-type vm:function-pointer-type)) + (inst add func code ndescr))) + + +;;;; Other random VOPs. + +(defknown unix::do-pending-interrupt () (values)) +(define-vop (unix::do-pending-interrupt) + (:policy :fast-safe) + (:translate unix::do-pending-interrupt) + (:generator 1 + (emit-not-implemented) + ;; AArch64 uses UDF (permanently-undefined instruction) as the trap + ;; mechanism; the signal handler decodes the immediate from the + ;; instruction word. This replaces SPARC's UNIMP instruction. + (inst udf pending-interrupt-trap))) + + +(define-vop (halt) + (:generator 1 + (emit-not-implemented) + (inst udf halt-trap))) + + +;;;; Dynamic vop count collection support + +(define-vop (count-me) + (:args (count-vector :scs (descriptor-reg))) + (:info index) + (:temporary (:scs (non-descriptor-reg)) count) + (:generator 1 + (emit-not-implemented) + ;; Compute the byte offset of element INDEX in the vector's data + ;; area, accounting for the other-pointer tag. + (let ((offset + (- (* (+ index vector-data-offset) word-bytes) other-pointer-type))) + ;; On AArch64 the unscaled (LDUR/STUR) immediate is a signed 9-bit + ;; value (-256..255). For larger offsets the loadw/storew macros + ;; will use a register-offset form when given a TEMP argument; here + ;; we simply assert the offset fits, matching the SPARC port's + ;; (signed-byte 13) check for its own immediate range. + (assert (typep offset '(signed-byte 9))) + (inst ldur count count-vector offset) + (inst add count count 1) + (inst stur count count-vector offset)))) + + +;;;; Cycle counter support. +;;; +;;; AArch64 exposes a 64-bit virtual counter via the CNTVCT_EL0 system +;;; register (accessible from EL0 when CNTKCTL_EL1.EL0VCTEN = 1, which +;;; is normally set by the OS). This replaces the SPARC RDTICK +;;; instruction and provides a similar monotonically-increasing cycle / +;;; time-base counter. +;;; +;;; The counter is a single 64-bit value; we split it into two 32-bit +;;; halves (low, high) to match the SPARC port's two-value interface and +;;; keep WITH-CYCLE-COUNTER source-compatible. + +(defknown read-cycle-counter () + (values (unsigned-byte 32) (unsigned-byte 32))) + +(define-vop (read-cycle-counter) + (:translate read-cycle-counter) + (:args) + (:policy :fast-safe) + (:results (lo :scs (unsigned-reg)) + (hi :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg) tick) + (:generator 3 + (emit-not-implemented) + ;; Read the virtual count register into a 64-bit temp. + (inst mrs tick :cntvct-el0) + ;; High 32 bits. + (inst lsr hi tick 32) + ;; Low 32 bits: zero-extend by masking the upper half. + (inst and lo tick #xffffffff))) + +(defun read-cycle-counter () + "Read the virtual instruction cycle counter available on AArch64. +The 64-bit counter is returned as two 32-bit unsigned integers. +The low 32-bit result is the first value." + (read-cycle-counter)) + +(defmacro with-cycle-counter (&body body) + "Returns the primary value of BODY as the primary value, and the + number of CPU cycles elapsed as secondary value." + (let ((hi0 (gensym)) + (hi1 (gensym)) + (lo0 (gensym)) + (lo1 (gensym))) + `(multiple-value-bind (,lo0 ,hi0) + (read-cycle-counter) + (values (locally ,@body) + (multiple-value-bind (,lo1 ,hi1) + (read-cycle-counter) + ;; Can't do anything about the notes about generic + ;; arithmetic, so silence the notes. + (declare (optimize (inhibit-warnings 3))) + (+ (ash (- ,hi1 ,hi0) 32) + (- ,lo1 ,lo0))))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/92e157c653e57be9f83aa0c... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/92e157c653e57be9f83aa0c... You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help