(herald (assembler ppc_format)
  (env t
       (assembler as_open))
  (syntax-table tas-ppc-syntax-table))

;;;; PowerPC Instruction Formats & Addressing Modes

;;; Copyright (C) 2005, Taylor Campbell
;;; All rights reserved.
;;; See the LICENCE file for details.

;;;; Arithmetic Instruction Formats

(define-fg (ppc/arith-format rD (rA-or-0 rA) rB primary secondary
                             printer)
  (print (p) (printer p rD rA rB))
  (fields (fixed 6 primary)
          (fixed 5 (register-code rD))
          (fixed 5 (register-code rA))
          (fixed 5 (register-code rB))
          (fixed 11 secondary)))

(define-syntax (define-arith-op id primary secondary)
  `(DEFINE-PPC-OP (,id rD rA rB)
     (PPC/ARITH-FORMAT rD rA rB
                       ,primary ,secondary
                       (LAMBDA (PORT rD rA rB)
                         (FORMAT PORT "~A ~A,~A,~A"
                                 ',(id->string id)
                                 rD rA rB)))))

(define-syntax (define-arith-op* id secondary)
  `(DEFINE-ARITH-OP ,id #B011111 ,secondary))

(define-syntax (define-arith-unop id secondary)
  `(DEFINE-PPC-OP (,id rD rA)
     (PPC/ARITH-FORMAT rD rA PPC-REG/ZERO
                       #B011111 ,secondary
                       (LAMBDA (PORT rD rA rB)
                         (IGNORE rB)    ; It will always be zero.
                         (FORMAT PORT "~A ~A,~A"
                                 ',(id->string id)
                                 rD rA)))))

(define-syntax (define-arith-ops id secondary . defarithop)
  (let ((secondary (fx-ashl secondary 1))
        (defarithop (if (null? defarithop)
                        'DEFINE-ARITH-OP*
                        (car defarithop))))
    `(BLOCK (,defarithop ,id ,secondary)               ; vanilla
            (,defarithop ,(concatenate-symbol id ".")  ; compare
                         ,(fx-ior secondary 1))
            (,defarithop ,(concatenate-symbol id 'o)   ; overflow
                         ,(fx-ior secondary (fx-ashl 1 10)))
            (,defarithop ,(concatenate-symbol id 'o.)  ; both
                         ,(fx-ior secondary
                                  (fx-ior 1 (fx-ashl 1 10)))))))

;;;;; Arithmetic-with-Immediate Formats

(define-fg (ppc/arith-imm-format rD (rA-or-0 rA) imm opcode printer)
  (print (p) (printer p rD rA imm))
  (fields (fixed 6 opcode)
          (fixed 5 (register-code rD))
          (fixed 5 (register-code rA))
          (fixed 16 imm)))

(define-syntax (define-arith-imm-op id opcode . printer)
  `(DEFINE-PPC-OP (,id rD rA IMM)
     (PPC/ARITH-IMM-FORMAT rD rA IMM
                           ,opcode
                           ,(if (null? printer)
                                `(LAMBDA (PORT rD rA IMM)
                                   (FORMAT PORT "~A ~A,~A,~A"
                                           ',(id->string id)
                                           rD rA IMM))
                                (car printer)))))

;;;; Comparison Instruction Formats

(define-fg (ppc/cmp-format opcode cr-field rA operand name)
  (printer "~A cr~A,~A,~G" name cr-field rA operand)
  (fields (fixed 6 opcode)
          (fixed 3 cr-field)
          (0 0)
          (fixed 5 (register-code rA))
          (subfield operand)))

(define-fg (ppc/cmp-reg-operand reg secondary)
  (printer "~A" reg)
  (fields (fixed 5 (register-code reg))
          (fixed 10 secondary)
          (0)))

(define-fg (ppc/cmp-imm-operand imm)
  (printer "#x~X" imm)
  (fields (fixed 16 imm)))

;;;; Floating-Point Instruction Formats

(define-fg (ppc/ternary-flop opcode rD rA rB rC secondary rc-bit
                             printer)
  (print (p) (printer p rD rA rB rC rc-bit))
  (fields (fixed 6 opcode)
          (fixed 5 (register-code rD))
          (fixed 5 (register-code rA))
          (fixed 5 (register-code rB))
          (fixed 5 (register-code rC))
          (fixed 5 secondary)
          (fixed 1 rc-bit)))

(define-fg (ppc/unary-flop opcode rD rA rB secondary rc-bit printer)
  (print (p) (printer p rD rA rB rc-bit))
  (fields (fixed 6 opcode)
          (fixed 5 (register-code rD))
          (0 0 0 0 0)
          (fixed 5 (register-code rB))
          (fixed 10 secondary)
          (fixed 1 rc-bit)))

;++ These depend on (LET (...) (DEFINE ...)) working in T, which at the
;++ moment happens to be the case but which may change.

(define-syntax (define-unary-flop id opcode secondary)
  `(LET ((PRINT (LAMBDA (PORT rD rA rB RC-BIT)
                  (IGNORE rA)
                  (FORMAT PORT "~A~A ~A,~A"
                          ',(id->string id)
                          (IF (FX-ZERO? RC-BIT) "" ".")
                          rD rB))))
     (DEFINE-PPC-OP (,id rD rB)
       (PPC/UNARY-FLOP ,opcode rD PPC-REG/ZERO rB ,secondary 0 PRINT))
     (DEFINE-PPC-OP (,(concatenate-symbol id ".") rD rB)
       (PPC/UNARY-FLOP ,opcode rD PPC-REG/ZERO rB ,secondary 1
                       PRINT))))

;;; Two variants for binary flops, depending on whether the instruction
;;; expects an rB or an rC operand.  (Don't ask me why they differ.)

(define-syntax (define-binaryB-flop id opcode secondary)
  `(LET ((PRINT (LAMBDA (PORT rD rA rB rC RC-BIT)
                  (IGNORE rC)
                  (FORMAT PORT "~A~A ~A,~A,~A"
                          ',(id->string id)
                          (IF (FX-ZERO? RC-BIT) "" ".")
                          rD rA rB))))
     (DEFINE-PPC-OP (,id rD rA rB)
       (PPC/TERNARY-FLOP ,opcode rD rA rB PPC-REG/ZERO ,secondary 0
                         PRINT))
     (DEFINE-PPC-OP (,(concatenate-symbol id ".") rD rA rB)
       (PPC/TERNARY-FLOP ,opcode rD rA rB PPC-REG/ZERO ,secondary 1
                         PRINT))))

(define-syntax (define-binaryC-flop id opcode secondary)
  `(LET ((PRINT (LAMBDA (PORT rD rA rB rC RC-BIT)
                  (IGNORE rB)
                  (FORMAT PORT "~A~A ~A,~A,~A"
                          ',(id->string id)
                          (IF (FX-ZERO? RC-BIT) "" ".")
                          rD rA rC))))
     (DEFINE-PPC-OP (,id rD rA rC)
       (PPC/TERNARY-FLOP ,opcode rD rA PPC-REG/ZERO rC ,secondary 0
                         PRINT))
     (DEFINE-PPC-OP (,(concatenate-symbol id ".") rD rA rC)
       (PPC/TERNARY-FLOP ,opcode rD rA PPC-REG/ZERO rC ,secondary 1
                         PRINT))))

(define-syntax (define-ternary-flop id opcode secondary)
  `(LET ((PRINT (LAMBDA (PORT rD rA rB rC RC-BIT)
                  (FORMAT PORT "~A~A ~A,~A,~A,~A"
                          ',(id->string id)
                          (IF (FX-ZERO? RC-BIT) "" ".")
                          rD rA rB rC))))
     (DEFINE-PPC-OP (,id rD rA rB rC)
       (PPC/TERNARY-FLOP ,opcode rD rA rB rC ,secondary 0 PRINT))
     (DEFINE-PPC-OP (,(concatenate-symbol id ".") rD rA rB rC)
       (PPC/TERNARY-FLOP ,opcode rD rA rB rC ,secondary 1 PRINT))))

;;;; Miscellaneous

;;; Special-purpose register movement format

(define-fg (ppc/spr-move primary dest src1 src2 secondary rc printer)
  (print (port) (printer port))
  (fields (fixed 6 primary)
          (fixed 5 dest)
          (fixed 5 src1)
          (fixed 5 src2)
          (fixed 10 secondary)
          (fixed 1 rc)))

;;; Random operandless instructions like eieio & isync

(define-syntax (define-nullary-ppc-op id secondary)
  `(DEFINE-PPC-OP (,id)
     (PPC/ARITH-FORMAT PPC-REG/ZERO PPC-REG/ZERO PPC-REG/ZERO
                       #B011111 ,secondary
                       (LAMBDA (PORT rD rA rB)
                         (IGNORE rD rA rB)
                         (WRITE-STRING PORT ',(id->string id))))))

;;;; Memory Instruction Formats

(define-fg (ppc/memory-format opcode reg ea-field printer)
  (print (p) (printer p reg ea-field))
  (fields (fixed 6 opcode)
          (fixed 5 (register-code reg))
          (subfield ea-field)))

(define (ppc/d@r-memory-format reg ea imm-primary reg-secondary
                               printer)
  ;; Protect this XCOND with an ENFORCE outside.
  (xcond ((reg-d@r? ea)
          (ppc/memory-format #b011111 reg
                             (reg-d@r-fg ea reg-secondary)
                             printer))
         ((imm-d@r? ea)
          (ppc/memory-format imm-primary reg (imm-d@r-fg ea)
                             printer))))

(define-syntax (define-d@r-memory-op id imm-primary reg-secondary)
  `(DEFINE-PPC-OP (,id REG EA)
     (PPC/D@R-MEMORY-FORMAT REG EA ,imm-primary ,reg-secondary
                            (LAMBDA (PORT REG EA-FG)
                              (FORMAT PORT "~A ~A,~G"
                                      ',(id->string id)
                                      REG EA-FG)))))

(define-syntax (define-imm-d@r-memory-op id opcode)
  `(DEFINE-PPC-OP (,id REG EA)
     (PPC/MEMORY-FORMAT ,opcode REG (IMM-D@R-FG EA)
                        (LAMBDA (PORT REG EA-FG)
                          (FORMAT PORT "~A ~A,~G"
                                  ',(id->string id)
                                  REG EA-FG)))))

(define-syntax (define-reg-d@r-memory-op id secondary)
  `(DEFINE-PPC-OP (,id REG EA)
     (PPC/MEMORY-FORMAT #B011111 REG (REG-D@R-FG EA ,secondary)
                        (LAMBDA (PORT REG EA-FG)
                          (FORMAT PORT "~A ~A,~G"
                                  ',(id->string id)
                                  REG EA-FG)))))

;;;;; Effective Address Operands

(define-structure-type* reg-d@r
  (reg-d@r A B)
  ()
  (((display self port)
    (format port "~A,~A"
            (reg-d@r-A self)
            (reg-d@r-B self)))))

(define-structure-type* imm-d@r
  (imm-d@r base index)
  ()
  (((display self port)
    (format port "~A(~A)"
            (imm-d@r-index self)
            (imm-d@r-base  self)))))

(define-integrable (d@r? obj)
  (or (reg-d@r? obj)
      (imm-d@r? obj)))

(define (d@r reg displ)
  (let ((reg (rA-or-0 reg)))
    (cond ((register?            displ) (reg-d@r reg displ))
          (((fixnum-of-bits? 16) displ) (imm-d@r reg displ))
          (else (d@r reg
                     (error '("illegal PPC register indirect index~%"
                              "~S~%"
                              "expected register or 16-bit fixnum")
                            displ))))))

(define-fg (reg-d@r-fg ea secondary)
  (printer "~A" ea)
  (fields (fixed 5 (register-code (reg-d@r-A ea)))
          (fixed 5 (register-code (reg-d@r-B ea)))
          (fixed 10 secondary)
          (0)))

(define-fg (imm-d@r-fg ea)
  (printer "~A" ea)
  (fields (fixed 5 (register-code (imm-d@r-base ea)))
          (fixed 16 (imm-d@r-index ea))))

;;; Operand utility

(define (rA-or-0 rA)
  (cond ((register? rA) rA)
        ((eq? rA 0) ppc-reg/zero)
        (else (rA-or-0 (error "illegal PPC source register or 0 ~S"
                              rA)))))