;;;
;;; geninsn - generate VM instruction related files
;;;
;;;   Copyright (c) 2004-2014  Shiro Kawai  <shiro@acm.org>
;;;
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

;; Generate the following VM instruction related files from vminsn.scm
;;   vminsn.c
;;   gauche/vminsn.h
;;   ../lib/gauche/vm/insn.scm

(use gauche.cgen)
(use gauche.parameter)
(use gauche.sequence)
(use gauche.vm.insn-core)
(use gauche.mop.instance-pool)
(use srfi-13)
(use text.tr)
(use file.util)
(use util.match)
(use util.list)

(define (c-insn-name name)
  (string-append "SCM_VM_" (string-tr (x->string name) "-" "_")))

(define *preamble*
  (list #`"/* Generated automatically from vminsn.scm */"
        #`"/* DO NOT EDIT */"))

(define *unit*
  (make <cgen-unit>
    :name "vminsn"
    :preamble *preamble*
    :c-file "vminsn.c"
    :h-file "gauche/vminsn.h"
    :init-prologue ""
    :init-epilogue ""
    ))

;; Instructon information
(define (find-insn name insns)
  (find (^_ (eq? name (~ _'name))) insns))

;; LREF shortcuts.
(define-constant .lrefx.
  '(LREF0 LREF1 LREF2 LREF3 LREF10 LREF11 LREF12 LREF20 LREF21 LREF30))

;;=============================================================
;; Generate gauche.vm.insn
;;   We have a header in ../lib/gauche/vm/insn.scm.src.
;;

(define (gen-gauche.vm.insn insns)
  (define (write-header)
    (format #t ";; Generated from vminsn.scm.  DO NOT EDIT\n")
    (write '(define-module gauche.vm.insn (extend gauche.vm.insn-core)))
    (newline)
    (write '(select-module gauche.vm.insn))
    (newline))
  (define (write-insn insn)
    (format #t ";; #x~3,'0x  ~a\n" (~ insn'code) (~ insn'name))
    (format #t "(make <vm-insn-info> :name '~a :code ~a\n"
            (~ insn'name) (~ insn'code))
    (format #t "  :num-params ~a :alt-num-params '~a\n"
            (~ insn'num-params) (~ insn'alt-num-params))
    (format #t "  :operand-type '~a\n" (~ insn'operand-type))
    (format #t "  :obsoleted ~s\n" (~ insn'obsoleted))
    (format #t "  :fold-lref ~s\n" (~ insn'fold-lref))
    (format #t "  :combined '~s\n" (~ insn'combined))
    (format #t "  :body '~s)\n\n" (~ insn'body)))
  (with-output-to-file "../lib/gauche/vm/insn.scm"
    (^[]
      (write-header)
      (for-each write-insn insns)
      (newline))
    :if-exists :supersede)
  )

;;=============================================================
;; Generate VM inner loop
;;

;; These parameters are used by the cise expander defined in
;; vminsn.scm.
(define result-type (make-parameter 'reg)) ;reg, push, call or ret
(define arg-source (make-parameter #f))    ;#f, pop, reg, lref,
                                           ;  or (lref DEPTH OFFSET)
(define insn-alist (make-parameter '()))   ;target insn alist, used to
                                           ;  communicate to cise expander.

(define (construct-vmbody insns)
  (define (case-label insn)
    (cgen-body (format "\nlabel_~a~:*:\nCASE(SCM_VM_~a) "
                       (cgen-safe-name-friendly (x->string (~ insn'name))))))
  (define (base-cise base)
    (and-let* [(base-insn (find-insn base insns))]
      (~ base-insn'body)))
  (define (symbol-join syms)
    ($ string->symbol $ string-join (map x->string syms) "-"))
  (define (cise->string cise)
    (call-with-output-string (cut cise-render cise <>)))
  (define (lrefx->lref lrefx)
    (rxmatch-let (#/LREF(\d)?(\d)/ (x->string lrefx))
      (#f dep off)
      `(lref ,(x->integer dep) ,(x->integer off))))
  (define (render cise) (cgen-body #`"{,(cise->string cise)}") #t)
  (define (do-combined orig comb)
    (match comb
      [(base 'PUSH)
       (and-let* ([cise (base-cise base)])
         (parameterize ([result-type 'push]) (render cise)))]
      [(base 'RET)
       (and-let* ([cise (base-cise base)])
         (parameterize ([result-type 'ret]) (render cise)))]
      [(base (and (or 'CALL 'TAIL-CALL) next))
       (and-let* ([cise (base-cise base)])
         (parameterize ([result-type 'call]) (render cise))
         (render `($goto-insn ,next)))]
      [('PUSH . next)
       (render `(PUSH-ARG VAL0))
       (render `($goto-insn ,(symbol-join next)))]
      [('LREF0 'PUSH . next)
       (render `(let* ((v (ENV-DATA ENV 0))) (PUSH-ARG v)))
       (render `($goto-insn ,(symbol-join next)))]
      [((and (? (cut memq <> .lrefx.)) lrefx) . next)
       (parameterize ([arg-source (lrefx->lref lrefx)])
         (do-combined-rec orig next))]
      [('LREF . next)
       (parameterize ([arg-source 'lref]) (do-combined-rec orig next))]
      [_ #f]))
  (define (do-combined-rec orig comb)
    (or (and-let* ([insn (find-insn (symbol-join comb) insns)]) (render1 insn))
        (do-combined orig comb)
        (warn "Don't know how to generate combined insn ~a" (~ orig'name))))
  (define (render1 insn)
    (or (and-let* ([cise (~ insn'body)]) (render cise))
        (and-let* ([comb (~ insn'combined)]) (do-combined insn comb))
        (warn "Don't know how to generate ~a" (~ insn'name))))

  ;; main body of construct-vmbody
  (parameterize ([insn-alist (map (^_(cons (~ _'name) _)) insns)])
    (dolist [insn insns]
      (case-label insn)
      (render1 insn))))

;;==============================================================
;; Emit state-transition table for instruction combiner
;; The state transition table is basically a DFA, but we have some
;; tweaks to keep the size of the tables small.
;;
;; Each state is represented by a table, keyed by input insn codes.
;; Each value indicates an action and the next state.
;;
;; In the following description, we denote a table as [something],
;; and the input code as (something), and the output as {something}.
;;
;; Actions:
;;   NEXT    - output nothing, merely replaces the current state to the
;;             next state.
;;   EMIT    - emit the specified insn(s), consuming the input, return
;;             to the state 0.
;;   KEEP    - emit the specified insn, keep other pending insns and
;;             input, then run DFA on the pending input.

(define-class <state> (<instance-pool-mixin>)
  ((name  :init-keyword :name)
   (transitions :init-value '())        ;; alist of (insn-name . <arc>)
   (index)                              ;; table #
   (entry-index)                        ;; an index of the entry array
                                        ;; that indicates the first entry
                                        ;; of this state.
   (index-count :allocation :class :init-value 0)
   ))

(define-method write-object ((s <state>) out)
  (format out "#<state ~a ~a>" (~ s'index) (~ s'name)))

;; A transitional arc.  stop-insn is used to hold intermediate value
;; during STN creation.
(define-class <arc> ()
  ((input        :init-keyword :input)
   (next-state   :init-keyword :next-state   :init-value #f)
   (stop-insn    :init-keyword :stop-insn    :init-value #f)
   (command      :init-keyword :command      :init-value #f)))

(define-method initialize ((s <state>) initargs)
  (next-method)
  (set! (~ s'index) (~ s'index-count))
  (inc! (~ s'index-count)))

(define (make-state name) (make <state> :name name))

(define (state-lookup state insn-name)
  (assq-ref (~ state'transitions) insn-name))

(define (state-set-insn! state insn-name stop-insn)
  (if-let1 arc (state-lookup state insn-name)
    (set! (~ arc'stop-insn) stop-insn)
    (push! (~ state'transitions)
           (cons insn-name
                 (make <arc> :input insn-name :stop-insn stop-insn)))))

(define (state-set-state! state insn-name next-state)
  (if-let1 arc (state-lookup state insn-name)
    (set! (~ arc'next-state) next-state)
    (push! (~ state'transitions)
           (cons insn-name
                 (make <arc> :input insn-name :next-state next-state)))))

;; Add one insn to a state network.
;; If an insn is marked 'obsoleted', we add it to the root insn anyway but
;; do not process combinations.  Addition for the root is ncessary since
;; the initial lookup of the state transition table is done by insn code,
;; so we need a placeholder for obsoleted insns.
;; TODO: Would help if we have a mechanism to report an error if such
;; placeholder insn is actually kicked.
(define (add-insn-to-state! root-state insn)

  (define (substate state name)
    (or (and-let* ([arc (state-lookup state name)])
          (~ arc'next-state))
        (rlet1 newstate (make-state `(,@(~ state'name) ,name))
          (state-set-state! state name newstate))))

  (state-set-insn! root-state (~ insn'name) insn)
  (when (and (pair? (~ insn'combined))
             (not (~ insn'obsoleted)))
    (let loop ([combined (~ insn'combined)]
               [state    root-state])
      (cond [(null? (cdr combined))
             (state-set-insn! state (car combined) insn)]
            [(and (~ insn'fold-lref) (eq? (car combined) 'LREF))
             (loop (cdr combined) (substate state 'LREF))
             (dolist [lref .lrefx.]
               (loop (cdr combined) (substate state lref)))]
            [else
             (loop (cdr combined) (substate state (car combined)))]))))

;; The second path to fixup the STN.  Assign each arc a command.
(define (fixup-states! root-state)
  (define state-entry-index 0)

  (define (fixup1 state pending)
    (unless (eq? state root-state)
      (push! (~ state'transitions) (cons #f (make <arc> :input #f))))
    (set! (~ state'entry-index) state-entry-index)
    (inc! state-entry-index (length (~ state'transitions)))
    (dolist [transition (~ state'transitions)]
      (let* ([arc (cdr transition)]
             [si  (~ arc'stop-insn)]
             [ns  (~ arc'next-state)])
        (cond
         [(and si (not ns))
          (set! (~ arc'command) `(reset ,(~ si'name)))
          (set! (~ arc'next-state) root-state)]
         [(and si ns)
          (set! (~ arc'command) `(next ,ns))
          (fixup1 ns (list (~ si'name)))]
         [(and (not si) ns)
          (set! (~ arc'command) `(next ,ns))
          (fixup1 ns (cons (~ arc'input) pending))]
         [else
          (set! (~ arc'command) `(keep ,@(reverse pending)))
          (set! (~ arc'next-state) root-state)])))
    (update! (~ state'transitions) reverse!))

  (fixup1 root-state '()))

;; Emit the state table.
(define (emit-states states)

  (define entry-count 0)

  (dolist [s (sort-by states (cut ref <> 'entry-index) <)]
    (cgen-body #`"/* State #,(~ s'index) ,(~ s'name) [,(~ s'entry-index)] */")
    (dolist [t (~ s'transitions)]
      (match-let1 (op . args) (~ (cdr t)'command)
        (receive (action operand)
            (case op
              [(next)  (values 'NEXT (~ (car args)'entry-index))]
              [(reset) (values 'EMIT (c-insn-name (car args)))]
              [(keep)  (if (null? (cdr args))
                         (values 'KEEP (c-insn-name (car args)))
                         (error "huh?"))])
          (cgen-body
           (format "  /*~3d*/ { ~a, ~a, ~a },"
                   entry-count
                   (cond [(~ (cdr t)'input) => c-insn-name] [else -1])
                   action
                   operand))))
      (inc! entry-count)))
  )

(define (construct-state-table insns)
  (let1 root (make-state '())
    (for-each (cut add-insn-to-state! root <>) insns)
    (fixup-states! root)
    (emit-states (instance-pool->list <state>))))

;;==============================================================
;; Parse vminsn.scm and returns the define-insn form in order.
;; CISE definitions are evaluated within the current context.
;;
(define (expand-toplevels file)
  (define (lref-replace form lrefx)
    (match form
      [(syms ...) (map (cut lref-replace <> lrefx) syms)]
      [symbol ($ string->symbol
                 $ regexp-replace #/\bLREF\b/ (x->string symbol)
                 $ x->string lrefx)]))
  (define (generate-lrefx insn nparams operand comb seed)
    (fold (^[lrefx seed]
            `((define-insn ,(lref-replace insn lrefx) ,nparams ,operand
                ,(lref-replace comb lrefx))
              ,@seed))
          seed .lrefx.))
  (fold (^[form seed]
          (match form
            [('define-insn . _) (cons form seed)]
            ;; Special expansion for LREF shortcuts.
            ;; define-insn-lref* generates all variations of LREFn
            ;; from the insn, plus the generic LREF version.
            ;; define-insn-lref+ generates all variations of LREFn
            ;; but not the generic LREF version (if the combined insn
            ;; uses insn parameters, we can't use generic LREF that also
            ;; uses insn parameters.)
            [('define-insn-lref* insn nparams operand comb)
             (generate-lrefx insn 0 operand comb
                             `((define-insn ,insn 2 ,operand ,comb)
                               ,@seed))]
            [('define-insn-lref+ insn nparams operand comb)
             (generate-lrefx insn nparams operand comb seed)]
            [('define-cise-stmt . _) (eval form (current-module)) seed]
            [else (error "Invalid form in vm instruction definition:"form)]))
        '()
        (file->sexp-list file)))

;;
;; Parse a single define-insn form
;;
(define (parse-define-insn insn-num definsn)
  (match definsn
    [(_ name num-params operand-type . opts)
     (let-optionals* opts ([combined #f]
                           [body #f]
                           . flags)
       (make <vm-insn-info>
         :name name :code insn-num
         :num-params (if (pair? num-params) (car num-params) num-params)
         :alt-num-params (if (pair? num-params) (cdr num-params) '())
         :operand-type operand-type :combined combined
         :body body
         :obsoleted (boolean (memq :obsoleted flags))
         :fold-lref (boolean (memq :fold-lref flags))))]
    [else (errorf "unrecognized define-insn form: ~s" definsn)]))

;;
;; From S-expr of define-insns, create <vm-insn-info> instances
;; and make necessary wiring.
;;
(define (populate-insn-info definsns)
  (rlet1 insns (map-with-index parse-define-insn definsns)
    ;; Set up insn relationships
    (dolist [insn insns]
      (and-let* ([comb (~ insn'combined)])
        (define (wire suffix slot)
          (let* ([basename (string->symbol
                            (rxmatch->string (string->regexp #`"^(.*)-,suffix")
                                             (x->string (~ insn'name))))]
                 [baseinsn (find (^_ (eq? (~ _'name) basename)) insns)])
            (set! (~ baseinsn slot) insn)
            (set! (~ insn'base-variant) baseinsn)))

        (case (car (last-pair comb))
          [(PUSH) (wire "PUSH" 'push-variant)]
          [(RET)  (wire "RET"  'ret-variant)])))))

;;
;; Main
;;
(define (main args)
  (parameterize ([cgen-current-unit *unit*])
    (let1 insns ($ populate-insn-info $ reverse $ expand-toplevels
                   $ get-optional (cdr args) "vminsn.scm")

      ;; Generate insn names and DEFINSN macros
      (cgen-extern "enum {")
      (cgen-body "#ifdef DEFINSN")
      (dolist [insn insns]
        (cgen-extern #`"  ,(c-insn-name (~ insn'name)),,")
        (cgen-body (format "DEFINSN(~a, \"~a\", ~a, ~a, ~a)"
                           (c-insn-name (~ insn'name)) (~ insn'name)
                           (~ insn'num-params)
                           (string-tr (x->string (~ insn'operand-type))
                                      "a-z+-" "A-Z__")
                           (string-join
                            (cond-list
                             [(~ insn'obsoleted) "SCM_VM_INSN_OBSOLETED"]
                             [(~ insn'fold-lref) "SCM_VM_INSN_FOLD_LREF"]
                             [#t "0"])
                            "|")
                           )))
      (cgen-extern "  SCM_VM_NUM_INSNS" "};")
      (cgen-body "#endif /*DEFINSN*/")

      ;; Generate insn combination state table
      (cgen-body "#ifdef STATE_TABLE")
      (construct-state-table insns)
      (cgen-body "#endif /*STATE_TABLE*/")

      ;; Generate vmloop body
      (cgen-body "#ifdef VMLOOP")
      (construct-vmbody insns)
      (cgen-body "#endif /*VMLOOP*/")

      ;; Write files
      (cgen-emit-h (cgen-current-unit))
      (cgen-emit-c (cgen-current-unit))
      (gen-gauche.vm.insn insns)
      0)))

;; Local variables:
;; mode: scheme
;; end:

