GitLab

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]

Raymond Toy pushed to branch arm64-dev-1 at cmucl / cmucl

Commits:

1 changed file:

Changes:

 +;;; -*- 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)))))
++