RISC-V Assembler.lisp

; RISC-V Assembler - Version 4 - 18th October 2024
; see http://www.ulisp.com/show?310Z
;

; Extract register number
(defun regno (sym)
  (case sym (zero 0) (ra 1) (sp 2) (gp 3) (tp 4) ((s0 fp) 8) (s1 9)
    (t (let* ((s (string sym))
              (c (char s 0))
              (n (read-from-string (subseq s 1))))
         (case c (#\x n) (#\a (+ n 10)) (#\s (+ n 16)) (#\t (if (<= n 2) (+ n 5) (+ n 25))))))))

; Short 3-bit register s0, s1, a0 to a5
(defun cregp (rd) (<= 8 (regno rd) 15))

(defun cregno (sym) (logand (regno sym) #x7))

; Pack arguments into bit fields
(defun emit (bits &rest args)
  (let ((word 0))
    (mapc #'(lambda (width value)
              (unless (zerop (ash value (- width))) (error* "Won't fit"))
              (setq word (logior (ash word width) value)))
          bits args)
    word))

; 32-bit emit
(defun emit32 (bits &rest args)
  (let ((word (apply #'emit bits args)))
    (list (logand word #xffff) (logand (ash word -16) #xffff))))

; Errors
(defun error* (txt) (format t "(pc=#x~x) ~a~%" *pc* txt))

; Test range of immediate signed values
(defun immp (x b)
  (<= (- (ash 1 (1- b))) x (1- (ash 1 (1- b)))))

; Extract bitfield
(defun bits (x a &optional b)
  (if b (logand (ash x (- b)) (1- (ash 1 (- a b -1))))
    (logand (ash x (- a)) 1)))

(defun offset (label) (- label *pc*))

; Instruction formats

(defun reg (funct7 rs2 rs1 funct3 rd op)
  (emit32 '(7 5 5 3 5 7) funct7 (regno rs2) (regno rs1) funct3 (regno rd) op))

(defun creg (op3 op1 op2 rd op2b rs2)
  (cond
   ((and (cregp rd) (cregp rs2))
    (emit '(3 1 2 3 2 3 2) op3 op1 op2 (cregno rd) op2b (cregno rs2) 1))
   (t (error* "C won't fit"))))

(defun immed (imm12 rs1 funct3 rd op)
  (cond
   ((immp imm12 12)
    (emit32 '(12 5 3 5 7) (logand imm12 #xfff) (regno rs1) funct3 (regno rd) op))
   (t
    (error* "Immediate value out of range"))))

(defun cimmed (imm12 rs1 funct3 rd op)
  (emit32 '(12 5 3 5 7) imm12 (regno rs1) funct3 (regno rd) op))

(defun branch (imm12 rs2 rs1 funct3 funct7)
  (let ((off (offset imm12)))
    (emit32 '(1 6 5 5 3 4 1 7) 
           (bits off 12) (bits off 10 5) (regno rs2) 
           (regno rs1) funct3 (bits off 4 1) (bits off 11) funct7)))

(defun jump (imm20 imm10-1 imm11 imm19-12 rd op)
  (emit32 '(1 10 1 8 5 7) imm20 imm10-1 imm11 imm19-12 rd op))

(defun muldiv (rs2 rs1 funct3 rd funct7)
  (emit32 '(7 5 5 3 5 7) 1 (regno rs2) (regno rs1) funct3 (regno rd) funct7))

(defun store (imm src base op)
  (emit32 '(7 5 5 3 5 7) (bits imm 11 5) (regno src) (regno base) op (bits imm 4 0) #x23))

(defun cimm6 (rd imm op1 op2)
  (emit '(3 1 5 5 2) op1 (bits imm 5) (regno rd) (bits imm 4 0) op2))

(defun cimm6* (rd imm op1 op2 op3)
  (emit '(3 1 2 3 5 2) op1 (bits imm 5) op2 (cregno rd) (bits imm 4 0) op3))

;
; Alphabetical list of mnemonics
;

(defun $add (rd rs1 rs2)
  (cond
   ((eq rd rs1)
    (emit '(3 1 5 5 2) 4 1 (regno rd) (regno rs2) 2))
   (t (reg 0 rs2 rs1 0 rd #x33))))

(defun $addi (rd rs1 imm)
  (cond
   ((and (eq rd rs1) (immp imm 6))
    (cimm6 rd imm 0 1))
   ((and (= (regno rd) 2) (= (regno rs1) 2) (immp imm 10))
    (emit '(3 1 5 1 1 2 1 2) 3 (bits imm 9) 2 (bits imm 4) (bits imm 6) (bits imm 8 7) (bits imm 5) 1))
   (t (immed imm rs1 0 rd #x13))))

(defun $and (rd rs1 rs2)
  (cond
   ((and (eq rd rs1) (cregp rd) (cregp rs2))
    (creg 4 0 3 rd 3 rs2))
   (t (reg 0 rs2 rs1 7 rd #x33))))

(defun $andi (rd rs1 imm)
  (cond
   ((and (eq rd rs1) (cregp rd) (immp imm 5))
    (cimm6* rd imm 4 2 1))
   (t (immed imm rs1 7 rd #x13))))

(defun $auipc (rd imm)
  (cond
   ((zerop (logand imm #xfff))
    (emit32 '(20 5 7) (bits imm 31 12) (regno rd) #x17))
   (t (error* "auipc no good"))))

(defun $beq (rs1 rs2 imm12)
  (branch imm12 rs2 rs1 0 #x63))

(defun $beqz (rs imm)
  (let ((off (offset imm)))
    (cond
     ((and (immp off 8) (cregp rs))
      (emit '(3 1 2 3 2 2 1 2) 6 (bits off 8) (bits off 4 3) 
            (cregno rs) (bits off 7 6) (bits off 2 1) (bits off 5) 1))
     (t ($beq rs 'x0 imm)))))

(defun $bge (rs1 rs2 imm12)
  (branch imm12 rs2 rs1 5 #x63))

(defun $bgeu (rs1 rs2 imm12)
  (branch imm12 rs2 rs1 7 #x63))

(defun $bgez (rs1 imm12)
  ($bge rs1 'x0 imm12))

(defun $bgt (rs1 rs2 imm12)
  ($blt rs2 rs1 imm12))

(defun $bgtu (rs1 rs2 imm12)
  ($bltu rs2 rs1 imm12))

(defun $bgtz (rs1 imm12)
  ($blt 'x0 rs1 imm12))
    
(defun $ble (rs1 rs2 imm12)
  ($bge rs2 rs1 imm12))

(defun $bleu (rs1 rs2 imm12)
  ($bgeu rs2 rs1 imm12))

(defun $blez (rs2 imm12)
  ($bge 'x0 rs2 imm12))

(defun $blt (rs1 rs2 imm12)
  (branch imm12 rs2 rs1 4 #x63))

(defun $bltu (rs1 rs2 imm12)
  (branch imm12 rs2 rs1 6 #x63))

(defun $bltz (rs1 imm12)
  ($blt rs1 'x0 imm12))

(defun $bne (rs1 rs2 imm12)
  (branch imm12 rs2 rs1 1 #x63))

(defun $bnez (rs imm)
  (let ((off (offset imm)))
    (cond
     ((and (immp off 8) (cregp rs))
      (emit '(3 1 2 3 2 2 1 2) 7 (bits off 8) (bits off 4 3) 
            (cregno rs) (bits off 7 6) (bits off 2 1) (bits off 5) 1))
     (t ($bne rs 'x0 imm)))))

(defun $div (rd rs1 rs2)
  (muldiv rs2 rs1 4 rd #x33)) 

(defun $divu (rd rs1 rs2)
  (muldiv rs2 rs1 5 rd #x33))

(defun $divw (rd rs1 rs2)
  (muldiv rs2 rs1 4 rd #x3b))

(defun $divuw (rd rs1 rs2)
  (muldiv rs2 rs1 5 rd #x3b))

(defun $fence () (emit32 '(16 16) #x0ff0 #x000f))

(defun $j (label)
  (let ((off (offset label)))
      (emit '(3 1 1 2 1 1 1 3 1 2) 5 (bits off 11) (bits off 4) (bits off 9 8)
          (bits off 10) (bits off 6) (bits off 7) (bits off 3 1) (bits off 5) 1)))

; C.JAL is RV32 only
(defun $jal (rd &optional label)
  (when (null label) (setq label rd rd 'ra))
  (let ((off (offset label)))
    (emit32 '(1 10 1 8 5 7) (bits off 20) (bits off 10 1) (bits off 11) (bits off 19 12) (regno rd) #x6f)))

(defun $jalr (label lst)
  (let ((off (+ (offset label) 4)))
    (emit32 '(12 5 3 5 7) (bits off 11 0) (regno (car lst)) 0 (regno (car lst)) #x67)))

(defun $jr (rs1)
  (emit '(3 1 5 5 2) 4 0 (regno rs1) 0 2))

; In next four, imm can be omitted and defaults to 0
(defun $lb (rd imm &optional lst)
  (unless lst (setq lst imm imm 0))
  (immed imm (car lst) 0 rd 3))

(defun $lbu (rd imm &optional lst)
  (unless lst (setq lst imm imm 0))
  (immed imm (car lst) 4 rd 3))

(defun $lh (rd imm &optional lst)
  (unless lst (setq lst imm imm 0))
  (immed imm (car lst) 1 rd 3))

(defun $lhu (rd imm &optional lst)
  (unless lst (setq lst imm imm 0))
  (immed imm (car lst) 5 rd 3))

; li pseudoinstruction - will load 32-bit immediates
(defun $li (rd imm)
  (cond
   ((immp imm 6) ; 16 bit
    (cimm6 rd imm 2 1))
   ((immp imm 12) ; 32 bit
    ($addi rd 'x0 imm))
   (t (let ((imm12 (logand imm #x00000fff)) ; 64 bit
            (imm20 (logand (ash imm -12) #xfffff)))
        (append
         ($lui rd (if (= (logand imm12 #x800) #x800) (+ imm20 #x1000) imm20))
         ; $addi
         (emit32 '(12 5 3 5 7) imm12 (regno rd) 0 (regno rd) #x13))))))

(defun $lui (rd imm)
  (cond
   ((and (immp imm 6) (/= imm 0) (/= (regno rd) 0) (/= (regno rd) 2)) ; 16 bit
    (cimm6 rd imm 3 1))
   (t
    (emit32 '(20 5 7) imm (regno rd) #x37))
   (t (error* "lui no good"))))

(defun $lw (rd imm lst)
  (cond
   ((listp lst)
    (let ((base (car lst)))
      (cond
       ; rs1 = sp
       ((and (= (regno base) 2))
        (emit '(3 1 5 3 2 2) 2 (bits imm 5) (regno rd) (bits imm 4 2) (bits imm 7 6) 2))
       ; rs1 = general
       ((and (cregp rd) (cregp base))
        (emit '(3 3 3 1 1 3 2) 2 (bits imm 5 3) (cregno base) (bits imm 2) (bits imm 6) (cregno rd) 0))
       (t (immed imm base 2 rd 3)))))
   (t (error* "Illegal 3rd arg"))))

(defun $mul (rd rs1 rs2)
  (muldiv rs2 rs1 0 rd #x33))

(defun $mulh (rd rs1 rs2)
  (muldiv rs2 rs1 1 rd #x33))  

(defun $mulhsu (rd rs1 rs2)
  (muldiv rs2 rs1 2 rd #x33)) 

(defun $mulhu (rd rs1 rs2)
  (muldiv rs2 rs1 3 rd #x33))

(defun $mv (rd rs1)
  (emit '(3 1 5 5 2) 4 0 (regno rd) (regno rs1) 2))

(defun $neg (rd rs2)
  ($sub rd 'x0 rs2))

(defun $nop ()
  ($addi 'x0 'x0 0))

(defun $not (rd rs1)
  ($xori rd rs1 -1))

(defun $or (rd rs1 rs2)
  (cond
   ((and (eq rd rs1) (cregp rd) (cregp rs2))
    (creg 4 0 3 rd 2 rs2))
   (t (reg 0 rs2 rs1 6 rd #x33))))

(defun $ori (rd rs1 imm)
  (immed imm rs1 6 rd #x13))

(defun $rem (rd rs1 rs2)
  (muldiv rs2 rs1 6 rd #x33))

(defun $remu (rd rs1 rs2)
  (muldiv rs2 rs1 7 rd #x33))

(defun $ret ()
  ($jr 'ra))

; In $sb, $sh, and $sw, imm can be omitted and defaults to 0
(defun $sb (src imm &optional lst)
  (unless lst (setq lst imm imm 0))
  (store imm src (car lst) 0))

(defun $seqz (rd rs1)
  ($sltiu rd rs1 1))

(defun $sgtz (rd rs2)
  ($slt rd 'x0 rs2))

(defun $sh (src imm &optional lst)
  (unless lst (setq lst imm imm 0))
  (store imm src (car lst) 1))

(defun $sll (rd rs1 rs2)
  (reg 0 rs2 rs1 1 rd #x33))

(defun $slli (rd rs1 imm)
  (cond
   ((and (eq rd rs1))
    (cimm6 rd imm 0 2))
   (t (emit32 '(6 6 5 3 5 7) 0 imm (regno rs1) 1 (regno rd) #x13))))

(defun $slt (rd rs1 rs2)
  (reg 0 rs2 rs1 2 rd #x33))

(defun $slti (rd rs1 imm)
  (immed imm rs1 2 rd #x13))

(defun $sltiu (rd rs1 imm)
  (immed imm rs1 3 rd #x13))

(defun $sltu (rd rs1 rs2)
  (reg 0 rs2 rs1 3 rd #x33))

(defun $sltz (rd rs1)
  ($slt rd rs1 'x0))

(defun $snez (rd rs2)
  ($sltu rd 'x0 rs2))

(defun $sra (rd rs1 rs2)
  (reg #x20 rs2 rs1 2 rd #x33))

(defun $srai (rd rs1 imm)
  (cond
   ((and (eq rd rs1) (cregp rd))
    (cimm6* rd imm 4 1 1))
   (t (emit32 '(6 6 5 3 5 7) #x10 imm (regno rs1) 5 (regno rd) #x13))))

(defun $srl (rd rs1 rs2)
  (reg 0 rs2 rs1 5 rd #x33))

(defun $srli (rd rs1 imm)
  (cond
   ((and (eq rd rs1) (cregp rd))
    (cimm6* rd imm 4 0 1))
   (t (emit32 '(6 6 5 3 5 7) 0 imm (regno rs1) 5 (regno rd) #x13))))

(defun $sub (rd rs1 rs2)
  (cond
   ((and (eq rd rs1) (cregp rd) (cregp rs2))
    (creg 4 0 3 rd 0 rs2))
   (t (reg #x20 rs2 rs1 0 rd #x33))))

(defun $sw (src imm &optional lst)
  (unless lst (setq lst imm imm 0))
  (let ((base (car lst)))
    (cond
     ; base = sp
     ((and (= (regno base) 2))
      (emit '(3 4 2 5 2) 6 (bits imm 5 2) (bits imm 7 6) (regno src) 2))
     ; base = general
     ((and (cregp src) (cregp base))
      (emit '(3 3 3 1 1 3 2) 6 (bits imm 5 3) (cregno base) (bits imm 2) (bits imm 6) (cregno src) 0))
     (t (store imm src base 2)))))

(defun $xor (rd rs1 rs2)
  (cond
   ((and (eq rd rs1) (cregp rd) (cregp rs2))
    (creg 4 0 3 rd 1 rs2))
   (t (reg 0 rs2 rs1 4 rd #x33))))

(defun $xori (rd rs1 imm)
  (immed imm rs1 4 rd #x13))