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

;;;; PowerPC LAP Environment

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

;;; This file must be loaded after ppc_machine.t.

(include-vanilla-pseudo-ops powerpc)

(define (*define-ppc-global id value)
  (*define-lap-global powerpc id value))

(define (*define-ppc-pseudo id value)
  (set (table-entry (machine-pseudo-ops powerpc) id)
       value))

; (put '*define-ppc-global 'scheme-indent-function 1)
; (put '*define-ppc-pseudo 'scheme-indent-function 1)

(define (ppc-lap-eval exp section)
  (lap-eval exp (machine-lap-env powerpc) section))

(define (ppc-op id)
  (table-entry (machine-ops-table powerpc) id))

(walk (lambda (x) (apply *define-ppc-global x))
      `(
        ;; Registers
        (R        ,ppc-reg/general)     ; operator position
        (FR       ,ppc-reg/float)       ; operator position
        (CR       ,(named-lambda CR (x)
                     (no-op (enforce (fixnum-of-bits? 3) x))))
        (ZERO     ,ppc-reg/zero)
        (XER      ,ppc-reg/xer)
        (LINK     ,ppc-reg/link)
        (COUNTER  ,ppc-reg/counter)
        (CTR      ,ppc-reg/counter)

        ;; Operands
        (D@R ,d@r)
        ($   ,(named-lambda $ (x) (no-op (enforce fixnum? x))))

        ;; Arithmetic operations
        (+  ,add)
        (-  ,subtract)
        (*  ,multiply)
        (/  ,quotient)
        (<< ,fixnum-ashl)
        (>> ,fixnum-ashr)
        ))

(let ((*define-regset
       (lambda (prefix count index->register)
         (do ((i 0 (fx+ i 1)))
             ((= i count))
           (*define-ppc-global (concatenate-symbol prefix i)
                               (index->register i))))))
  (*define-regset 'R 32 ppc-reg/general)
  (*define-regset 'FR 32 ppc-reg/float)
  (*define-regset 'CR 8 identity))

(walk (lambda (width)
        (destructure (((long short) width))
          (*define-ppc-global long long)
          (*define-ppc-global short long)))
      '((single   :s)
        (double   :d)
        (byte     :b)
        (halfword :h)
        (word     :w)))

(define (ppc-jabs-emitter op)
  (lambda (form section ib)
    (destructure (((#f tag) form))
      (let ((next-label (generate-symbol 'lap-label)))
        (as-emit-jump section ib (make-ppc-jabs-op (ppc-op op))
                      tag '#f)
        (as-tag section next-label)))))

(walk (lambda (op)
        (*define-ppc-pseudo op (ppc-jabs-emitter op)))
      '(b ba bl bla))

(define (ppc-jump-emitter op predict?)
  (lambda (form section ib)
    (destructure (((#f bc-op cr-index tag) form))
      (let ((next-label (generate-symbol 'lap-label)))
        (as-emit-jump section ib
                      (lap-ppc-jump-op op bc-op predict? cr-index
                                       section)
                      tag next-label)
        (as-tag section next-label)))))

(define (lap-ppc-jump-op op bc-op predict? cr-index section)
  (make-ppc-jump-op (ppc-op op) (ppc-lap-eval bc-op section) predict?
                    (ppc-lap-eval cr-index section)))

(define (ppc-jump-emitter* op predict? cr-index)
  (lambda (form section ib)
    (destructure (((#f cr-field tag) form))
      (let ((next-label (generate-symbol 'lap-label)))
        (as-emit-jump section ib
                      (lap-ppc-jump-op* op (make-cr-bc-op '#t)
                                        predict?
                                        cr-field cr-index
                                        section)
                      tag next-label)
        (as-tag section next-label)))))

(define (ppc-reverse-jump-emitter* op predict? cr-index)
  (lambda (form section ib)
    (destructure (((#f cr-field tag) form))
      (let ((next-label (generate-symbol 'lap-label)))
        (as-emit-jump section ib
                      (lap-ppc-jump-op* op (make-cr-bc-op '#f)
                                        predict?
                                        cr-field cr-index
                                        section)
                      tag next-label)
        (as-tag section next-label)))))

(define (lap-ppc-jump-op* op bc-op predict? cr-field cr-index section)
  (make-ppc-jump-op (ppc-op op) bc-op predict?
                    (assemble-fixnum (fx 3 (ppc-lap-eval cr-field
                                                         section))
                                     (fx 2 cr-index))))

(walk (lambda (op)
        (*define-ppc-pseudo op (ppc-jump-emitter op '#f))
        (*define-ppc-pseudo (concatenate-symbol op '\,P)
          (ppc-jump-emitter op '#t))
        (walk (lambda (spec)
                (destructure (((suffix rev-suffix bit) spec))
                  (*define-ppc-pseudo
                      (concatenate-symbol op suffix)
                    (ppc-jump-emitter* op '#f bit))
                  (*define-ppc-pseudo
                      (concatenate-symbol op suffix '\,P)
                    (ppc-jump-emitter* op '#t bit))
                  (cond (rev-suffix
                         (*define-ppc-pseudo
                             (concatenate-symbol op rev-suffix)
                           (ppc-reverse-jump-emitter* op '#f bit))
                         (*define-ppc-pseudo
                             (concatenate-symbol op rev-suffix '\,P)
                           (ppc-reverse-jump-emitter* op '#t bit))))))
              '((< >= 0)
                (> <= 1)
                (= /= 2)
                (-so #f 3)              ; summary overflow (XER[0])
                (-NaN #f 3))))
      '(bc bca bcl bcla))

;;; Even though these are regular instruction emitters (not jump
;;; emitters), we need to define pseudo-operations because of the
;;; optional prediction argument, which is specified by ,P or its
;;; absence in LAP.

(define (ppc-non-tag-jump-emitter op predict?)
  (lambda (form section ib)
    (destructure (((#f bc-op cr-index) form))
      (as-emit ib ((ppc-op op) (ppc-lap-eval bc-op section)
                               predict?
                               (ppc-lap-eval cr-index section))))))

(walk (lambda (op)
        (*define-ppc-pseudo op (ppc-non-tag-jump-emitter op '#f))
        (*define-ppc-pseudo (concatenate-symbol op '\,P)
          (ppc-non-tag-jump-emitter op '#t)))
      '(bclr bclrl bcctr bcctrl))