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

;;;; PowerPC Machine Description

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

;;; Should be: 4 bytes/clump, 8 bits/byte, low clumps first
;;; But fixnums don't have 32 bits, so we divide it into 2 bytes per
;;; clump instead.

(define (ppc/write-clumps clumps clump-count bytev bytev-start)
  (do ((cl-i 0 (fx+ cl-i 1))
       (bv-i bytev-start (fx+ bv-i 2)))
      ((fx>= cl-i clump-count)
       bv-i)
    (let ((clump (swap (vector-elt clumps cl-i) 0)))
      (set (bref-8-u bytev      bv-i)    (fx-ashr clump 8))
      (set (bref-8-u bytev (fx+ bv-i 1))          clump))))

(define powerpc
        (cons-machine 1                 ; dummy op count
                      16                ; clump size in bits
                      32                ; number of clumps (?)
                      (lambda (reg top?) (ignore top?) reg)
                      (lambda (clumps clump-count bytev bytev-start)
                        (ppc/write-clumps clumps clump-count bytev
                                          bytev-start))))

(define-syntax (define-ppc-op id.bvl . body)
  (let* ((id (car id.bvl))
         (ppc/id (concatenate-symbol 'PPC/ id)))
    `(BLOCK (DEFINE (,ppc/id . ,(cdr id.bvl)) ,@body)
            (*DEFINE-OP POWERPC 0 ',id ,ppc/id))))

;;;; PPC Registers

(define-structure-type %register
  string
  code
  index
  (((register? self) '#t)
   ((*register-code   (self struct)) (%register-code   struct))
   ((*register-index  (self struct)) (%register-index  struct))
   (( register-string (self struct)) (%register-string struct))
   ((print (self struct) port)
    (format port "#{PPC-register~_~S~_~A}"
            (%register-index struct)
            (register-string self)))
   ((display self port)
    (write-string port (register-string self)))))

(define-predicate register?)

;;; Weird operation dispatch here for totally premature optimization.

(define-local-syntax (define-regop name)
  `(BLOCK (DEFINE-OPERATION (,(concatenate-symbol '* name) REG))
          (DEFINE-INTEGRABLE (,name REG)
            (IF (%REGISTER? REG)
                (,(concatenate-symbol '% name) REG)
                (,(concatenate-symbol '* name) REG)))))

(define-regop register-code)
(define-regop register-index)

(define-operation (register-string reg))

(define (make-register string code)
  (let ((index *ppc-register-index*))
    (if index
        (let ((reg (make-%register)))
          (set *ppc-register-index* (fx+ index 1))
          (set (%register-string reg) string)
          (set (%register-code   reg) code)
          (set (%register-index  reg) index)
          (set (%ppc-register  index) reg)
          reg)
        (error '("no new PPC registers may be constructed~%"
                 "**~10T~S")
               `(MAKE-REGISTER ,string ,code ,index)))))

(lset *ppc-register-index* 0)

(define %ppc-register (make-infinite-vector 32 nil 'ppc-register))
(define-integrable (ppc-register index) (%ppc-register index))

(define-local-syntax (define-regset prefix count vector-name pred-name
                       accessor-name)
  `(BLOCK (DEFINE ,vector-name (MAKE-VECTOR ,count))
          (DEFINE-PREDICATE ,pred-name)
          (DEFINE-INTEGRABLE (,accessor-name N)
            (VECTOR-ELT ,vector-name N))
          (DO ((I 0 (FX+ I 1)))
              ((FX= I ,count))
            (SET (VECTOR-ELT ,vector-name I)
                 (JOIN (OBJECT NIL
                               ((,pred-name SELF) '#T))
                       (MAKE-REGISTER
                        (FORMAT NIL "~A~D"
                                ,(string-downcase!
                                  (symbol->string prefix))
                                I)
                        I))))))

(define-regset r 32 ppc-general-purpose-registers ppc-reg/general?
  ppc-reg/general)

(define-constant ppc-reg/zero (ppc-reg/general 0))

(define-regset fr 32 ppc-floating-point-registers ppc-reg/float?
  ppc-reg/float)

(define ppc-reg/xer     (make-register "XER" #b0000000001))
(define ppc-reg/link    (make-register "LR"  #b0000001000))
(define ppc-reg/counter (make-register "CTR" #b0000001001))

(define ppc-register-count *ppc-register-index*)
(set *ppc-register-index* nil)

(define-integrable (make-ppc-register-vector)
  (make-vector ppc-register-count))