(in-package "CL-USER")


(setf *global-const-list* nil)
  
(defun do-comp (e sl)
  (let ((res (comp-01 (expand e) nil))
        (globs nil))
    (setf res (comp-11 res))
    (format t "~%")
    (pprint (car res))
    (setf res (comp-2 (expand (car res)) nil))
    (format t "comp-2 = ~S~%" res)
    (pprint res)
    (format t "~%~%")
    (setf res (comp-11 (expand res)))
    (format t "comp-2 analyzed = ")
    (pprint (car res))
    (format t "~%~%")
    (setf res (comp-3 (car res) nil))
    (setf *xx* res)
    (pprint res)))

(defun do-comp-1 (e sl)
  (let ((res (comp-11 (expand e)))
        (globs nil))
    (setf res (comp-2 (expand (car res)) nil))
    (format t "comp-2 = ~S~%" res)
    (pprint res)))


(defun fun-analyze ()

  (format t "required funs = ~a~%~%~%" (get-req-funs))
  (loop for ff in (get-req-funs) do
        (format t "~a ~a~%" ff (not (null (msys::to-cl (msys::symbol-function (msys::cl-to ff))))))))



;;
;; (comp-x form) compiles a form and generates a pre-template
;; this pre-template contains a halt instruction at the end, added with comp-gen-embrace
;; the pre-template can be "assembled" to memory simply by calling (msys::cl-to *tt*) 
;; where *tt* is the pre-template 
;;



(defun comp-x (e)
  (let ((res nil))

    (setf res (expand e))
    (setf res (comp-11 res))
    (pprint res)
    (format t "~%************~%")
    (setf res (comp-2 (car res) nil))
    (pprint res)
    (format t "~%************~%")
    (setf res (comp-11 (expand res)))
    (pprint res)
    (format t "~%************~%")
    (setf res (comp-3 (car res) nil))
    (setf res (expand res))
    (pprint res)
    (format t "~%************~%")
    (stat-init *stat*)

    (keep-book-defined-functions nil)

    (comp-gen res *stat*)    

    (fun-analyze)

    (comp-gen-embrace *stat*)
    (setf *tt* (make-pretemplate *stat*))
;    (format t "*stat* = ~A~%" *stat*)
    ))

;;
;; comp-y is comp-x with less output
;;

(defun comp-y (e)
  (let ((res nil))

    (setf res (expand e))

    (setf res (comp-11 res))

    (setf res (comp-2 (car res) nil))

    (setf res (comp-11 (expand res)))

    (setf res (comp-3 (car res) nil))
    (setf res (expand res))

    (stat-init *stat*)
    
    (keep-book-defined-functions nil)
    
    (comp-gen res *stat*)

    (fun-analyze)

    (comp-gen-embrace *stat*)
    (setf *tt* (make-pretemplate *stat*))))

;;
;; comp-template is a special version of the comp routines only provided for compiling the
;; three templates below and maybe additional ones for similar purpose in the future
;; difference is, that no halt instruction is added at the end of the compiled code
;;



(defun comp-template (e)
  (let ((res nil))

    (setf res (expand e))
    (setf res (comp-11 res))
    (pprint res)
    (format t "~%************~%")
    (setf res (comp-2 (car res) nil))
    (pprint res)
    (format t "~%************~%")
    (setf res (comp-11 (expand res)))
    (pprint res)
    (format t "~%************~%")
    (setf res (comp-3 (car res) nil))
    (setf res (expand res))
    (pprint res)
    (format t "~%************~%")
    (stat-init *stat*)
    (comp-gen (cadr res) *stat*)
;    (comp-gen-embrace *stat*)
    (setf *tt* (make-pretemplate *stat*))
    (format t "*stat* = ~A~%" *stat*)
    (caadr *tt*)))


;;
;; the following three templates provide the code for %make-vector %make-closure %reserve-space
;; pointers to closures formed out of these templates are in lower memory
;; the compiler inserts indirect closure calls through these pointers when compiling one of the
;; above three functions
;;
;; see also comp-all.lisp
;;

(setf *make-vector+tp*
      (comp-template
       '(lambda (n)
          (let ((n-bytes (p-align3 (%+ (p-shiftl n 2) 12))))
            (let ((p (%reserve-space n-bytes)))
              (set-word p 0 (tag-set (addr-ior (p-shiftl n-bytes 2) 1) 1))
              (set-word p 4 n)
              (set-word p 8 0)
;              (do ((i 0 (%+ i 1)))
;                  ((%>= i n))
;                (set-svref p i nil))
              (setq p (tag-set p 2)))))))

(setf *make-closure+tp*
      (comp-template
       '(lambda (templ vect)
          (let ((p (%reserve-space 16)))
            (set-word p 0 (tag-set 3 1))
            (set-word p 4 0)
            (set-word p 8 templ)
            (set-word p 12 vect)
            (setq p (tag-set p 2))
            p))))

;;
;; the following is an augmented version of reserve-space-template which contains a soundness check
;; that allocation always start on 8 byte boundaries
;;

;;;; (setf *reserve-space+tp*
;;;;       (comp-template
;;;;        '(lambda (n)
;;;;           (let ((p (get-word 200 24)))
;;;;             (if (addr-eqi (addr-and p 1) 1) (progn (%print "reserve: ap = ") 
;;;;                                                               (%print p)))
;;;;             (set-word 200 24 (p-add p n))
;;;;             p))))
;;;;            

(setf *reserve-space+tp*
      (comp-template
       '(lambda (n)
          (let ((p (get-word 200 24)))
            (set-word 200 24 (p-add p n))
            p))))
                
(setf *cons+tp*
      (comp-template
       '(lambda (x y)
          (let ((p (%reserve-space 8)))
            (set-word p 0 x)
            (set-word p 4 y)
            (tag-set p 1)))))


(setf *reserve-space-code*
       '(lambda (s n)
          (let ((p (get-word 200 24)))
            (set-word 200 24 (p-add p n))
            p)))
          
          


;;
;; (tst1 form) compiles form, displaying extensive compiler output and runs it on emu
;; template linkage not supported yet
;;


(defun tst1 (xx)
  (setf steps 100000)
  (setf *tst0q* xx)
  (comp-x *tst0q*)

  (comp-init-sysfuns)

  (setf tp (msys::cl-to *tt*))

  (msys::set-word (msys::cl-to 200) (msys::cl-to 24) msys::*alloc-pointer*)
  (msys::set-word (msys::cl-to 200) (msys::cl-to 28) msys::*base-pkg*)
  (msys::set-word (msys::cl-to 200) (msys::cl-to 32) msys::nil)

  (emu::emu-init tp)
  (emu::run-processor steps))

;;
;; (tst11 form) compiles form, suppressing most of compiler output and runs it on emu
;; template linkage not supported yet
;;


(defun tst11a (xx)

  (setf steps (* 10 1000 1000))
  (setf *tst0q* xx)
  (comp-y *tst0q*)

  (comp-init-sysfuns)

  (format t "ap = ~a~%" msys::*alloc-pointer*)
  (setf tp (msys::cl-to *tt*))


  (comp-init-basis-1)

  (format t "ap = ~a~%" (msys::get-word (msys::cl-to 200) (msys::cl-to 24)))

  (emu::emu-init tp)
  (emu::run-processor steps))


(defun comp-init-sysfuns ()
  (msys::set-word (msys::cl-to 200) (msys::cl-to 0) (msys::make-closure (msys::cl-to *make-closure+tp*) msys::nil))
  (msys::set-word (msys::cl-to 200) (msys::cl-to 4) (msys::make-closure (msys::cl-to *make-vector+tp*) msys::nil))
  (msys::set-word (msys::cl-to 200) (msys::cl-to 8) (msys::make-closure (msys::cl-to *reserve-space+tp*) msys::nil))
  (msys::set-word (msys::cl-to 200) (msys::cl-to 12) (msys::make-closure (msys::cl-to *cons+tp*) msys::nil)))
  
(defun comp-init-basis-1 ()
  (msys::set-word (msys::cl-to 200) (msys::cl-to 24) msys::*alloc-pointer*)
  (msys::set-word (msys::cl-to 200) (msys::cl-to 28) msys::*base-pkg*)
  (msys::set-word (msys::cl-to 200) (msys::cl-to 32) msys::nil))


(defun tst11-do (form)
  (let ((tp (comp-f form)))
    (let ((res (run-tp tp)))
      (format t "res = ~a~%~%" res))))

(defun tst11-let-list (form)
  (let ((form (cddr form)))
    (loop
     for ff in form do
     (tst11-do ff))))


(defun tst11 (form)
  (comp-init-sysfuns)
  (comp-init-basis-1)
  (if (and (eq (car form) 'let)
           (eq (cadr form) nil))
      (tst11-let-list form)
    (tst11-do form)))
  


(defun aktualize-ap-from-mem ()
  (setf msys::*alloc-pointer* (msys::get-word 800 96)))

(defun aktualize-ap-to-mem ()
  (msys::set-word 800 96 msys::*alloc-pointer*))


(defun comp-f (form)
  (let ((tp nil))
    (aktualize-ap-from-mem)
;    (format t "ap before comp-x = ~a~%" (msys::get-word 800 96))
;    (pprint (msys::to-cl (msys::symbol-function (msys::cl-to 'f))))
    (comp-y form)
;    (pprint *tt*)
;    (format t "~%ap before assemble = ~a~%" (msys::get-word 800 96))
    (setf tp (msys::cl-to *tt*))
    (aktualize-ap-to-mem)
;    (pprint (msys::to-cl tp))
    tp))


(defun run-tp (tp)
  (let ((steps (* 10 1000 1000))
        (res nil))
    
;    (format t "~%ap before run = ~a~%" (msys::get-word (msys::cl-to 200) (msys::cl-to 24)))
 
    (emu::emu-init tp)
;    (format t "dsp = ~a~%" emu::*dsp*)
   
    (emu::run-processor steps)

;    (format t "dsp = ~a~%" emu::*dsp*)

    (setf res (msys::get-word emu::*dsp* 0))

;    (format t "ap after run = ~a~%" (msys::get-word 800 96))
    (setf res (msys::to-cl res))))

    
    

  




(defun init-memory ()
  (loop
   for i from 0 to (- (* 256 1024) 1) by 4 do
   (msys::set-word i 0 0)))
   

;;
;; the following is the actual memory dumper
;; output directory is hard coded, must be adapted in changed environment
;;


(defun big-endian (i)
  (let ((res 0))
    (loop 
     for j from 3 downto 0  do
     (setf res (+ (* 256 res) (msys::to-cl (msys::get-byte i (msys::cl-to j)))))
     finally return res)))


(defun dump-memory (fname)
  (with-open-file (fo 
		(concatenate 'string "" fname)
			 :direction :output :if-exists :supersede :if-does-not-exist :create)
    (let ((page-size 1024)
          (pages 8))
      (let ((max-addr (- (* pages page-size) 1)))
        (loop
         for i from 0 upto max-addr by 4 do
         (if (= 0 (mod i 16))
             (format fo "//@~8,'0,X~%" i))
         (format fo "~8,'0,X~%" (big-endian i)))))))

;;
;; (clean) must be called before compilation of a first template
;; if a second template for linkage follows clean must not be called before compiling the second template
;; because it wipes the memory
;;

(defun clean ()
  (clear-struct-tables)
  (reset-arity-list)
  (mapcar #'(lambda (z) (load z) (compile-file z)) '("msys-pack.lisp" "comp-test.lisp")))

;;
;; mem-dump-file
;;

;(setf *akt-mem-dump* "f:\\ISEProjekte\\Proto200\\akt-test.mem")

(setf *akt-mem-dump* "../micasm/akt-test.dump")

;;
;; (tst2 form) compiles form and generates executable memory image
;; this image is directly readable by simemu, by the verilog simulator and by the fpga init-tools xi-init
;; and by data2mem
;;

(defun tst2 (xx &key (add-code nil) (alloc-base nil))

  (setf *tst0q* xx)
  (comp-y *tst0q*)

  (when (not add-code)
    (comp-init-sysfuns))

  (when alloc-base
    (setf msys::*alloc-pointer* alloc-base))

  (when (not add-code)
    (msys::set-word (msys::cl-to 50) (msys::cl-to 8) msys::*alloc-pointer*)) ;; lower limit of first template

  (when add-code
    (msys::set-word (msys::cl-to 50) (msys::cl-to 16) msys::*alloc-pointer*)) ;; lower limit of second template

  (format t "ap anf = ~a~%" msys::*alloc-pointer*)

  (setf tp (msys::cl-to *tt*))

  (format t "ap end = ~a~%" msys::*alloc-pointer*)

  (msys::set-word (msys::cl-to 200) (msys::cl-to 24) msys::*alloc-pointer*) ;; upper limit of current template

  (when (not add-code)
    (msys::set-word (msys::cl-to 50) (msys::cl-to 0) 0) ;; flag eq 0 for first template
    (msys::set-word (msys::cl-to 50) (msys::cl-to 12) msys::*alloc-pointer*)) ;; upper limit of first template

  (when (not add-code)
    (msys::set-word (msys::cl-to 200) (msys::cl-to 28) msys::*base-pkg*)
    (msys::set-word (msys::cl-to 200) (msys::cl-to 32) msys::nil))


  (when add-code
    (msys::set-word (msys::cl-to 50) (msys::cl-to 20) msys::*alloc-pointer*) ;; upper limit of second template
    (msys::set-word (msys::cl-to 50) (msys::cl-to 0) (msys::cl-to 1)) ;; flag eq 1 for second template
    (msys::set-word (msys::cl-to 50) (msys::cl-to 4) tp)) ;; template address of second template

  (when (not add-code)
    (msys::set-word 0 (msys::cl-to 0) msys::nil)
    (msys::set-word 0 (msys::cl-to 4) tp))
  
  (msys::set-word 0 (msys::cl-to 8) msys::*alloc-pointer*) ;; ignored in current implementation

  (dump-memory *akt-mem-dump*))



(defun tst22 (xx &key (add-code nil) (alloc-base '(200 48)) (run-mode :emu))
;;(defun tst22 (xx &key (add-code nil) (alloc-base '(200 24)) (run-mode :emu))
  (let ((tp nil))

    (when (not add-code)
      (comp-init-sysfuns)
      (comp-init-basis-1))
    

    ;; alloc base is chosen to be compatible with (200 48) being the alloc-pointer in *basis02* after the gc
    ;; takes control

    (when add-code 
      (setf msys::*alloc-pointer* (msys::get-word (msys::cl-to (car alloc-base)) (msys::cl-to (cadr alloc-base)))))

    (format t "ap anf = ~a~%" msys::*alloc-pointer*)
    
    (comp-y xx)
  
    (setf tp (msys::cl-to *tt*)) 
    
    (format t "ap end = ~a~%" msys::*alloc-pointer*)

    (when add-code
      (msys::set-word (msys::cl-to (car alloc-base)) (msys::cl-to (cadr alloc-base)) msys::*alloc-pointer*))

    (when (not add-code)
      (msys::set-word (msys::cl-to 200) (msys::cl-to 24) msys::*alloc-pointer*)) ;; upper limit of first template
    ;; is written into classical (non gc) allocation pointer

    (when (not add-code)
      (msys::set-word (msys::cl-to 50) (msys::cl-to 16) msys::*alloc-pointer*)) ;; upper limit of first template
    ;; becomes lower limit of gc area in *basis02*

    ;; kept for compatibility with closure call from 1st to 2nd template
    (when (not add-code)
      (msys::set-word (msys::cl-to 50) (msys::cl-to 0) 0) ;; flag eq 0 for first template
      (msys::set-word (msys::cl-to 50) (msys::cl-to 12) msys::*alloc-pointer*)) ;; upper limit of first template


    ;; kept for compatibility
    (when add-code
      (msys::set-word (msys::cl-to 50) (msys::cl-to 20) msys::*alloc-pointer*) ;; upper limit of second template
      (msys::set-word (msys::cl-to 50) (msys::cl-to 0) (msys::cl-to 1)) ;; flag eq 1 for second template
      (msys::set-word (msys::cl-to 50) (msys::cl-to 4) tp)) ;; template address of second template

    
    ;; inform the system about position of msys::*base-pkg* and msys::nil
    (when (not add-code)
      (msys::set-word (msys::cl-to 200) (msys::cl-to 28) msys::*base-pkg*)
      (msys::set-word (msys::cl-to 200) (msys::cl-to 32) msys::nil))


    (cond ((eq run-mode :emu)
           (out-ap)
           (run-tp tp)
           (out-ap))
          ((eq run-mode :simemu)
           
           (msys::set-word 0 (msys::cl-to 0) msys::nil)
           (msys::set-word 0 (msys::cl-to 4) tp)
           (msys::set-word 0 (msys::cl-to 8) msys::*alloc-pointer*) ;; ignored in current implementation
           
           (dump-memory *akt-mem-dump*)))))


(defun out-ap ()
  (format t "ap is = ~a~%" (msys::get-word (* 200 4) (* 48 4))))


(defun doit01 ()
  (let ((res nil))
    (clean)
    (setf res (tst22 *basis02*))
    (format t "res = ~a~%" res)
    (tst22 *keyb02* :add-code t)
    (tst22 *editor01* :add-code t)
    (tst22 *windows02* :add-code t :run-mode :simemu)))

(defun doit011 ()
  (let ((res nil))
    (clean)
;    (setf res (tst22 *basis02*))
;    (format t "res = ~a~%" res)
    (tst22 *print01*)
    (tst22 *keyb02* :add-code t)
;    (tst22 *editor01* :add-code t)
    (tst22 *windows01* :add-code t :run-mode :simemu)))
   
(defun doit02 ()
  (let ((res nil))
    (clean)
    (tst22 *test-a7* :run-mode :simemu)))
 
(defun doit022 ()
  (let ((res nil))
    (clean)
    (tst22 *test-a6* :run-mode :simemu)))


(defun tst2-run (steps)
  (emu::emu-init tp)
  (emu::run-processor steps))


(defun disasm (sym)
  (msys::to-cl (msys::symbol-function (msys::cl-to sym))))