;;;
;;; geninsn - generate VM instruction related files
;;;
;;;   Copyright (c) 2004-2005 Shiro Kawai, All rights reserved.
;;;   
;;;   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.
;;;  
;;;  $Id: geninsn,v 1.4 2007-01-14 09:22:59 shirok Exp $
;;;

;; 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.cgen.cise)
(use gauche.parameter)
(use gauche.sequence)
(use gauche.vm.insn-core)
(use gauche.mop.instance-pool)
(use gauche.experimental.app)
(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 (lambda (o) (eq? name (ref o '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 out)
    (format out ";; Generated from vminsn.scm.  DO NOT EDIT\n")
    (write '(define-module gauche.vm.insn
              (extend gauche.vm.insn-core)) out)
    (newline out)
    (write '(select-module gauche.vm.insn) out)
    (newline out))
  (define (write-insn insn out)
    (format out ";; #x~3,'0x  ~a\n" (ref insn 'code) (ref insn 'name))
    (format out "(make <vm-insn-info> :name '~a :code ~a\n"
            (ref insn 'name) (ref insn 'code))
    (format out "  :num-params ~a :operand-type '~a\n"
            (ref insn 'num-params) (ref insn 'operand-type))
    (format out "  :combined '~s\n" (ref insn 'combined))
    (format out "  :body '~s)\n\n"
            (ref insn 'body)))
  (call-with-output-file "../lib/gauche/vm/insn.scm"
    (lambda (out)
      (write-header out)
      (for-each (cut write-insn <> out) insns)
      (write '(provide "gauche/vm/insn") out)
      (newline out))
    :if-exists :supersede)
  )

;;=============================================================
;; Generate VM inner loop (unfinished)
;;

;; 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 (ref insn'name))))))
  (define (base-cise base)
    (and-let* [(base-insn (find-insn base insns))]
      (ref 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)}"))
  (define (do-combined insn comb)
    (match comb
      [(base 'PUSH)
       (and-let* [(cise (base-cise base))]
         (parameterize ([result-type 'push]) (render cise))
         #t)]
      [(base 'RET)
       (and-let* [(cise (base-cise base))]
         (parameterize ([result-type 'ret]) (render cise))
         #t)]
      [(base (and (or 'CALL 'TAIL-CALL) next))
       (and-let* [(cise (base-cise base))]
         (parameterize ([result-type 'call]) (render cise))
         (render `($goto-insn ,next))
         #t)]
      [('PUSH . next)
       (render `(PUSH-ARG VAL0))
       (render `($goto-insn ,(symbol-join next)))
       #t]
      [('LREF0 'PUSH . next)
       (render `(let* ((v (ENV-DATA ENV 0))) (PUSH-ARG v)))
       (render `($goto-insn ,(symbol-join next)))
       #t]
      [((and (? (cut memq <> .lrefx.)) lrefx) . next)
       (parameterize ([arg-source (lrefx->lref lrefx)])
         (do-combined-rec next))]
      [('LREF . next)
       (parameterize ([arg-source 'lref]) (do-combined-rec next))]
      [_ #f]))
  (define (do-combined-rec comb)
    (and-let* [(insn (find-insn (symbol-join comb) insns))]
      (render1 insn)))
  (define (render1 insn)
    (or (and-let* [(cise (ref insn 'body))]
          (render cise)
          #t)
        (and-let* [(comb (ref insn 'combined))]
          (do-combined insn comb))
        (warn "Don't know how to generate ~a" (ref insn 'name))))

  ;; main body of construct-vmbody
  (parameterize ((insn-alist (map (lambda (i) (cons (ref i'name) i)) 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 descrption, 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>" (ref s 'index) (ref 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! (ref s 'index) (ref s 'index-count))
  (inc! (ref s 'index-count)))

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

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

(define (state-set-insn! state insn-name stop-insn)
  (or (and-let* ((arc (state-lookup state insn-name)))
        (set! (ref arc 'stop-insn) stop-insn))
      (push! (ref state 'transitions)
             (cons insn-name
                   (make <arc> :input insn-name :stop-insn stop-insn)))))

(define (state-set-state! state insn-name next-state)
  (or (and-let* ((arc (state-lookup state insn-name)))
        (set! (ref arc 'next-state) next-state))
      (push! (ref state 'transitions)
             (cons insn-name
                   (make <arc> :input insn-name :next-state next-state)))))

;; Add one insn to a state network.
(define (add-insn-to-state! root-state insn)

  (define (substate state name)
    (or (and-let* ((arc (state-lookup state name)))
          (ref arc 'next-state))
        (let1 newstate (make-state `(,@(ref state 'name) ,name))
          (state-set-state! state name newstate)
          newstate)))

  (state-set-insn! root-state (ref insn 'name) insn)
  (when (pair? (ref insn 'combined))
    (let loop ((combined (ref insn 'combined))
               (state    root-state))
      (if (null? (cdr combined))
        (state-set-insn! state (car combined) insn)
        (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! (ref state 'transitions) (cons #f (make <arc> :input #f))))
    (set! (ref state 'entry-index) state-entry-index)
    (inc! state-entry-index (length (ref state 'transitions)))
    (dolist (transition (ref state 'transitions))
      (let* ((arc (cdr transition))
             (si  (ref arc 'stop-insn))
             (ns  (ref arc 'next-state)))
        (cond
         ((and si (not ns))
          (set! (ref arc 'command) `(reset ,(ref si 'name)))
          (set! (ref arc 'next-state) root-state))
         ((and si ns)
          (set! (ref arc 'command) `(next ,ns))
          (fixup1 ns (list (ref si 'name))))
         ((and (not si) ns)
          (set! (ref arc 'command) `(next ,ns))
          (fixup1 ns (cons (ref arc 'input) pending)))
         (else
          (set! (ref arc 'command) `(keep ,@(reverse pending)))
          (set! (ref arc 'next-state) root-state)))))
    (update! (ref state 'transitions) reverse!))

  (fixup1 root-state '()))

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

  (define entry-count 0)
  
  (dolist (s (sort states (lambda (s1 s2)
                            (< (ref s1 'entry-index)
                               (ref s2 'entry-index)))))
    (cgen-body #`"/* State #,(ref s 'index) ,(ref s 'name) [,(ref s 'entry-index)] */")
    (dolist (t (ref s 'transitions))
      (match-let1 (op . args) (ref (cdr t) 'command)
        (receive (action operand)
            (case op
              ((next)  (values 'NEXT (ref (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 ((ref (cdr t) 'input) => c-insn-name)
                         (else -1))
                   action
                   operand))))
      (inc! entry-count)))
  )

(define (construct-state-table insns)
  (let ((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 (parse-vminsn 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 (lambda (lrefx seed)
            `((define-insn ,(lref-replace insn lrefx) ,nparams ,operand
                ,(lref-replace comb lrefx))
              ,@seed))
          seed .lrefx.))
  (fold (lambda (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)))

;;
;; From S-expr of define-insns, create <vm-insn-info> instances
;; and make necessary wiring.
;;
(define (populate-insn-info definsns)
  (let1 insns (map-with-index
               (lambda (count insn)
                 (match insn
                   [(_ name num-params operand-type . opts)
                    (let-optionals* opts ((combined #f)
                                          (body #f))
                      (make <vm-insn-info>
                        :name name :code count :num-params num-params
                        :operand-type operand-type :combined combined
                        :body body))]
                   [else (errorf "unrecognized define-insn form: ~s" insn)]))
               definsns)
    ;; Set up insn relationships
    (dolist (insn insns)
      (and-let* ([comb (ref insn'combined)])
        (define (wire suffix slot)
          (let* ((basename (string->symbol
                            (rxmatch->string (string->regexp #`"^(.*)-,suffix")
                                             (x->string (ref insn'name)))))
                 (baseinsn (find (lambda (i) (eq? (ref i 'name) basename))
                                 insns)))
            (set! (ref baseinsn slot) insn)
            (set! (ref insn 'base-variant) baseinsn)))
        
        (case (car (last-pair comb))
          [(PUSH) (wire "PUSH" 'push-variant)]
          [(RET)  (wire "RET"  'ret-variant)])))
    
    insns))

;;
;; Main
;;
(define (main args)
  (parameterize ((cgen-current-unit *unit*))
    (let1 insns ($ populate-insn-info $ reverse $ parse-vminsn
                   $ 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 (ref insn 'name)),,")
        (cgen-body (format "DEFINSN(~a, \"~a\", ~a, ~a)"
                           (c-insn-name (ref insn 'name)) (ref insn 'name)
                           (ref insn 'num-params)
                           (string-tr (x->string (ref insn 'operand-type))
                                      "a-z+-" "A-Z__"))))
      (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:

