- cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][arm64-dev-1] Cross-compile from x86 to arm64
by Raymond Toy (＠rtoy) 23 Mar '26

23 Mar '26

Raymond Toy pushed to branch arm64-dev-1 at cmucl / cmucl Commits: d5a9de2e by Raymond Toy at 2026-03-23T12:01:18-07:00 Cross-compile from x86 to arm64 First cut. Basically the same as the arm version with a few obvious minor changes. [skip-ci] - - - - - 1 changed file: - + src/tools/cross-scripts/cross-x86-arm64.lisp Changes: ===================================== src/tools/cross-scripts/cross-x86-arm64.lisp ===================================== @@ -0,0 +1,280 @@ +;;; Cross-compile script to build an ARM core using x86 as the +;;; compiling system. This is based on the x86 to sparc script. +;;; +;;; This needs work! + +(in-package :cl-user) + +;;; Rename the X86 package and backend so that new-backend does the +;;; right thing. +(rename-package "X86" "OLD-X86" '("OLD-VM")) +(setf (c:backend-name c:*native-backend*) "OLD-X86") + +(c::new-backend "ARM64" + ;; Features to add here + '(:arm64 + :relative-package-names ; Relative package names from Allegro + :conservative-float-type + :hash-new + :random-xoroshiro + :modular-arith ; Modular arithmetic + :double-double ; Double-double float support + :unicode + + :linux + :glibc2 + :unix + ) + ;; Features to remove from current *features* here + '( + ;; Other architectures we aren't using. Particularly important + ;; to get rid of sse2 and x87 so we don't accidentally try to + ;; compile the x87/sse2 float support on sparc, which won't work. + :x86 :x86-bootstrap :sse2 :x87 :i486 + :alpha :osf1 :mips + ;; Really old stuff that should have been removed long ago. + :propagate-fun-type :propagate-float-type :constrain-float-type + :pentium :long-float :new-random + + ;; Other OSes we're not using + :openbsd :freebsd :mach-o :darwin :bsd + + ;; We're not building a small core + :small + + ;; Other features not yet supported by the ARM port. + :mp + :gencgc + :heap-overflow-check + :stack-checking + + ;; Not implemented yet + :complex-fp-vops + :alien-callback + :linkage-table + :random-mt19937 + )) + +;; Temporarily use large values so that error messages in the logs +;; contain more information so we don't have to run the cross-compile +;; interactively to get all of the info out. +(setf *print-length* 64 + *print-level* 64 + debug:*debug-print-length* 64 + debug:*debug-print-level* 64 + ext:*describe-print-length* 64 + ext:*describe-print-level* 64 + ext:*error-print-length* 64 + ext:*error-print-level* 64) + + +;;; Changes needed to bootstrap cross-compiling from x86 to arm + +;; Set up the linkage space stuff appropriately for arm. +(setf (c::backend-foreign-linkage-space-start c::*target-backend*) + #x0f000000 + (c::backend-foreign-linkage-entry-size c::*target-backend*) + ;; FIXME! + 16) + +;; Get new fops so we can process fasls with big-endian unicode +;; strings on our little-endian compiling system. +;;#+unicode +;;(load "target:tools/cross-scripts/cross-unicode-big-endian.lisp") + +;;; End changes needed to bootstrap cross-compiling from x86 to arm + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + ;;(format t "extern-alien-name: ~S~%" name) + ;;(lisp::maybe-swap-string 'extern-alien-name (copy-seq name)) + name) +(defconstant c::arm-fasl-file-implementation 13) + + +;; FIXME: Enable this with the correct code when we have more of the +;; ARM kernel running. +(defun fixup-code-object (code offset fixup kind) + (declare (type index offset)) + (error "fixup-code-object not implemented")) +(export 'fixup-code-object) + +;; FIXME: implement this correctly +(defun sanctify-for-execution (component) + (error "sanctify-for-execution ~S" component) + nil) +(export 'sanctify-for-execution) + +;; Export all external X86 symbols. This wasn't required before, but I +;; (rtoy) think this happened when the compiler magic for EXPORT was +;; removed to make EXPORT a regular function without compiler magic. +(do-external-symbols (s "OLD-X86") + (export (intern (symbol-name s) "VM") "VM")) + +;;; Compile the new backend. +(pushnew :bootstrap *features*) +(pushnew :building-cross-compiler *features*) +(load "target:tools/comcom") + +;;; Load the new backend. +(setf (search-list "c:") + '("target:compiler/")) +(setf (search-list "vm:") + '("c:arm64/" "c:generic/")) +(setf (search-list "assem:") + '("target:assembly/" "target:assembly/arm64/")) + +;; Load the backend of the compiler. + +(in-package "C") + +(load "vm:vm-macs") +(load "vm:parms") +(load "vm:objdef") +(load "vm:interr") +(load "assem:support") + +(load "target:compiler/srctran") +(load "vm:vm-typetran") +(load "target:compiler/float-tran") +(load "target:compiler/saptran") + +(load "vm:macros") +(load "vm:utils") + +(load "vm:vm") +(load "vm:insts") +(load "vm:primtype") +(load "vm:move") +(load "vm:sap") +(load "vm:system") +(load "vm:char") +(load "vm:float") + +(load "vm:memory") +(load "vm:static-fn") +(load "vm:arith") +(load "vm:cell") +(load "vm:subprim") +(load "vm:debug") +(load "vm:c-call") +(load "vm:print") +(load "vm:alloc") +(load "vm:call") +(load "vm:nlx") +(load "vm:values") +(load "vm:array") +(load "vm:pred") +(load "vm:type-vops") + +(load "assem:assem-rtns") + +(load "assem:array") +(load "assem:arith") +(load "assem:alloc") + +(load "c:pseudo-vops") + +(check-move-function-consistency) + +(load "vm:new-genesis") + +;;; OK, the cross compiler backend is loaded. + +(setf *features* (remove :building-cross-compiler *features*)) + +;;; Info environment hacks. +(macrolet ((frob (&rest syms) + `(progn ,@(mapcar #'(lambda (sym) + `(defconstant ,sym + (symbol-value + (find-symbol ,(symbol-name sym) + :vm)))) + syms)))) + (frob OLD-VM:BYTE-BITS + OLD-VM:WORD-BITS + OLD-VM::WORD-BYTES + OLD-VM:CHAR-BITS + OLD-VM:CHAR-BYTES + OLD-VM:LOWTAG-BITS + #+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE + #+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE + OLD-VM:SIMPLE-BIT-VECTOR-TYPE + OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE + OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET + OLD-VM:DOUBLE-FLOAT-DIGITS + old-vm:single-float-digits + OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE + OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE + OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE + OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE + ) + #+double-double + (frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE) + ) + +(let ((function (symbol-function 'kernel:error-number-or-lose))) + (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) + (setf (symbol-function 'kernel:error-number-or-lose) function) + (setf (info function kind 'kernel:error-number-or-lose) :function) + (setf (info function where-from 'kernel:error-number-or-lose) :defined))) + +(defun fix-class (name) + (let* ((new-value (find-class name)) + (new-layout (kernel::%class-layout new-value)) + (new-cell (kernel::find-class-cell name)) + (*info-environment* (c:backend-info-environment c:*target-backend*))) + (remhash name kernel::*forward-referenced-layouts*) + (kernel::%note-type-defined name) + (setf (info type kind name) :instance) + (setf (info type class name) new-cell) + (setf (info type compiler-layout name) new-layout) + new-value)) +(fix-class 'c::vop-parse) +(fix-class 'c::operand-parse) + +#+random-mt19937 +(declaim (notinline kernel:random-chunk)) + +(setf c:*backend* c:*target-backend*) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + name) +(export 'extern-alien-name) + + +(in-package :cl-user) + +;;; Don't load compiler parts from the target compilation + +(defparameter *load-stuff* nil) + +;; hack, hack, hack: Make old-x86::any-reg the same as +;; x86::any-reg as an SC. Do this by adding old-x86::any-reg +;; to the hash table with the same value as x86::any-reg. + +(let ((ht (c::backend-sc-names c::*target-backend*))) + (setf (gethash 'old-vm::any-reg ht) + (gethash 'vm::any-reg ht))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d5a9de2e93bcb559fa592b2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d5a9de2e93bcb559fa592b2… 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

1 0

[Git][cmucl/cmucl][arm64-dev-1] 3 commits: First cut at arm64 subprim.lisp
by Raymond Toy (＠rtoy) 23 Mar '26

23 Mar '26

Raymond Toy pushed to branch arm64-dev-1 at cmucl / cmucl Commits: f4345a37 by Raymond Toy at 2026-03-23T10:17:34-07:00 First cut at arm64 subprim.lisp Basically the sparc version but updated for arm64. Compiles, but no other testing, obviously. [skip-ci] - - - - - d5343317 by Raymond Toy at 2026-03-23T10:35:39-07:00 Rudimentary arm64_linux config Need this so we can create cross-compile targets using arm64_linux as the config. Untested. [skip-ci] - - - - - d0734459 by Raymond Toy at 2026-03-23T10:36:40-07:00 Update for arm64 for symbol stuff. Just do what we already do for sparc, but also do the amd64 stuff. Mostly untested, but we do need symbol-hash as a known function. [skip-ci] - - - - - 3 changed files: - + src/compiler/arm64/subprim.lisp - src/compiler/generic/objdef.lisp - + src/lisp/Config.arm64_linux Changes: ===================================== src/compiler/arm64/subprim.lisp ===================================== @@ -0,0 +1,62 @@ +;;; -*- 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/subprim.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; Linkage information for standard static functions, and random vops. +;;; +;;; Written by William Lott. +;;; ARM64 port derived from the SPARC implementation. +;;; +(in-package "ARM64") + + + + +;;;; Length + +(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 + (emit-not-implemented) + (let ((done (gen-label)) + (loop (gen-label)) + (not-list (generate-cerror-code vop object-not-list-error object))) + (move ptr object) + (move count zero-tn) + + (emit-label loop) + + ;; Unlike SPARC, ARM64 has no branch delay slots; no NOP needed. + (inst cmp ptr null-tn) + (inst b :eq done) + + (test-type ptr temp not-list t vm:list-pointer-type) + + (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type) + (inst add count count (fixnumize 1)) + (test-type ptr temp loop nil vm:list-pointer-type) + + (cerror-call vop done object-not-list-error ptr) + + (emit-label done) + (move result count)))) + + +(define-static-function length (object) :translate length) ===================================== src/compiler/generic/objdef.lisp ===================================== @@ -478,15 +478,15 @@ ;;;; Symbols -#+(or gengc sparc x86 amd64 ppc) +#+(or gengc sparc x86 amd64 ppc arm64) (defknown %make-symbol (fixnum simple-string) symbol (flushable movable)) -#+(or gengc sparc x86 amd64 ppc) +#+(or gengc sparc x86 amd64 ppc arm64) (defknown symbol-hash (symbol) fixnum (flushable movable)) -#+(or gencgc sparc x86 amd64 ppc) +#+(or gencgc sparc x86 amd64 ppc arm64) (defknown %set-symbol-hash (symbol index) t (unsafe)) @@ -500,12 +500,12 @@ (define-primitive-object (symbol :lowtag other-pointer-type :header symbol-header-type :alloc-trans - #-(or gengc x86 amd64 sparc ppc) make-symbol - #+(or gengc x86 amd64 sparc ppc) %make-symbol) + #-(or gengc x86 amd64 sparc ppc arm64) make-symbol + #+(or gengc x86 amd64 sparc ppc arm64) %make-symbol) (value :set-trans %set-symbol-value :init :unbound) - #-(or gengc x86 amd64 sparc ppc) unused - #+(or gengc x86 amd64 sparc ppc) + #-(or gengc x86 amd64 sparc ppc arm64) unused + #+(or gengc x86 amd64 sparc ppc arm64) (hash :init :arg) (plist :ref-trans symbol-plist :set-trans %set-symbol-plist @@ -518,7 +518,7 @@ ;; We couldn't use the nil/symbol trick in 32-bit, because the difference ;; between the low tags of nil and symbol is 4 but the word-size is 8. This is ;; a slow workaround. -#+amd64 +#+(and amd64 arm64) (deftransform symbol-name ((symbol) (*)) '(if (eq symbol nil) "NIL" ===================================== src/lisp/Config.arm64_linux ===================================== @@ -0,0 +1,40 @@ +# -*- Mode: makefile -*- + +PATH1 = ../../src/lisp +vpath %.h $(PATH1) +vpath %.c $(PATH1) +vpath %.S $(PATH1) + +CMULOCALE = ../../src/i18n/locale +vpath %.pot $(CMULOCALE) +vpath %.po $(CMULOCALE) +vpath %.mo $(CMULOCALE) + +GC_SRC := gc.c + +CPPFLAGS := -DUNICODE -iquote . -iquote $(PATH1) +CFLAGS += -marm -Wstrict-prototypes -Wall -O0 -ggdb3 -fno-omit-frame-pointer -ffp-contract=off +ASFLAGS = -g + +ARCH_SRC = arm-arch.c + +NM = $(PATH1)/linux-nm +DEPEND_FLAGS = -MM + +ASSEM_SRC = arm64-assem.S undefineds-assem.S +OS_SRC += Linux-os.c os-common.c elf.c +OS_LIBS = -ldl -lutil +OS_LINK_FLAGS = -marm -rdynamic -Wl,-Map,foo -Wl,-z,noexecstack + +EXEC_FINAL_OBJ = exec-final.o + +# Convert undefineds.h to a set of stubs. Preprocess undefineds.h, +# remove preprocessor junk and take each symbol and make a stub out of +# it. +# +# TODO: Modify undefineds.h and get rid of the F(foo) and D(foo) stuff. +undefineds-assem.S: undefineds.h + $(CPP) '-DF(x)=x' '-DD(x)' $< | \ + sed -e '/^#/d' -e '/^ *$$/d' -e 's/,$$//' | \ + sort | \ + awk 'BEGIN { print "\t.text\n" } { printf "\t.align 2\n\t.global stub_%s\nstub_%s:\n\tb %s\n\n", $$1, $$1, $$1 }' > $@ View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/2668dee30d0ee65b80e277… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/2668dee30d0ee65b80e277… 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

1 0

[Git][cmucl/cmucl][arm64-dev-1] First cut at arm64 cell.lisp
by Raymond Toy (＠rtoy) 23 Mar '26

23 Mar '26

Raymond Toy pushed to branch arm64-dev-1 at cmucl / cmucl Commits: 2668dee3 by Raymond Toy at 2026-03-23T10:05:43-07:00 First cut at arm64 cell.lisp Basically the sparc version but updated for arm64. Compiles, but no other testing, obviously. [skip-ci] - - - - - 1 changed file: - + src/compiler/arm64/cell.lisp Changes: ===================================== src/compiler/arm64/cell.lisp ===================================== @@ -0,0 +1,352 @@ +;;; -*- 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/cell.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of various primitive memory access +;;; VOPs for ARM64. +;;; +;;; Originally written for SPARC by Rob MacLachlan, converted by William Lott. +;;; Ported to ARM64. +;;; + +(in-package "ARM64") +(intl:textdomain "cmucl-arm64-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 + (emit-not-implemented) + (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 + (emit-not-implemented) + (storew value object offset lowtag))) + + + +;;;; Symbol hacking VOPs: + +;;; The compiler likes to be able to directly SET symbols. +;;; +(define-vop (set cell-set) + (:variant symbol-value-slot other-pointer-type)) + +;;; 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 + (emit-not-implemented) + (move obj-temp object) + (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type) + (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) + ;; inst cmp: alias for SUBS with Rd=XZR. + ;; Defined in checkpoint as (define-instruction-macro cmp (rn src) `(inst subs null-tn ,rn ,src)) + (inst cmp value vm:unbound-marker-type) + ;; inst b :eq label: conditional branch B.cond. + ;; Defined in checkpoint as (define-instruction b (segment cond-or-target &optional target)) + (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 + (emit-not-implemented) + (loadw value object vm:symbol-value-slot vm:other-pointer-type) + ;; inst cmp: SUBS XZR, value, unbound-marker-type + (inst cmp value vm:unbound-marker-type) + ;; inst b :eq/:ne target: B.cond conditional branch + (inst b (if not-p :eq :ne) target))) + +(define-vop (fast-symbol-value cell-ref) + (:variant vm:symbol-value-slot vm:other-pointer-type) + (:policy :fast) + (:translate symbol-value)) + +(define-vop (symbol-hash) + (:policy :fast-safe) + (:translate symbol-hash) + (:args (symbol :scs (descriptor-reg null))) + (:results (res :scs (any-reg))) + (:result-types tagged-num) + (:generator 2 + (emit-not-implemented) + ;; The symbol-hash slot of NIL holds NIL because it is also the cdr + ;; slot, so we strip the two low tag bits to ensure it is a fixnum. + (loadw res symbol symbol-hash-slot other-pointer-type) + ;; inst bic has NO immediate form (invertp=t excludes integer src types in checkpoint). + ;; Use inst and with the bitwise complement instead: + ;; AND res, res, (lognot fixnum-tag-mask) -- keeps all bits except the tag bits. + (inst and res res (lognot vm:fixnum-tag-mask)))) + +(define-vop (%set-symbol-hash cell-set) + (:translate %set-symbol-hash) + (:variant symbol-hash-slot other-pointer-type)) + + +;;;; Fdefinition (fdefn) objects. + +(define-vop (fdefn-function cell-ref) + (:variant fdefn-function-slot other-pointer-type)) + +(define-vop (safe-fdefn-function) + (: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 + (emit-not-implemented) + (move obj-temp object) + (loadw value obj-temp fdefn-function-slot other-pointer-type) + (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) + ;; inst cmp: SUBS XZR, value, null-tn + (inst cmp value null-tn) + ;; inst b :eq err-lab: B.EQ conditional branch + (inst b :eq err-lab)))) + +(define-vop (set-fdefn-function) + (:policy :fast-safe) + (:translate (setf fdefn-function)) + (:args (function :scs (descriptor-reg) :target result) + (fdefn :scs (descriptor-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) type) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (emit-not-implemented) + (let ((normal-fn (gen-label))) + ;; load-type: defined in arm64-macros as (inst ldurb target source offset). + ;; Reads the low type byte of the object header word. + (load-type type function (- function-pointer-type)) + ;; inst cmp: SUBS XZR, type, function-header-type + (inst cmp type function-header-type) + ;; inst mov: macro expanding to (inst orr rd null-tn src). + ;; Move function -> temp unconditionally before the branch (no delay slot on ARM64). + (inst mov temp function) + ;; inst b :eq normal-fn: skip closure-tramp load if already a plain function + (inst b :eq normal-fn) + ;; inst li: materialise an assembly-routine address into a register. + ;; Used throughout arm64-macros for loading fixup/immediate values. + (inst li temp (make-fixup 'closure-tramp :assembly-routine)) + (emit-label normal-fn) + (storew function fdefn fdefn-function-slot other-pointer-type) + (storew temp fdefn fdefn-raw-addr-slot other-pointer-type) + ;; inst mov: ORR result, XZR, function + (inst mov 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) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (emit-not-implemented) + (storew null-tn fdefn fdefn-function-slot other-pointer-type) + ;; inst li: load assembly-routine address (arm64-macros pattern) + (inst li temp (make-fixup 'undefined-tramp :assembly-routine)) + (storew temp fdefn fdefn-raw-addr-slot other-pointer-type) + ;; inst mov: ORR result, XZR, fdefn + (inst mov 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)) temp) + (:generator 5 + (emit-not-implemented) + (loadw temp symbol vm:symbol-value-slot vm:other-pointer-type) + ;; inst add: ADD bsp-tn, bsp-tn, #imm. + ;; Defined in checkpoint as (def add 1 0 0 nil t). + (inst add bsp-tn bsp-tn (* 2 vm:word-bytes)) + (storew temp bsp-tn (- vm:binding-value-slot vm:binding-size)) + (storew symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + (storew val symbol vm:symbol-value-slot vm:other-pointer-type))) + + +(define-vop (unbind) + (:temporary (:scs (descriptor-reg)) symbol value) + (:generator 0 + (emit-not-implemented) + (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size)) + (storew value symbol vm:symbol-value-slot vm:other-pointer-type) + ;; zero-tn: ARM64 XZR alias used throughout the backend + (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + ;; inst sub: SUB bsp-tn, bsp-tn, #imm. + ;; Defined in checkpoint as (def sub 1 1 0 neg t). + (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes)))) + + +(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) + (:generator 0 + (emit-not-implemented) + (let ((loop (gen-label)) + (skip (gen-label)) + (done (gen-label))) + (move where arg) + ;; inst cmp: SUBS XZR, where, bsp-tn + (inst cmp where bsp-tn) + ;; inst b :eq done: skip loop body entirely if already at target + (inst b :eq done) + + (emit-label loop) + (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + ;; inst cbz symbol skip: Compare and Branch if Zero. + ;; Defined in checkpoint as format-compare-branch with op=0 (CBZ). + ;; Replaces the SPARC (inst cmp symbol) + (inst b :eq skip) pair. + (inst cbz symbol skip) + (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size)) + (storew value symbol vm:symbol-value-slot vm:other-pointer-type) + (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + + (emit-label skip) + ;; inst sub: SUB bsp-tn, bsp-tn, #imm + (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes)) + ;; inst cmp + inst b :ne loop: loop until where == bsp-tn + (inst cmp where bsp-tn) + (inst b :ne loop) + + (emit-label done)))) + + + +;;;; Closure indexing. + +(define-vop (closure-index-ref word64-index-ref) + (:variant vm:closure-info-offset vm:function-pointer-type) + (:translate %closure-index-ref)) + +(define-vop (funcallable-instance-info word64-index-ref) + (:variant funcallable-instance-info-offset vm:function-pointer-type) + (:translate %funcallable-instance-info)) + +(define-vop (set-funcallable-instance-info word64-index-set) + (:variant funcallable-instance-info-offset function-pointer-type) + (:translate %set-funcallable-instance-info)) + +(define-vop (funcallable-instance-lexenv cell-ref) + (:variant funcallable-instance-lexenv-slot function-pointer-type)) + + +(define-vop (closure-ref slot-ref) + (:variant closure-info-offset function-pointer-type)) + +(define-vop (closure-init slot-set) + (:variant closure-info-offset function-pointer-type)) + + +;;;; Value Cell hackery. + +(define-vop (value-cell-ref cell-ref) + (:variant value-cell-value-slot other-pointer-type)) + +(define-vop (value-cell-set cell-set) + (:variant value-cell-value-slot other-pointer-type)) + + + +;;;; 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 + (emit-not-implemented) + (loadw temp struct 0 instance-pointer-type) + ;; inst lsr: Logical Shift Right. + ;; Defined in checkpoint as (def lsr 1 63) with (segment rd rn shift). + ;; LSR rd, temp, vm:type-bits -- shifts header word right to extract length field. + (inst lsr res temp vm:type-bits))) + +(define-vop (instance-ref slot-ref) + (:variant instance-slots-offset instance-pointer-type) + (:policy :fast-safe) + (:translate %instance-ref) + (:arg-types instance (:constant index))) + +(define-vop (instance-set slot-set) + (:policy :fast-safe) + ;; This translation is disabled because %instance-set needs a return value + ;; and this VOP doesn't return anything. See SPARC notes for context. + ;;(:translate %instance-set) + (:variant instance-slots-offset instance-pointer-type) + (:arg-types instance (:constant index) *)) + +(define-vop (instance-index-ref word64-index-ref) + (:policy :fast-safe) + (:translate %instance-ref) + (:variant instance-slots-offset instance-pointer-type) + (:arg-types instance positive-fixnum)) + +(define-vop (instance-index-set word64-index-set) + (:policy :fast-safe) + (:translate %instance-set) + (:variant instance-slots-offset instance-pointer-type) + (:arg-types instance positive-fixnum *)) + + + +;;;; Code object frobbing. + +(define-vop (code-header-ref word64-index-ref) + (:translate code-header-ref) + (:policy :fast-safe) + (:variant 0 other-pointer-type)) + +(define-vop (code-header-set word64-index-set) + (:translate code-header-set) + (:policy :fast-safe) + (:variant 0 other-pointer-type)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2668dee30d0ee65b80e277f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2668dee30d0ee65b80e277f… 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

1 0

[Git][cmucl/cmucl][arm64-dev-1] 4 commits: Add support for the system counter registers
by Raymond Toy (＠rtoy) 23 Mar '26

23 Mar '26

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/92e157c653e57be9f83aa0… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/92e157c653e57be9f83aa0… 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

1 0

[Git][cmucl/cmucl][arm64-dev-1] First cut at arm64/macros.lisp
by Raymond Toy (＠rtoy) 22 Mar '26

22 Mar '26

Raymond Toy pushed to branch arm64-dev-1 at cmucl / cmucl Commits: 30f5293b by Raymond Toy at 2026-03-21T22:43:01-07:00 First cut at arm64/macros.lisp Modeled very much after the sparc implementation by just updating it to use arm64 instructions. This is basically untested, but it does allow arm64/move.lisp to be compiled, so at least some things work. [skip-ci] - - - - - 1 changed file: - + src/compiler/arm64/macros.lisp Changes: ===================================== src/compiler/arm64/macros.lisp ===================================== @@ -0,0 +1,582 @@ +;;; -*- 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/macros.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains various useful macros for generating ARM64 code. +;;; +;;; Written by [ARM64 port contributors]. +;;; Derived from the ARM and SPARC ports. +;;; + +(in-package "ARM64") +(intl:textdomain "cmucl-arm64-vm") + + +;;; Instruction-like macros. + +(defmacro move (dst src) + "Move SRC into DST unless they are location=." + (once-only ((n-dst dst) + (n-src src)) + `(unless (location= ,n-dst ,n-src) + (inst mov ,n-dst ,n-src)))) + +;; (loadw object base &optional (offset 0) (lowtag 0) temp) +;; (storew object base &optional (offset 0) (lowtag 0) temp) +;; +;; Load a word at a given address into the register OBJECT, or store +;; OBJECT at the given address. The address of the word is in register +;; BASE, plus an offset given by OFFSET, which is in words. LOWTAG is +;; an adjustment to OFFSET to account for any tag bits used in the BASE +;; descriptor register. +;; +;; On AArch64 we use LDUR/STUR which take an exact unscaled signed-byte 9 +;; byte offset (-256..255). When the offset does not fit, TEMP is loaded +;; with the full offset and the register-offset form of LDR/STR is used. +;; If TEMP is not supplied the offset is assumed to fit in a signed-byte 9. +(macrolet + ((def-load/store-word (op inst reg-inst shift) + `(defmacro ,op (object base &optional (offset 0) (lowtag 0) temp) + (if temp + (let ((offs (gensym))) + `(let ((,offs (- (ash ,offset ,',shift) ,lowtag))) + (if (typep ,offs '(signed-byte 9)) + (inst ,',inst ,object ,base ,offs) + (progn + (inst li ,temp ,offs) + (inst ,',reg-inst ,object (reg-offset ,base ,temp)))))) + `(inst ,',inst ,object ,base (- (ash ,offset ,',shift) ,lowtag)))))) + (def-load/store-word loadw ldur ldr word-shift) + (def-load/store-word storew stur str word-shift)) + +(defmacro load-symbol (reg symbol) + `(inst add ,reg null-tn (static-symbol-offset ,symbol))) + +(macrolet + ((frob (slot) + (let ((loader (intern (concatenate 'simple-string + "LOAD-SYMBOL-" + (string slot)))) + (storer (intern (concatenate 'simple-string + "STORE-SYMBOL-" + (string slot)))) + (offset (intern (concatenate 'simple-string + "SYMBOL-" + (string slot) + "-SLOT") + (find-package "VM")))) + `(progn + (defmacro ,loader (reg symbol) + `(inst ldur ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-type)))) + (defmacro ,storer (reg symbol) + `(inst stur ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-type)))))))) + (frob value) + (frob function)) + +(defmacro load-type (target source &optional (offset 0)) + "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)) + (ecase (backend-byte-order *target-backend*) + (:little-endian + `(inst ldurb ,n-target ,n-source ,n-offset)) + (:big-endian + `(inst ldurb ,n-target ,n-source (+ ,n-offset (1- word-bytes))))))) + +;;; Macros to handle the fact that we cannot use the machine native call and +;;; return instructions. +;;; +;;; On AArch64 there is no indirect-branch-through-register instruction that +;;; also sets the link register; instead we use BR (branch to register) for +;;; computed jumps and compute the target address explicitly via LIP-TN. +;;; The hardware link register (X30 / LR-TN) is reserved for the C ABI; +;;; Lisp uses its own LRA convention. + +(defmacro lisp-jump (function) + "Jump to the lisp function FUNCTION. LIP-TN is an interior-reg temporary." + `(progn + (inst add lip-tn ,function + (- (ash function-code-offset word-shift) vm:function-pointer-type)) + (move code-tn ,function) + (inst br lip-tn))) + +(defmacro lisp-return (return-pc &key (offset 0) (frob-code t)) + "Return to RETURN-PC." + `(progn + (inst add lip-tn ,return-pc + (- (* (1+ ,offset) word-bytes) other-pointer-type)) + ,(when frob-code + `(move code-tn ,return-pc)) + (inst br lip-tn))) + +(defmacro emit-return-pc (label) + "Emit a return-pc header word. LABEL is the label to use for this return-pc." + `(progn + (align lowtag-bits) + (emit-label ,label) + (inst lra-header-word))) + + +;;;; Stack TNs + +;;; Load-Stack-TN, Store-Stack-TN -- Interface +;;; +;;; Move a stack TN to a register and vice-versa. +;;; +;;; On AArch64 the control stack grows downward. The offset into the +;;; frame is therefore negated relative to CFP-TN, matching the ARM port. +;;; Large offsets that do not fit in the LDR/STR immediate field require a +;;; temporary register; callers that care about very deep frames should use +;;; LOADW/STOREW with an explicit TEMP argument instead. +(defmacro load-stack-tn (reg stack) + `(let ((reg ,reg) + (stack ,stack)) + (sc-case stack + ((control-stack) + ;; Stack grows down, so negate the TN offset. + (loadw reg cfp-tn (- (tn-offset stack)) 0))))) + +(defmacro store-stack-tn (stack reg) + `(let ((stack ,stack) + (reg ,reg)) + (sc-case stack + ((control-stack) + ;; Stack grows down, so negate the TN offset. + (storew reg cfp-tn (- (tn-offset stack)) 0))))) + + +;;; MAYBE-LOAD-STACK-TN -- Interface +;;; +(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) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) + + +;;;; Storage allocation: + +;; Allocation macro +;; +;; This macro does the appropriate stuff to allocate space. +;; +;; 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). +;; +;; If STACK-P is given, then allocation occurs on the control stack +;; (for dynamic-extent). In this case, you MUST also specify NODE, so +;; that the appropriate compiler policy can be used, and TEMP-TN, +;; which is needed for work-space. TEMP-TN MUST be a non-descriptor +;; reg. +;; +;; TEMP-TN MUST always be supplied because a temp register is needed +;; to do inline allocation. +;; +;; The ALLOC-TN register (X14) holds the current heap frontier and +;; carries the pseudo-atomic flag in bit 0, exactly as on SPARC. +;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is set. +(defmacro allocation (result-tn size lowtag &key stack-p temp-tn) + `(cond (,stack-p + ;; Stack allocation + ;; + ;; The control stack grows down on AArch64. Round CSP down to + ;; a multiple of the lispobj size, use that as the allocation + ;; pointer, then subtract SIZE to claim the space. + + ;; Make sure the temp-tn is a non-descriptor register! + (assert (and ,temp-tn (sc-is ,temp-tn non-descriptor-reg))) + + ;; temp-tn is csp-tn rounded down to a multiple of the lispobj size. + (inst and ,temp-tn csp-tn (lognot vm:lowtag-mask)) + ;; Set the result to temp-tn, with appropriate lowtag. + (inst orr ,result-tn ,temp-tn ,lowtag) + + ;; Allocate the desired space on the stack. + (inst sub csp-tn ,temp-tn ,size)) + (t + (let ((not-overflow (gen-label))) + ;; See if we can do an inline allocation. The updated free + ;; pointer should not point past the end of the current region. + ;; If it does, a full alloc needs to be done. + (load-symbol-value ,result-tn *current-region-end-addr*) + + ;; Sometimes the size is a known constant but won't fit in the + ;; 12-bit immediate field of an ADD instruction. Materialise it + ;; in TEMP-TN in that case. + (cond ((and (tn-p ,temp-tn) + (numberp ,size) + (not (typep ,size '(unsigned-byte 12)))) + (inst li ,temp-tn ,size) + (inst add alloc-tn alloc-tn ,temp-tn)) + (t + (inst add alloc-tn alloc-tn ,size))) + + (inst and ,temp-tn alloc-tn (lognot lowtag-mask)) ; Zap PA bits + + ;; temp-tn points to the new end of region. Did we go past the + ;; actual end of the region? If so, we need a full alloc. + (inst cmp ,temp-tn ,result-tn) + (without-scheduling () + ;; NOTE: alloc-tn has been updated to point to the new end. + ;; But the allocation routines expect alloc-tn to point to the + ;; original free region. Thus, the allocation trap handler + ;; MUST subtract SIZE from alloc-tn before calling the alloc + ;; routine. This allows for (slightly) faster inline code. + + ;; As above, SIZE might not fit in the immediate field. + (cond ((and (tn-p ,temp-tn) + (numberp ,size) + (not (typep ,size '(unsigned-byte 12)))) + (inst li ,result-tn ,size) + (inst sub ,result-tn ,temp-tn ,result-tn)) + (t + (inst sub ,result-tn ,temp-tn ,size))) + ;; Branch past the UDF if we did not overflow the region. + (inst b.le not-overflow) + (inst udf allocation-trap)) + (emit-label not-overflow) + ;; Set lowtag appropriately. + (inst orr ,result-tn ,result-tn ,lowtag))))) + +(defmacro with-fixed-allocation ((result-tn temp-tn type-code size + &key (lowtag other-pointer-type) + stack-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) (temp-tn temp-tn) + (type-code type-code) (size size) + (lowtag lowtag)) + `(pseudo-atomic () + (allocation ,result-tn (pad-data-block ,size) ,lowtag + :temp-tn ,temp-tn + :stack-p ,stack-p) + (when ,type-code + (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code)) + (storew ,temp-tn ,result-tn 0 ,lowtag)) + ,@body))) + + +;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. +;;; +;;; On AArch64, as on SPARC, the pseudo-atomic flag lives in bit 0 of +;;; ALLOC-TN (X14). Set by ORR-ing in pseudo-atomic-value, cleared by +;;; AND-ing with its complement. After clearing, ANDS tests the +;;; interrupted flag discarding the result into ZERO-TN (mirroring +;;; SPARC's ANDCC ZERO-TN, ALLOC-TN, ...). Because UDF is +;;; unconditional (unlike SPARC's "T :NE"), we guard it with a +;;; B.EQ skip label. The EXTRA keyword is accepted for compatibility +;;; but ignored. +(defmacro pseudo-atomic ((&key (extra 0)) &rest forms) + (declare (ignore extra)) + (let ((label (gensym "PA-NOT-INTERRUPTED-"))) + `(progn + (without-scheduling () + (inst orr alloc-tn alloc-tn pseudo-atomic-value)) + ,@forms + (let ((,label (gen-label))) + (without-scheduling () + (inst and alloc-tn alloc-tn (lognot pseudo-atomic-value)) + (inst ands zero-tn alloc-tn pseudo-atomic-interrupted-value) + (inst b.eq ,label) + (inst udf pseudo-atomic-trap)) + (emit-label ,label))))) + + +;;;; Type testing noise. + +;;; GEN-RANGE-TEST -- internal +;;; +;;; Generate code that branches to TARGET iff REG contains one of VALUES. +;;; If NOT-P is true, invert the test. Jumping to NOT-TARGET is the same +;;; as falling out the bottom. +;;; +;;; On AArch64, CMP sets the condition flags; conditional branches use the +;;; standard Bcc mnemonic with a keyword condition code (e.g. :eq, :le). +;;; The argument ordering for (inst b target cond) follows the ARM port +;;; convention: condition comes second. +(defun gen-range-test (reg target not-target not-p min seperation max values) + (let ((tests nil) + (start nil) + (end nil) + (insts nil)) + (multiple-value-bind (equal less-or-equal greater-or-equal label) + (if not-p + (values :ne :gt :lt not-target) + (values :eq :le :ge target)) + (flet ((emit-test () + (if (= start end) + (push start tests) + (push (cons start end) tests)))) + (dolist (value values) + (cond ((< value min) + (error (intl:gettext "~S is less than the specified minimum of ~S") + value min)) + ((> value max) + (error (intl:gettext "~S is greater than the specified maximum of ~S") + value max)) + ((not (zerop (rem (- value min) seperation))) + (error (intl:gettext "~S isn't an even multiple of ~S from ~S") + value seperation min)) + ((null start) + (setf start value)) + ((> value (+ end seperation)) + (emit-test) + (setf start value))) + (setf end value)) + (emit-test)) + (macrolet ((inst (name &rest args) + `(push (list 'inst ',name ,@args) insts))) + (do ((remaining (nreverse tests) (cdr remaining))) + ((null remaining)) + (let ((test (car remaining)) + (last (null (cdr remaining)))) + (if (atom test) + (progn + (inst cmp reg test) + (if last + (inst b target equal) + (inst b label :eq))) + (let ((start (car test)) + (end (cdr test))) + (cond ((and (= start min) (= end max)) + (warn (intl:gettext "The values ~S cover the entire range from ~ + ~S to ~S [step ~S].") + values min max seperation) + (push `(unless ,not-p (inst b ,target)) insts)) + ((= start min) + (inst cmp reg end) + (if last + (inst b target less-or-equal) + (inst b label :le))) + ((= end max) + (inst cmp reg start) + (if last + (inst b target greater-or-equal) + (inst b label :ge))) + (t + (inst cmp reg start) + (inst b (if not-p target not-target) :lt) + (inst cmp reg end) + (if last + (inst b target less-or-equal) + (inst b label :le)))))))))) + (nreverse insts))) + +(defun gen-other-immediate-test (reg target not-target not-p values) + (gen-range-test reg target not-target not-p + (+ other-immediate-0-type lowtag-limit) + (- other-immediate-1-type other-immediate-0-type) + (ash 1 type-bits) + values)) + + +(defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs + function-p) + (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql) + (member odd-fixnum-type lowtags :test #'eql))) + (lowtags (sort (if fixnump + (delete even-fixnum-type + (remove odd-fixnum-type lowtags + :test #'eql) + :test #'eql) + (copy-list lowtags)) + #'<)) + (lowtag (if function-p + vm:function-pointer-type + vm:other-pointer-type)) + (hdrs (sort (copy-list hdrs) #'<)) + (immed (sort (copy-list immed) #'<))) + (append + (when immed + `((inst and ,temp ,reg type-mask) + ,@(if (or fixnump lowtags hdrs) + (let ((fall-through (gensym))) + `((let (,fall-through (gen-label)) + ,@(gen-other-immediate-test + temp (if not-p not-target target) + fall-through nil immed) + (emit-label ,fall-through)))) + (gen-other-immediate-test temp target not-target not-p immed)))) + (when fixnump + ;; On AArch64, TST is ANDS with Rd = XZR; it sets condition flags + ;; without storing the result. + `((inst tst ,reg fixnum-tag-mask) + ,(if (or lowtags hdrs) + `(inst b ,(if not-p not-target target) :eq) + `(inst b ,target ,(if not-p :ne :eq))))) + (when (or lowtags hdrs) + `((inst and ,temp ,reg lowtag-mask))) + (when lowtags + (if hdrs + (let ((fall-through (gensym))) + `((let ((,fall-through (gen-label))) + ,@(gen-range-test temp (if not-p not-target target) + fall-through nil + 0 1 (1- lowtag-limit) lowtags) + (emit-label ,fall-through)))) + (gen-range-test temp target not-target not-p 0 1 + (1- lowtag-limit) lowtags))) + (when hdrs + `((inst cmp ,temp ,lowtag) + (inst b ,(if not-p target not-target) :ne) + (load-type ,temp ,reg (- ,lowtag)) + ,@(gen-other-immediate-test temp target not-target not-p hdrs)))))) + +(defconstant immediate-types + (list base-char-type unbound-marker-type)) + +(defconstant function-subtypes + (list funcallable-instance-header-type + #-double-double dylan-function-header-type + function-header-type closure-function-header-type + closure-header-type)) + +(defmacro test-type (register temp target not-p &rest type-codes) + (let* ((type-codes (mapcar #'eval type-codes)) + (lowtags (remove lowtag-limit type-codes :test #'<)) + (extended (remove lowtag-limit type-codes :test #'>)) + (immediates (intersection extended immediate-types :test #'eql)) + (headers (set-difference extended immediate-types :test #'eql)) + (function-p nil)) + (unless type-codes + (error (intl:gettext "Must supply at least on type for test-type."))) + (when (and headers (member other-pointer-type lowtags)) + (warn (intl:gettext "OTHER-POINTER-TYPE supersedes the use of ~S") headers) + (setf headers nil)) + (when (and immediates + (or (member other-immediate-0-type lowtags) + (member other-immediate-1-type lowtags))) + (warn (intl:gettext "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S") immediates) + (setf immediates nil)) + (when (intersection headers function-subtypes) + (unless (subsetp headers function-subtypes) + (error (intl:gettext "Can't test for mix of function subtypes and normal ~ + header types."))) + (setq function-p t)) + + (let ((n-reg (gensym)) + (n-temp (gensym)) + (n-target (gensym)) + (not-target (gensym))) + `(let ((,n-reg ,register) + (,n-temp ,temp) + (,n-target ,target) + (,not-target (gen-label))) + (declare (ignorable ,n-temp)) + ,@(if (constantp not-p) + (test-type-aux n-reg n-temp n-target not-target + (eval not-p) lowtags immediates headers + function-p) + `((cond (,not-p + ,@(test-type-aux n-reg n-temp n-target not-target t + lowtags immediates headers + function-p)) + (t + ,@(test-type-aux n-reg n-temp n-target not-target nil + lowtags immediates headers + function-p))))) + (emit-label ,not-target))))) + + +;;;; Error Code + +(defvar *adjustable-vectors* nil) + +(defmacro with-adjustable-vector ((var) &rest body) + `(let ((,var (or (pop *adjustable-vectors*) + (make-array 16 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t)))) + (setf (fill-pointer ,var) 0) + (unwind-protect + (progn + ,@body) + (push ,var *adjustable-vectors*)))) + +(eval-when (compile load eval) + (defun emit-error-break (vop kind code values) + (let ((vector (gensym))) + `((let ((vop ,vop)) + (when vop + (note-this-location vop :internal-error))) + ;; AArch64 uses UDF (permanently undefined instruction) as the + ;; error trap. The KIND immediate is encoded directly in the + ;; UDF instruction word and read by the signal handler. + (inst udf ,kind) + (with-adjustable-vector (,vector) + (write-var-integer (error-number-or-lose ',code) ,vector) + ,@(mapcar #'(lambda (tn) + `(let ((tn ,tn)) + (write-var-integer (make-sc-offset (sc-number + (tn-sc tn)) + (tn-offset tn)) + ,vector))) + values) + (inst byte (length ,vector)) + (dotimes (i (length ,vector)) + (inst byte (aref ,vector i)))) + (align word-shift))))) + +(defmacro error-call (vop error-code &rest values) + "Cause an error. ERROR-CODE is the error to cause." + (cons 'progn + (emit-error-break vop error-trap error-code values))) + +(defmacro cerror-call (vop label error-code &rest values) + "Cause a continuable error. If the error is continued, execution resumes at + LABEL." + `(progn + ,@(emit-error-break vop cerror-trap error-code values) + (inst b ,label))) + +(defmacro generate-error-code (vop error-code &rest values) + "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) + (error-call ,vop ,error-code ,@values) + start-lab))) + +(defmacro generate-cerror-code (vop error-code &rest values) + "Generate-CError-Code Error-code Value* + Emit code for a continuable error with the specified Error-Code and + context Values. If the error is continued, execution resumes after + the GENERATE-CERROR-CODE form." + (let ((continue (gensym "CONTINUE-LABEL-")) + (error (gensym "ERROR-LABEL-"))) + `(let ((,continue (gen-label))) + (emit-label ,continue) + (assemble (*elsewhere*) + (let ((,error (gen-label))) + (emit-label ,error) + (cerror-call ,vop ,continue ,error-code ,@values) + ,error))))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/30f5293b6cca331c87941bb… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/30f5293b6cca331c87941bb… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][arm64-dev-1] Check formats and printers
by Raymond Toy (＠rtoy) 22 Mar '26

22 Mar '26

Raymond Toy pushed to branch arm64-dev-1 at cmucl / cmucl Commits: 3fdc9ea5 by Raymond Toy at 2026-03-21T17:32:09-07:00 Check formats and printers * Checked all the instruction formats against the ARM reference and updated any differences. * Checked that W regs are printed when expected. * ldr/str handle reg-offset now so it's all unified. * Use sign-extend t for imm9 and imm7 fields. * memory-ref base — changed from (base nil :type tn) to (base (required-argument) :type tn) * reg-offset — default extend-type changed from :lsl to :uxtx; docstring updated; added rm to the declare * ldr/str comment examples — updated to use x2 instead of w2, added (reg-offset x1 x2) bare example, added :sxtw 2 example; removed the old :lsl example print-backend-inst-space works. This work was done by Claude with review by me. [skip-ci] - - - - - 1 changed file: - src/compiler/arm64/insts.lisp Changes: ===================================== src/compiler/arm64/insts.lisp ===================================== @@ -303,8 +303,12 @@ (imm :fields (list (byte 19 5) (byte 2 29)) :printer #'(lambda (vlist stream dstate) (declare (ignore dstate)) - (let ((imm (logior (ash (first vlist) 2) - (second vlist)))) + (let* ((raw (logior (ash (first vlist) 2) + (second vlist))) + ;; sign-extend from bit 20 (21-bit signed value) + (imm (if (logbitp 20 raw) + (- raw (ash 1 21)) + raw))) (print-immed imm stream)))) (rd :field (byte 5 0) :type 'reg)) @@ -320,6 +324,8 @@ ;;; [29] S (0=no flags, 1=set flags) ;;; [28:24] 10001 ;;; [23:22] shift (00=LSL#0, 01=LSL#12) +;;; [23] 0 (reserved) +;;; [22] shift (0=LSL#0, 1=LSL#12) ;;; [21:10] imm12 ;;; [9:5] Rn ;;; [4:0] Rd @@ -333,14 +339,15 @@ (op :field (byte 1 30)) (s :field (byte 1 29)) (op1 :field (byte 5 24)) - (shift :field (byte 2 22)) + (res0 :field (byte 1 23) :value 0) + (shift :field (byte 1 22)) (imm12 :field (byte 12 10)) (rn :field (byte 5 5) :type 'reg) (rd :field (byte 5 0) :type 'reg)) (define-emitter emit-format-add-sub-imm 32 - (byte 1 31) (byte 1 30) (byte 1 29) (byte 5 24) (byte 2 22) - (byte 12 10) (byte 5 5) (byte 5 0)) + (byte 1 31) (byte 1 30) (byte 1 29) (byte 5 24) (byte 1 23) + (byte 1 22) (byte 12 10) (byte 5 5) (byte 5 0)) ;;; Logical (immediate) @@ -719,7 +726,7 @@ (op2 :field (byte 2 24) :value #b00) (opc :field (byte 2 22)) (z :field (byte 1 21) :value 0) - (imm9 :field (byte 9 12)) + (imm9 :field (byte 9 12) :sign-extend t) (type :field (byte 2 10)) (rn :field (byte 5 5) :type 'reg) (rt :field (byte 5 0) :type 'reg)) @@ -759,7 +766,15 @@ (op2 :field (byte 2 24) :value #b00) (opc :field (byte 2 22)) (one :field (byte 1 21) :value 1) - (rm :field (byte 5 16) :type 'reg) + (rm :field (byte 5 16) + :printer #'(lambda (value stream dstate) + (let* ((word (disassem::sap-ref-int + (disassem:dstate-segment-sap dstate) + (disassem:dstate-cur-offs dstate) + 4 :little-endian)) + (option (ldb (byte 3 13) word))) + (princ (get-reg-name value (if (< option 6) 0 1)) + stream)))) (option :field (byte 3 13) :type 'extend-type) (s :field (byte 1 12)) (op3 :field (byte 2 10) :value #b10) @@ -801,7 +816,7 @@ (op2 :field (byte 1 25) :value 0) (index :field (byte 2 23)) (l :field (byte 1 22)) - (imm7 :field (byte 7 15)) + (imm7 :field (byte 7 15) :sign-extend t) (rt2 :field (byte 5 10) :type 'reg) (rn :field (byte 5 5) :type 'reg) (rt :field (byte 5 0) :type 'reg)) @@ -986,14 +1001,17 @@ (defstruct memory-ref ;; Base register. - (base nil :type tn) + (base (required-argument) :type tn) ;; Byte offset -- semantics depend on mode: - ;; :offset unsigned, scaled by access size at emit time - ;; :pre signed 9-bit, stored unscaled in imm9 - ;; :post signed 9-bit, stored unscaled in imm9 + ;; :offset unsigned, scaled by access size at emit time + ;; :pre signed 9-bit, stored unscaled in imm9 + ;; :post signed 9-bit, stored unscaled in imm9 + ;; :reg-offset register offset via extended-reg (offset 0 :type integer) + ;; Register offset operand (only for :reg-offset mode). + (rm nil :type (or null extended-reg)) ;; Addressing mode. - (mode :offset :type (member :offset :pre :post))) + (mode :offset :type (member :offset :pre :post :reg-offset))) (defun mem (base &optional (offset 0)) "Unsigned-offset memory reference: [base, #offset]. @@ -1014,6 +1032,18 @@ (declare (type tn base) (type (signed-byte 9) offset)) (make-memory-ref :base base :offset offset :mode :post)) +(defun reg-offset (base rm &optional (extend-type :uxtx) (shift 0)) + "Register-offset memory reference: [base, rm, extend #shift] + Rm is the offset register, extended and optionally shifted. + Extend-type defaults to :uxtx (no extension, X register). + Use :uxtw or :sxtw to treat rm as a W register. + Shift is 0 or the log2 of the access size." + (declare (type tn base rm) + (type (member :uxtb :uxth :uxtw :uxtx :sxtb :sxth :sxtw :sxtx) extend-type) + (type (integer 0 4) shift)) + (make-memory-ref :base base :mode :reg-offset + :rm (extend rm extend-type shift))) + (defun nzcv (&rest flags) "Return a 4-bit integer encoding the NZCV flags, suitable for use as the nzcv argument to CCMP/CCMN. Also usable with MSR NZCV after @@ -1785,12 +1815,12 @@ (etypecase src ((unsigned-byte 12) (emit-format-add-sub-imm segment ,sf ,op ,s #b10001 - 0 src + 0 0 src (reg-tn-encoding rn) (reg-tn-encoding rd))) (shifted-imm (emit-format-add-sub-imm segment ,sf ,op ,s #b10001 - (shifted-imm-shift src) + 0 (shifted-imm-shift src) (shifted-imm-value src) (reg-tn-encoding rn) (reg-tn-encoding rd))) @@ -1856,10 +1886,10 @@ (etypecase src ((unsigned-byte 12) (emit-format-add-sub-imm segment ,sf ,op 1 #b10001 - 0 src (reg-tn-encoding rn) 31)) + 0 0 src (reg-tn-encoding rn) 31)) (shifted-imm (emit-format-add-sub-imm segment ,sf ,op 1 #b10001 - (shifted-imm-shift src) + 0 (shifted-imm-shift src) (shifted-imm-value src) (reg-tn-encoding rn) 31)) (tn @@ -2022,7 +2052,7 @@ (define-instruction-macro mov (rd src) `(inst orr ,rd null-tn ,src)) -;; MVN Xd, src = ORN Xd, XZR, src +;; MVN Xd, src = ORN Xd, XZR, src -- bitwise NOT. (define-instruction-macro mvn (rd src) `(inst orn ,rd null-tn ,src)) @@ -2311,7 +2341,8 @@ `(define-instruction ,name (segment rt target) (:declare (type tn rt) (type label target)) (:printer format-compare-branch - ((sf ,sf) (op1 #b011010) (op ,op))) + ((sf ,sf) (op1 #b011010) (op ,op) + ,@(when (zerop sf) '((rt nil :type 'wreg))))) (:attributes branch) (:emitter (emit-back-patch segment 4 @@ -2337,7 +2368,8 @@ (type (unsigned-byte ,(if (zerop sf) 5 6)) bit-num) (type label target)) (:printer format-test-branch - ((op1 #b011011) (op ,op) (b5 ,sf))) + ((op1 #b011011) (op ,op) (b5 ,sf) + ,@(when (zerop sf) '((rt nil :type 'wreg))))) (:attributes branch) (:emitter (emit-back-patch segment 4 @@ -2499,6 +2531,10 @@ ;; (inst ldr x0 (mem x1 16)) ; LDR X0, [X1, #16] ;; (inst ldr x0 (pre-index x1 16)) ; LDR X0, [X1, #16]! ;; (inst ldr x0 (post-index x1 -8)) ; LDR X0, [X1], #-8 +;; (inst ldr x0 (reg-offset x1 x2)) ; LDR X0, [X1, X2] +;; (inst ldr x0 (reg-offset x1 x2 :uxtx 3)) ; LDR X0, [X1, X2, LSL #3] +;; (inst ldr x0 (reg-offset x1 x2 :uxtw)) ; LDR X0, [X1, W2, UXTW] +;; (inst ldr x0 (reg-offset x1 x2 :sxtw 2)) ; LDR X0, [X1, W2, SXTW #2] ;; (inst ldrh w0 (mem x1 6)) ; LDRH W0, [X1, #6] ;; (inst ldrb w0 (mem x1 3)) ; LDRB W0, [X1, #3] ;; (inst str x0 (mem x1 16)) ; STR X0, [X1, #16] @@ -2516,6 +2552,9 @@ (:printer format-ldst-imm9 ((size ,size) (op1 #b111) (v 0) (op2 #b00) (opc ,opc) (type #b01))) + (:printer format-ldst-reg + ((size ,size) (op1 #b111) (v 0) (op2 #b00) (opc ,opc) + (one 1) (op3 #b10))) (:emitter (let ((rn (memory-ref-base mem)) (offset (memory-ref-offset mem))) @@ -2540,7 +2579,19 @@ (emit-format-ldst-imm9 segment ,size #b111 0 #b00 ,opc 0 (ldb (byte 9 0) offset) #b01 (reg-tn-encoding rn) - (reg-tn-encoding rt))))))))) + (reg-tn-encoding rt))) + (:reg-offset + (let* ((ext (memory-ref-rm mem)) + (rm (extended-reg-reg ext)) + (s (if (zerop (extended-reg-shift ext)) 0 1))) + (emit-format-ldst-reg segment ,size #b111 0 #b00 ,opc + 1 + (reg-tn-encoding rm) + (extend-type-encoding + (extended-reg-extend-type ext)) + s #b10 + (reg-tn-encoding rn) + (reg-tn-encoding rt)))))))))) ;; name size opc access-size (def strb #b00 #b00 1) (def ldrb #b00 #b01 1) @@ -3448,5 +3499,3 @@ (define-instruction-macro li (reg value) `(%li ,reg ,value)) - -;; NOT Xd, Xm = ORN Xd, XZR, Xm (already covered by MVN macro). View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3fdc9ea54a809684a28eee2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3fdc9ea54a809684a28eee2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][arm64-dev-1] 2 commits: Tell cmucl where the arm64 files are
by Raymond Toy (＠rtoy) 21 Mar '26

21 Mar '26

Raymond Toy pushed to branch arm64-dev-1 at cmucl / cmucl Commits: 001fe8ba by Raymond Toy at 2026-03-21T08:02:10-07:00 Tell cmucl where the arm64 files are They're in the src/compiler/arm64, of course. - - - - - 54272c1b by Raymond Toy at 2026-03-21T08:06:22-07:00 Update insts.lisp A completely new version that seems more natural and probably closer to what I would do by hand. It's also much closer to arm/insts.lisp, and looks like spar/insts.lisp and ppc/insts.lisp. This file compiles and `(disassem::print-backend-inst-space)` shows no errors so that we can at least disassemble the instructions correctly. Printers are, of course, untested. Also created by Claude with lots of guidance from me. [skip-ci] - - - - - 2 changed files: - src/compiler/arm64/insts.lisp - src/tools/setup.lisp Changes: ===================================== src/compiler/arm64/insts.lisp ===================================== The diff for this file was not included because it is too large. ===================================== src/tools/setup.lisp ===================================== @@ -306,6 +306,7 @@ ((c:target-featurep :amd64) "amd64/") ((c:target-featurep :arm) "arm/") ((c:target-featurep :sparc64) "sparc64/") + ((c:target-featurep :arm64) "arm64/") (t (error "What machine is this?"))) (make-pathname :directory (pathname-directory f))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d0312fc92acadffce490b4… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d0312fc92acadffce490b4… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][arm64-dev-1] Add arm64-lispregs.h
by Raymond Toy (＠rtoy) 19 Mar '26

19 Mar '26

Raymond Toy pushed to branch arm64-dev-1 at cmucl / cmucl Commits: d0312fc9 by Raymond Toy at 2026-03-18T18:43:48-07:00 Add arm64-lispregs.h Update lispregs.h to load it. Generated by Claude [skip-ci] - - - - - 2 changed files: - + src/lisp/arm64-lispregs.h - src/lisp/lispregs.h Changes: ===================================== src/lisp/arm64-lispregs.h ===================================== @@ -0,0 +1,88 @@ +/* + * This code was written as part of the CMUCL project and has been + * placed in the public domain. + */ +#ifndef ARM64_LISPREGS_H +#define ARM64_LISPREGS_H + +#ifdef LANGUAGE_ASSEMBLY +#define REG(num) x ## num +#else +#define REG(num) (num) +#endif + +#define NREGS 32 + +/* + * Non-descriptor (C argument/scratch) registers: X0-X7. + * Caller-saved in both the C ABI and Lisp; hold raw untagged values. + */ +#define reg_NL0 REG(0) /* X0 - C arg 0 / return value */ +#define reg_NL1 REG(1) /* X1 - C arg 1 */ +#define reg_NL2 REG(2) /* X2 - C arg 2 */ +#define reg_NL3 REG(3) /* X3 - C arg 3 */ +#define reg_NL4 REG(4) /* X4 - C arg 4 */ +#define reg_NL5 REG(5) /* X5 - C arg 5 */ +#define reg_NL6 REG(6) /* X6 - C arg 6 */ +#define reg_NL7 REG(7) /* X7 - C arg 7 */ + +/* Runtime state registers (non-descriptor range). */ +#define reg_NARGS REG(8) /* X8 - number of arguments */ +#define reg_CFUNC REG(9) /* X9 - C function address */ +#define reg_NFP REG(10) /* X10 - number-stack frame pointer */ +#define reg_BSP REG(11) /* X11 - binding stack pointer */ +#define reg_CFP REG(12) /* X12 - control frame pointer */ +#define reg_CSP REG(13) /* X13 - control stack pointer */ +#define reg_ALLOC REG(14) /* X14 - allocation pointer */ +#define reg_NULL REG(15) /* X15 - NIL / null register */ + +/* Code and call-target registers. */ +#define reg_CODE REG(16) /* X16 - current code object (C: ip0) */ +#define reg_FDEFN REG(17) /* X17 - function definition (C: ip1) */ + +/* Descriptor (Lisp object) registers. */ +#define reg_CNAME REG(18) /* X18 - called name */ +#define reg_LEXENV REG(19) /* X19 - lexical environment */ +#define reg_OCFP REG(20) /* X20 - old control frame pointer */ +#define reg_LRA REG(21) /* X21 - lisp return address */ + +/* Argument registers (descriptor). */ +#define reg_A0 REG(22) /* X22 - argument 0 */ +#define reg_A1 REG(23) /* X23 - argument 1 */ +#define reg_A2 REG(24) /* X24 - argument 2 */ +#define reg_A3 REG(25) /* X25 - argument 3 */ + +/* Local (descriptor) registers. */ +#define reg_L0 REG(26) /* X26 - local 0 */ +#define reg_L1 REG(27) /* X27 - local 1 */ +#define reg_L2 REG(28) /* X28 - local 2 */ + +/* Interior pointer and ABI registers. */ +#define reg_LIP REG(29) /* X29 - lisp interior pointer (C ABI FP, reclaimed) */ +#define reg_LR REG(30) /* X30 - hardware link register */ + +/* + * X31 is context-dependent in AArch64: + * - In data-processing encodings: XZR (zero register), reads as 0. + * - In load/store base and SP-arith: SP (stack pointer). + */ +#define reg_NSP REG(31) /* X31/SP - native stack pointer / zero register */ + +#define REGNAMES \ + "NL0", "NL1", "NL2", "NL3", "NL4", "NL5", "NL6", "NL7", \ + "NARGS", "CFUNC", "NFP", "BSP", "CFP", "CSP", "ALLOC", "NULL", \ + "CODE", "FDEFN", "CNAME", "LEXENV", "OCFP", "LRA", \ + "A0", "A1", "A2", "A3", \ + "L0", "L1", "L2", \ + "LIP", "LR", "ZR/SP" + +#define BOXED_REGISTERS { \ + reg_A0, reg_A1, reg_A2, reg_A3, \ + reg_CNAME, reg_LEXENV, reg_OCFP, reg_LRA, reg_CODE, reg_FDEFN \ +} + +#define SC_REG(scp, reg) (*os_sigcontext_reg(scp, reg)) +#define SC_PC(scp) (*os_sigcontext_pc(scp)) +#define SC_SP(scp) SC_REG(scp, reg_CSP) + +#endif /* ARM64_LISPREGS_H */ ===================================== src/lisp/lispregs.h ===================================== @@ -44,6 +44,10 @@ #include "arm-lispregs.h" #endif +#ifdef __aarch64__ +#include "arm64-lispregs.h" +#endif + /* This matches the definition of sc-offset in code/debug-info.lisp */ #define SC_OFFSET(sc,offset) (((offset) << 5) | (sc)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d0312fc92acadffce490b41… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d0312fc92acadffce490b41… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch arm64-dev-1
by Raymond Toy (＠rtoy) 19 Mar '26

19 Mar '26

Raymond Toy pushed new branch arm64-dev-1 at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/arm64-dev-1 You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #489: Rewrite gitlab-ci to use Gitlab extends syntax
by Raymond Toy (＠rtoy) 15 Mar '26

15 Mar '26

Raymond Toy pushed to branch master at cmucl / cmucl Commits: c48d3604 by Raymond Toy at 2026-03-15T07:47:08-07:00 Fix #489: Rewrite gitlab-ci to use Gitlab extends syntax - - - - - 314c203f by Raymond Toy at 2026-03-15T07:47:08-07:00 Merge branch 'issue-489-update-gitlab-to-extends-syntax' into 'master' Fix #489: Rewrite gitlab-ci to use Gitlab extends syntax Closes #489 See merge request cmucl/cmucl!366 - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -15,15 +15,19 @@ workflow: - if: $CI_PIPELINE_SOURCE == "schedule" # Run on merge requests - if: $CI_PIPELINE_SOURCE == "merge_request_event" - # Don't create a branch pipeline when an MR pipeline already exists + # Run on the default branch (where there's no MR) + - if: $CI_COMMIT_BRANCH == $CI_DEFAULT_BRANCH + # Run on feature branches, but only if there's no open MR (to avoid + # duplicate pipelines). - if: $CI_COMMIT_BRANCH && $CI_OPEN_MERGE_REQUESTS when: never - if: $CI_COMMIT_BRANCH + # Run on tags - if: $CI_COMMIT_TAG # Default install configuration to download the cmucl tarballs to use # for building. -.install_template: &install_configuration +.install: stage: install artifacts: paths: @@ -45,7 +49,7 @@ workflow: # the option '-C ""' is good enough. We also override the default # build dirs by using the -b option so that we know where the results # are, independent of OS. -.build_template: &build_configuration +.build: stage: build artifacts: paths: @@ -78,7 +82,7 @@ workflow: - bin/make-dist.sh -S build-4 # Default configuration for running the ansi-tests. -.ansi_test_template: &ansi_test_configuration +.ansi-test: stage: ansi-test artifacts: paths: @@ -88,7 +92,7 @@ workflow: - cp ../ansi-test/test.out ansi-test.out # Default configuration for running unit tests. -.unit_test_template: &unit_test_configuration +.unit-test: stage: test artifacts: paths: @@ -99,7 +103,7 @@ workflow: # Default configuration to test creation of lisp executable and # testing the exectuable works. -.exec_test_template: &exec_test_configuration +.exec-test: stage: test script: # Create an executable and test it by printing the version. @@ -110,7 +114,7 @@ workflow: - bin/run-unit-tests.sh -l ./saved-lisp-executable # Default configuration for running the benchmarks. -.benchmark_template: &benchmark_configuration +.benchmark: stage: benchmark artifacts: paths: @@ -121,7 +125,68 @@ workflow: - CMUCL=../../snapshot/bin/lisp ./run-cmucl.sh - CMUCL=../../dist/bin/lisp ./run-cmucl.sh - ../../snapshot/bin/lisp -load report - + +# Rules shared by optional/manual jobs (static analyzer, markdown-link-check). +.optional-rules: + rules: + - if: $CI_PIPELINE_SOURCE == "schedule" + - if: $RUN_CHECKS + - when: manual + allow_failure: true + +# Per-platform base jobs: capture tags and the needs chain so individual +# jobs don't have to repeat them. +.linux: + tags: + - linux + +.linux-needs-install: + extends: .linux + needs: + - job: linux:install + artifacts: true + +.linux-needs-build: + extends: .linux + needs: + # Needs artifacts from build (dist/) + - job: linux:build + artifacts: true + +.osx: + tags: + - macos-virtualbox + +.osx-needs-install: + extends: .osx + needs: + - job: osx:install + artifacts: true + +.osx-needs-build: + extends: .osx + needs: + # Needs artifacts from build (dist/) + - job: osx:build + artifacts: true + +.ubuntu: + tags: + - ubuntu + +.ubuntu-needs-install: + extends: .ubuntu + needs: + - job: ubuntu:install + artifacts: true + +.ubuntu-needs-build: + extends: .ubuntu + needs: + # Needs artifacts from build (dist/) + - job: ubuntu:build + artifacts: true + stages: - install - build @@ -135,29 +200,21 @@ cache: #### Linux jobs #### linux:install: - <<: *install_configuration - tags: - - linux + extends: [.install, .linux] variables: osname: "linux" CURL: "curl" linux:build: - <<: *build_configuration - tags: - - linux - needs: - - job: linux:install - artifacts: true + extends: [.build, .linux-needs-install] variables: # Fedora 41 must build with gcc because the clang build fails some # ansi-tests. See [#469]. CONFIG: "x86_linux" linux:cross-build: + extends: .linux-needs-install stage: build - tags: - - linux artifacts: paths: - xdist/ @@ -169,10 +226,6 @@ linux:cross-build: variables: # This must match the config used for the linux build! CONFIG: "x86_linux" - - needs: - - job: linux:install - artifacts: true script: - bin/create-target.sh xtarget $CONFIG - bin/create-target.sh xcross $CONFIG @@ -181,26 +234,14 @@ linux:cross-build: - bin/make-dist.sh -I xdist xlinux-4 linux:test: - <<: *unit_test_configuration - tags: - - linux - needs: - # Needs artifacts from build (dist/) - - job: linux:build - artifacts: true + extends: [.unit-test, .linux-needs-build] linux:exec-test: - <<: *exec_test_configuration - tags: - - linux - needs: - - job: linux:build - artifacts: true + extends: [.exec-test, .linux-needs-build] linux:cross-test: + extends: .linux stage: test - tags: - - linux artifacts: paths: - ansi-test/test.out @@ -213,18 +254,10 @@ linux:cross-test: - bin/run-unit-tests.sh -l xdist/bin/lisp 2>&1 | tee cross-test.log linux:ansi-test: - <<: *ansi_test_configuration - tags: - - linux - needs: - # Needs artifacts from build (dist/) - - job: linux:build - artifacts: true - + extends: [.ansi-test, .linux-needs-build] + linux:benchmark: - <<: *benchmark_configuration - tags: - - linux + extends: [.benchmark, .linux] needs: # Needs artifacts from install (snapshot/) and build (dist/) - job: linux:install @@ -233,78 +266,42 @@ linux:benchmark: #### OSX (Mac) jobs #### osx:install: - <<: *install_configuration - tags: - - macos-virtualbox + extends: [.install, .osx] variables: osname: "darwin" CURL: "/opt/local/bin/curl" osx:build: - <<: *build_configuration - tags: - - macos-virtualbox - needs: - - job: osx:install - artifacts: true + extends: [.build, .osx-needs-install] variables: CONFIG: "x86_darwin" osx:test: - <<: *unit_test_configuration - tags: - - macos-virtualbox - needs: - # Needs artifacts from build (dist/) - - job: osx:build - artifacts: true + extends: [.unit-test, .osx-needs-build] osx:exec-test: - <<: *exec_test_configuration - tags: - - macos-virtualbox - needs: - - job: osx:build - artifacts: true - + extends: [.exec-test, .osx-needs-build] + osx:ansi-test: - <<: *ansi_test_configuration - tags: - - macos-virtualbox - needs: - # Needs artifacts from build (dist/) - - job: osx:build - artifacts: true - + extends: [.ansi-test, .osx-needs-build] + osx:benchmark: - <<: *benchmark_configuration - tags: - - macos-virtualbox + extends: [.benchmark, .osx] needs: # Needs artifacts from install (snapshot/) and build (dist/) - job: osx:install artifacts: true - - job: osx:build + - job: osx:build # Optional job that runs the static analyzer. It needs the files from # the linux-4 directory built in the linux:build job. linux:static-analyzer: + extends: [.optional-rules, .linux-needs-build] stage: analyze - - tags: - - linux artifacts: when: always paths: - analyzer.log - needs: - - job: linux:build - artifacts: true - rules: - - if: $CI_PIPELINE_SOURCE == "schedule" - - if: $RUN_CHECKS - - when: manual - allow_failure: true script: # Analysis can generate huge amounts of output. For now just save # the results to the log file instead of also having it go to the @@ -315,20 +312,13 @@ linux:static-analyzer: #### OpenSUSE jobs #### ubuntu:install: - <<: *install_configuration - tags: - - ubuntu + extends: [.install, .ubuntu] variables: osname: "linux" CURL: "curl" ubuntu:build: - <<: *build_configuration - tags: - - ubuntu - needs: - - job: ubuntu:install - artifacts: true + extends: [.build, .ubuntu-needs-install] variables: # Build with gcc on Ubuntu 25.10. It produces a lisp than passes # the ansi-tests. Clang seems to fail the ansi-tests WRITE.1, @@ -336,22 +326,10 @@ ubuntu:build: CONFIG: "x86_linux" ubuntu:test: - <<: *unit_test_configuration - tags: - - ubuntu - needs: - # Needs artifacts from build (dist/) - - job: ubuntu:build - artifacts: true + extends: [.unit-test, .ubuntu-needs-build] ubuntu:ansi-test: - <<: *ansi_test_configuration - tags: - - ubuntu - needs: - # Needs artifacts from build (dist/) - - job: ubuntu:build - artifacts: true + extends: [.ansi-test, .ubuntu-needs-build] # Optional job that runs the markdown link checker. This is optional # because it's very slow, of course; you have to run it manually. @@ -359,21 +337,14 @@ ubuntu:ansi-test: # From https://github.com/tcort/markdown-link-check # Checks links on the wiki pages whenever any wiki markdown pages change. markdown-link-check: + extends: [.optional-rules, .linux] stage: markdown-link-check - # Only the linux runner has markdown-link-check installed - tags: - - linux # It's ok if this fails; we don't want to declare the entire # pipeline as having failed. allow_failure: true # This job doesn't depend on any others. needs: [] - rules: - - if: $CI_PIPELINE_SOURCE == "schedule" - - if: $RUN_CHECKS - - when: manual - allow_failure: true script: # Check links in the main repo - find . -name \*.md -print0 | xargs -0 -n1 markdown-link-check @@ -383,3 +354,4 @@ markdown-link-check: - git clone https://gitlab.common-lisp.net/cmucl/cmucl.wiki.git - find cmucl.wiki -name \*.md -print0 | xargs -0 -n1 markdown-link-check + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3db302f36355d9eb32c50b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3db302f36355d9eb32c50b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0