#lang scheme/base

;; Compiler state
(require
 scheme/match
 "../tools.ss"
 "../target.ss"
 "../control/2stack.ss")

(provide
 state:compiler
 (struct-out compiler)
 (struct-out dict)
 (struct-out mcont)
 dict-label
 dict-terminate
 comp-print-state
 )


;; During compilation the assembly code (the result of instantiating
;; macros) is organized in the following hierarchy:

;;   * A word is a single entry point, represented by a target-word
;;     struct.  Each target-word struct is associated to a chunk A
;;     chunk is a list of consecutive assembly code instructions.
;;     Code inside a target-word struct can only be reached through a
;;     jump to its label.  This means that the target-word and its
;;     associated chunk is not observable to the world, and is
;;     completely abstracted by its label.  Therefore target-word
;;     structs serve as the unit of code generation (and
;;     recombination).  Any operation on code that doesn't alter
;;     linear code flow is legal within a chunk.

;;   * A code chain is a list of code chunks with implicit
;;     fallthrough.  Each chunk indicates a single entry point.
;;     Chains are terminated by exit points.  Chains are the unit of
;;     target address allocation: each chain can be associated to an
;;     address independent of other chains.  Some chains have a fixed
;;     address (org).
;;
;;   * The store is a set of recently constructed chains (implemented
;;     as a stack).  Chains in the store can be placed in arbitrary
;;     locations in the target's memory.


;; Summarized:
;;   - chunk  : ENTRY point
;;   - chain  : EXIT point
;;  
;; This hierarchy is necessary because Forth words can have multiple
;; entry and exit points.  A Forth word then consists of one or more
;; chains.  (A chain has a single EXIT point, but can have multiple
;; ENTRY points.)

;; Organizing it this way gives maximum flexibility: the compiler
;; implements the jump^ macro set.  On top of this the Forth-style
;; control^ is implemented, which provides efficient control flow word
;; bundled with post-processing control flow analysis.



(define-struct dict
  (current  ;; current word label
   chain    ;; list of words with fallthrough
   store))  ;; set (stack?) of fallthrough lists


;; Save code under label, but drop if there is no label, which means
;; the code is not reachable.

(define (log-dead code)
  (log:
   (format
    "dead:~a\n"
    (apply
     string-append
     (map (lambda (ins)
            (format " ~a"
                    (instruction->string ins)))
          (reverse code))))))

(define (dict-label d new-word code)
  (match d
         ((struct dict (current chain store))
          (make-dict new-word
                     (if current
                         (cons (list current code) chain)
                         (begin
                           (unless (null? code)
                             (log-dead code))
                           chain))
                     store))))


;; Terminate current fallthrough chain by moving it to the store.
(define dict-terminate
  (match-lambda
   ((struct dict (current chain store))
    (make-dict current '()
               (if (null? chain) ;; drop empty chains
                   store
                   (cons chain store))))))




;; To make it easier to convert Forth definitions that call ";" inside
;; the definition to macros, we provide a simulated local exit for
;; macros which jumps to past the macro's generated code.  This
;; requires a simulated return stack with 'macro continuations'.

;; Note that this is _not_ the control stack!  Forth's control
;; structures and the run-time return stack are independent.  This
;; serves to simulate the run-time stack, so needs a different
;; mechanism.  (FIXME: maybe the control stack can be implemented in
;; terms of this?  It looks strange to need 2 stacks for control.)

(define-struct mcont (label refs))


;; (printf "define-struct compiler\n")  ;; to check double instantiations
(define-struct (compiler 2stack)
  (dict      ;; dictionary object: keeps track of label -> code bindings
   rs))      ;; 'return stack' for macros: a list of exit labels + refcount

(define update-compiler
  (case-lambda
    ((state asm)
     (update-compiler state asm
                      (2stack-ctrl-list state)))
    ((state asm ctrl) 
     (update-compiler state asm ctrl
                      (compiler-dict state)
                      (compiler-rs state)))
    ((state asm ctrl dict rs)
     (make-state:compiler asm ctrl dict rs))))

(define (make-state:compiler ctrl asm dict rs)
  (make-compiler update-compiler
                 ctrl asm dict rs))

(define (state:compiler [datastack '()])
  (make-state:compiler datastack
                       '()
                       (make-dict #f '() '())
                       '()))


;; State is "opened up" compared to the structure expected by
;; format-target-word, so specific printers are provided.

(define (comp-print-state s)
  (define (format-chunk chunk)
    (apply string-append
           (for/list ((a (reverse chunk)))
             (format "\t~a\n" (instruction->string a)))))
  (define (format-chain chain)
    (apply string-append
           (for/list ((word/chunk (reverse chain)))
             (format "~a~a"
                     (format-target-word (car word/chunk))
                     (format-chunk (cadr word/chunk))))))
  (define (format-ctrl ctrl)
    (apply string-append
           (for/list ((wd ctrl))
             (if (target-word? wd)
                 (format "~s\n" (target-word-name wd))
                 (format "~a\n" wd)))))

  (define (format-rs rs)
    (apply string-append
           (for/list ((mc rs))
             (match mc
                    ((struct mcont (label refc))
                     (format "~a ~a\n"
                             (target-word-name label)
                             refc))))))

  (define (format-store store)
    (apply string-append (map format-chain (reverse store))))
  (match s
   ((struct compiler (update asm ctrl
                             (struct dict (current chain store))
                             rs))
    (with-handlers ((void
                     (lambda (e)
                       (printf "print-state error: ~a\n" e)
                       (printf "ASM:~a\nCTRL:~a\nCURRENT:~a\nCHAIN:~a\nSTORE:~a\nRS:~a\n"
                               asm ctrl current chain store rs))))
      (display
       (string-append
        (format ";; store\n~a\n" (format-store store))
        (format ";; chain\n~a\n" (format-chain chain))
        (format ";; current\n~a\n" (and (target-word? current) (format-target-word current)))
        (format ";; asm\n~a\n" (format-chunk asm))
        (format ";; ctrl\n~a\n" (format-ctrl ctrl))
        (format ";; rs\n~a\n" (format-rs rs))
        ))

    ))))