(herald (assembler lap t 59))

#|

For lap processing, each machine has these global tables:
 -  pseudo operations
 -  pseudo operands
 -  lap environment, a.k.a "machine-ops-table"

There ought to be versions of these that are local to each assembly.

The most conspicuous place for local versions is in the pseudo-ops EQUATE,
and REGISTER-EQUATE which currently affect the global lap-env table.  (They
are written to use *define-lap-local, but that currently is the same as 
*define-lap-global.)  

Register names appear in the lap-env and map to distinguished register
tokens.  When the lap transducer "evals" an operand and gets a register
token, it uses the procedure (machine-coerce-lap-reg <machine>) to
transform this to the value to use for the register (usually an fg or
number).  *DEFINE-LAP-REGISTER makes new register tokens - this should only
happen in the machine description.  New register names should be added as
in the REGISTER-EQUATE pseudo-op.  (Except REGISTER-EQUATE is supposed to
be local, and you may want a global set of new register names.)

Some entries in the lap-env (those defined with DEFINE-OP) are also in the
machine-ops-vector for quick access.  This is a hack.

|#
    
;;; ---------------- Lap processor.

;;; Define a variable in the lap environment for the given machine 

(define (*define-lap-global machine sym val)
  (set (table-entry (machine-ops-table machine) sym) val))

(define (*define-pseudo-global machine name proc)
  (set (table-entry (machine-pseudo-ops machine) name) proc))

(define *define-lap-local *define-lap-global)
(define *define-pseudo-local *define-pseudo-global)

;;; Walk the lap items, noting labels, and filling in jumps.

;;; Needed error checking:  emit-tag on existant tag, emits after emit-jump
;;; emit-jump after emit-jump.

(define (process-lap-list items section current-ib)
  (let* ((machine (assembly-section-machine section))
         (p-ops   (machine-pseudo-ops machine)))
    (iterate loop ((items items)
                   (ib current-ib))
      (cond ((null? items) ib)
            (else
             (let ((i (car items)))
               (cond ((pair? i)      ;  --instruction
                      (let ((val (cond ((table-entry p-ops (car i))
                                        => (lambda (p) (p i section ib)))
                                       (else
                                        (process-lap-item i section machine)))))
                        (cond ((ib? val)
                               (loop (cdr items) val))
                              (else
                               (if (fg? val) (as-emit ib val))
                               (loop (cdr items) ib)))))

                     ((string? i)     ; --comment
                      (as-comment ib i)
                      (loop (cdr items) ib))
                     
                     ((symbol? i)     ; --tag
                      (let ((prev ib)
                            (next (new-as-tag section i)))

                        ;(cond (reorder-blocks?
                        ;       (if (empty? (ib-jump-op prev))
                        ;          (as-emit-jump prev jump-op/jabs new nil)))
                        ;      (else
                        ;       (maybe-set-ib-follower prev next)))
                        (set (ib-name next) i)

                        (maybe-set-ib-follower prev next)
                        (loop (cdr items) next)))
                     
                     (else
                      (error " - from lap - cannot process: ~s" i) ))))))))

;;; Process the operands, then apply the operator to get an fg.
;;; For operands, evaluate the form in the lap-env, except that numbers are
;;; registers.  Pseudo-operands are handled specially 

(define (process-lap-item item section machine)
  (let ((env (machine-lap-env machine))
        (p-opnds (machine-pseudo-operands machine)))
    (do ((as (cdr item) (cdr as))
         (vs '() (let ((opd (car as)))
                   (cons (cond ((and (pair? opd)
                                     (table-entry p-opnds (car opd)))
                                => (lambda (p) (p opd section)))
                               (else
                                (lap-eval-top opd env section)))
                         vs))))
        ((null? as)
         (apply (lap-eval (car item) env section) (reverse! vs))))))

;;; Little evaluator for lap expressions.  Does quote, constants, and
;;; applications 

(define (lap-eval exp env sec)
  (lap-eval-1 exp env sec '#f))

(define (lap-eval-top exp env sec)
  (lap-eval-1 exp env sec '#t))

(define (lap-eval-1 exp env section top-level?)
  (cond ((or (eq? exp '#t) (eq? exp '#f) (char? exp) (integer? exp)) exp)
        ((symbol? exp)
         (let ((probe (table-entry env exp)))
           (cond ((register-marker? probe)
                  ((machine-coerce-lap-reg (assembly-section-machine section))
                   (register-marker-index probe)
                   top-level?))
                 (probe probe)
                 (else
                  (no-lap-value exp)))))
        ((pair? exp)
         (lap-eval-combination exp env section))
        (else
         (error "can't lap eval: ~s" exp))))

(define (no-lap-value exp)
  (error "no lap value: ~s" exp))

(define (lap-eval-combination exp env section)
  (let ((key (car exp))
        (args (cdr exp)))
    (case key
      ((quote) (car args))
      ((tag) (fixnum-ashr (ib-address (as-tag section (car args))) 3))
      ((expr)
       (lambda (x)
         (lap-eval (car args) env section)))
      (else
       (let ((vals (map (lambda (x) (lap-eval x env section)) exp)))
         (apply (car vals) (cdr vals)))))))

;;; ---------------- For testing

(define (test-lap items machine)
  (let ((section (cons-assembly-section machine)))
    (let ((current-ib (as-tag section (generate-symbol 'lap-entry))))
      (process-lap-list items section current-ib)
      section)))
                 
;;; ---------------- Registers

;;; Each machine defines a mapping of register name -> index.  [The index
;;; need not be a number, though is usually is.]  When the lap processor
;;; encounters a register name, it calls the (machine-lap-register machine)
;;; procedure to convert the index into whatever is appropriate.  The
;;; converter is called with the index and a flag indicating is the
;;; register name was "top level".  The typical action is for "top level"
;;; register names to be converted to the appropriate register field group,
;;; and for non top level register names to be converted to an appropriate
;;; integer.  This makes is possible to write lap code like
;;;   (MOVE .L D0 (D@A A0 1))
;;; whereas the interface the assembler would most naturally provide
;;; would look like
;;;   (MOVE .L (D 0) (D@A 0 1))
;;; [which is the way I would have left it had it been entirely up to me].

(define-structure-type register-marker index)

(define (cons-register-marker i)
  (let ((m (make-register-marker)))
    (set (register-marker-index m) i)
    m))

(define (*define-lap-register machine name i)
  (set (table-entry (machine-lap-env machine) name) (cons-register-marker i)))

;;; ---------------- For the lap environment

(define (jump-op-emitter jump-op)
  (real-jump-op-emitter jump-op '#f))

(define (jabs-emitter jump-op)
  (real-jump-op-emitter jump-op '#t))

(define (real-jump-op-emitter jump-op jabs?)
  (lambda (form section ib)
    (destructure (((symbolic-jump-op 1label) form))
      (if (not (symbol? 1label)) (error "jump op emitter expects a symbol"))
      (let ((next-label (generate-symbol 'lap-jump)))
        (as-emit-jump section ib jump-op 1label
                      (if jabs? '#f next-label))
        (as-tag section next-label)))))

(define (include-vanilla-pseudo-ops machine)
  (walk (lambda (i)
          (set (table-entry (machine-pseudo-ops machine) (car i)) (cdr i)))
        `(
          (equate . ,(lambda (form sec ib)
                       (destructure (((equate id expr) form))
                         (*define-lap-local machine id
                                            (lap-eval expr
                                                      (machine-lap-env machine)
                                                      sec)))))
          (align-tag . ,(lambda (form sec ib)
                          (destructure (((a-tag label max mask offset) form))
                            (let ((next-tag (as-tag sec label)))
                              (set (ib-align next-tag) (list max mask offset))
                              next-tag))))

          (align . ,(lambda (form sec ib)
                      (destructure (((align max mask offset) form))
                        (let ((next-tag (as-tag sec (generate-symbol align))))
                          (set (ib-align next-tag) (list max mask offset))
                          next-tag))))

          (block . ,(lambda (form sec ib)
                      (destructure (((block . forms) form))
                        (last (map (lambda (e)
                                     (lap-eval e (machine-lap-env machine) sec))
                                   forms)))))

          ;; for use in making comi from stand-alone assembler
          (global .  ,(lambda (form section ib)
                        (destructure (((global lab) form))
                          (push (assembly-section-globals section) lab)
                          0)))
          )))