;;; -*- Mode:LISP; Package:COMPILER; Base:8; Readtable:ZL -*-


;;; This doesn't belong here, but it doesn't belong anywhere else either...

zwei:
(DEFCOM COM-CROSSCOMPILE-REGION "Crosscompile the current region or defun.
If there is a region, it is compiled.
Otherwise, the current or next defun is compiled." ()
  (COMPILE-DEFUN-INTERNAL (or (get-buffer-compiler *interval*) T)
			  (if *numeric-arg-p* "Cross-and-downloading" "Crosscompiling")
			  (if *numeric-arg-p* "Cross-and-downloaded" "Crosscompiled.")
			    NIL ;USE-TYPEOUT
			    NIL ;DEFVAR-HACK
			    '(:MODE COMPILER:MACRO-COMPILE)	;generating-micro-compiler-input-p
					;will wind up getting set however.
			    'COMPILER:K				;*target-computer*
			    #+never
			    (if *numeric-arg-p*
				'COMPILER:NLISP-DOWNLOAD-FASD-INTERFACE
			      'COMPILER:K-DUMMY-FASD-INTERFACE))	;*fasd-interface*
  DIS-NONE)



;k target computer interface
(defprop k fdefine-for-k fdefine)
(defprop k peep-for-k peep)
(defprop k qlapp-for-k qlapp)
(defprop k p2sbind-for-toplevel-for-k p2sbind-for-toplevel)
(defprop k assign-lap-addresses-for-k assign-lap-addresses)
(defprop k var-compute-init-for-k var-compute-init)
(defprop k p2-for-k p2)

(defun fdefine-for-k (function-spec definition &optional carefully-flag no-query-flag)
  (declare (ignore carefully-flag no-query-flag))
  (when nc:*debug-flag*
    (format t "~%Fdefine ~s ~s" function-spec definition))
  nil)

(defun peep-for-k (peep-code-array &optional function-name)
  (declare (ignore function-name))
  ;(grind-top-level (g-l-p peep-code-array))
  ;  (format t "~%PEEP ~s ~s" (g-l-p peep-code-array) function-name)
  nil)

(defun qlapp-for-k (fctn lap-mode)
  ;;(format t "~%QLAPP ~s ~s" fctn lap-mode)
  (multiple-value-bind (name instructions entry-points function-type)
      (cross-compile fctn 'store)		;or 'print
    (let-if (not (variable-boundp nc:*debug-stream*))
	    ((nc:*debug-stream* standard-output))
      (when (intersection '(:pre :post :postx) nc:*debug-flag*)
	(format nc:*debug-stream* "~%Entries ~s. ~%" entry-points))
      (setq instructions (nreverse instructions))
      (nc:debug :pre
	(format nc:*debug-stream* "~%Preprocessed instructions:~%")
	(nc:print-instructions instructions))
      (let ((code (nc:post-process (nreverse instructions))))
	(nc:debug :post
	  (format nc:*debug-stream* "~%Postprocessed instructions:~%")
	  (nc:print-instructions code nc:*debug-stream*)
	  ;;(grind-top-level code)
	  )
	(let ((nc-function-defstruct (nc:assemble-instruction-list name code entry-points)))
	  (nc:debug :postx
	    (format nc:*debug-stream* "~%Postprocessed instructions:~%")
	    (nc:print-instructions code nc:*debug-stream* (nc:ncompiled-function-code nc-function-defstruct)))
	  (cond ((eq lap-mode 'qfasl)
		 (fasd-k-compiled-function nc-function-defstruct function-type))
		((eq lap-mode 'compile-to-core)
		 #+never
		 (compiler-fasd-switch (fasd-function-defstruct nc-function-defstruct))))))
	)))

;k-dummy-fasd-interface
(defprop k-dummy-fasd-interface k-dummy-fasd-file-property-list fasd-file-property-list)
(defprop k-dummy-fasd-interface k-dummy-fasd-function-defstruct fasd-function-defstruct)

(defun k-dummy-fasd-file-property-list (plist)
  (declare (ignore plist))
  nil)

(defun k-dummy-fasd-function-defstruct (function-defstruct)
  (declare (ignore function-defstruct))
  nil)


;nlisp-download-fasd-interface
(defprop nlisp-download-fasd-interface nlisp-download-fasd-file-property-list fasd-file-property-list)
(defprop nlisp-download-fasd-interface nlisp-download-fasd-function-defstruct fasd-function-defstruct)

(defun nlisp-download-fasd-file-property-list (plist)
  (declare (ignore plist))
  nil)

(defun nlisp-download-fasd-function-defstruct (function-defstruct &optional (stream k-kbug:*kfasl-stream*))
  (let-globally ((k-kbug:*k-pausing* t))
    (let ((stopped? (k-kbug:kbug-stopped?)))
      (unless stopped?
	(k-kbug:kbug-stop)
	(k-kbug:kbug-wait-until-stopped))
      (send stream :reload-info)
      (k-kbug:kbug-cmd-raw k-k2:kbug-command-fasl-stream)
      (k-fasdump:fasd-compiled-function function-defstruct stream)
      (k-fasdump:fasd-eof stream)
      (send stream :force-output)
      (if (null stopped?)
	  (k-kbug:kbug-proceed)))
    ;(process-sleep 1000)
    ))

 

;P2-FOR-K central functions.  
;This is getting to look more and more like a whole new P2 (which is progress).

;;; Compile a form for multiple values (maybe).
;--- for lambda only.
;;; If our value is non-nil, it means that the code compiled
;;; failed to produce the multiple values as it was asked to.
;;; Normally, the destination should be D-PDL.
;;; If you use another destination, then, if the value returned is non-NIL
;;; then the single value has been compiled to the given destination,
;;; but if the value is NIL, then the destination has been ignored.
;;; This happens because forms that know how to generate the multiple
;;; values setq *M-V-TARGET* to NIL.

;;; Note: It is assumed that D-RETURN never has an *M-V-TARGET*,
;;; and that an *M-V-TARGET* of MULTIPLE-VALUE-LIST implies D-PDL.

;*M-V-TARGET* can be: a number, multiple-value-list, throw.


;Internal value: (for example, normal call to p2-for-k).  Value may be
;  generated by placing it in the desired destination without procedure call.
;Internal multiple values.  In some cases, compiler could figure things out
;  entirely at compile time.  We don't do this now, instead, everything must
;  use the external multiple-value mechanism.
;External multiple values.  Involve the mechanism of hw:return-code-mv-p,
; *number-of-return-values*, *return-0*, etc.  Always involves an actual
; procedure call, if for no other reason than destination return, etc.
; must be used to set up return-code-mv-p, etc.

(DEFUN P2MV-for-k (FORM DEST *M-V-TARGET*)
  (IF (NULL *M-V-TARGET*)
      (P2-for-k FORM DEST)
    (COND ((ADRREFP-for-k FORM)
	   (P2-for-k FORM DEST))
	  ((memq (car form) '(%POP %pop-for-with-stack-list))
	   (ferror nil "%pop or %pop-for-with-stack-list can't be used on the Falcon."))
	  (T
	   (P2F-for-k FORM DEST))))
  *M-V-TARGET*)

(DEFUN ADRREFP-for-k (EXP)				;Predicate T if can be ref by adr only
  (OR (ATOM EXP)
      (MEMQ (CAR EXP) '(LOCAL-REF QUOTE FUNCTION BREAKOFF-FUNCTION self-ref lexical-ref))))

;;; Compile code to compute FORM and put the result in destination DEST.
;;; If DEST is D-IGNORE, we may not actually bother to compute the value
;;; if we can tell that there would be no side-effects.
;DEST can be a symbol in the K package such as K:O0, K:A1, K:R2, etc.
;DEST can also be a list (k:new-open <n>) or (k:new-tail-open <n>).
;  in these cases, *open-frames* is hacked (mostly by OUTI-FOR-K).
;the value returned by P2-FOR-K is undefined.
(DEFUN P2-FOR-K (FORM DEST)
  (COND ((ADRREFP-for-k FORM)
	 (OR (EQ DEST 'D-IGNORE)
	     (p2-compute-move-for-k dest form)))
	((EQ (CAR FORM) '%POP)
	 (warn nil :very-obsolete "%POP is not supported on the Falcon."))
	((EQ (CAR FORM) '%POP-for-with-stack-list)
	 (warn nil :very-obsolete "%POP-FOR-WITH-STACK-LIST is not supported on the Falcon."))
	((EQ (CAR FORM) 'CHANGE-PDLLVL)
	 (warn nil :very-obsolete "Stack lists are not supported on the Falcon."))
	(T
	 (LET ((*BDEST* ()))
	   (P2F-FOR-K FORM DEST)))))


;; Stubs for now.
(defun microcoded-on-lambda (fun)
  (ignore fun)
  ())

(defun coded-for-k (fun)
  (ignore fun)
  t)

(DEFUN P2F-FOR-K (FORM DEST)
  (LET ((*P2FN* (CAR FORM))
	(ARGL (CDR FORM))
	TEM)
    (cond ((and (microcoded-on-lambda *p2fn*)
		(not (coded-for-k *p2fn*)))
	   (format t "~&~S is not implemted on the K yet~%" *p2fn*)))
    (COND ((setq tem (get *p2fn* 'p2-for-k))
	   (funcall tem (cdr form) dest))
	  ((SETQ TEM (GET *P2FN* 'QINTCMP))
	   (P2MISC-for-k *P2FN* ARGL DEST TEM))
	  (T
	   (P2ARGC-for-k *P2FN* ARGL (GETARGDESC *P2FN*) DEST *P2FN*)))))

(defun p2-compute-move-for-k (dest form &aux tem)
  (labels ((do-lexical (ref-index)
	    ;; Lexical-ref's are encoded as 12 bits of offset in environment and
	    ;; 12 bits of nesting level.
	    (let* ((tail-p (tail-call-p dest))	;Heh heh.  1-instruction closures!
		   (level (ldb (byte 12. 12.) ref-index))
		   (offset (ldb (byte 12. 0) ref-index)))
	      (tail-call-open 'closure-ref tail-p #'discard-temporary-frame :single-value)
	      (outi-for-k `(k:move k:o0 k:a15 k:boxed-right))	;Lexical Environment
	      (cond ((and (= level 0)
			  (< offset li:*closure-ref-0-max*))
		     (maybe-tail-call `(,(elt li:*closure-ref-0* offset) 1)
				      dest :single-value tail-p))
		    ((= level 0)
		     (outi-for-k `(k:movei k:o1 ',(1+ offset) k:boxed))	;1-origin!
		     (maybe-tail-call `(li:closure-ref-0 2) dest :single-value tail-p))
		    (t (outi-for-k `(k:movei k:o1 ',level k:boxed))
		       (outi-for-k `(k:movei k:o2 ',(1+ offset) k:boxed))	;1-origin!
		       (maybe-tail-call `(li:closure-ref 3) dest :single-value tail-p))))))
    (cond ((and (symbolp form)
		;;; @#$#@ this should be NC::REGISTER or COMPILER::REGISTER @#$#@$
		(get form :register))
	   (outi-for-k `(k:move ,dest ,form k:boxed-right) :single-value))
	  ((null form)
	   (outi-for-k `(k:move ,dest gr:*nil* k:boxed-right) :single-value))
	  ((atom form)
	   ;; let POST-PROCESS make OPEN-CALL, otherwise it gets faked out.
	   (let ((tail-p (tail-call-p dest)))
	     (tail-call-open 'symbol:%symbol-value tail-p #'discard-temporary-frame
			     :single-value)
	     (outi-for-k `(k:movei k:o0 (quote ,form) k:boxed))
	     (maybe-tail-call `(symbol:%symbol-value 1) dest :single-value tail-p)))
	  ((eq (car form) 'local-ref)
	   (let ((lap-address (var-lap-address (cadr form))))
	     (ecase (first lap-address)
	       (arg
		(outi-for-k `(k:move ,dest ,(a-n (cadr lap-address)) k:boxed-right)
			    :single-value))
	       (local
		(read-stack-slot (cadr lap-address))
		(outi-for-k `(k:move ,dest k:md k:boxed-right) :single-value))
	       (lexical
		(do-lexical (second lap-address))))))
	  ;; LEXICAL
	  ((eq (first form) 'lexical-ref)
	   (let ((ref-index (second form)))
	     (do-lexical ref-index)))
	  ;; INSTANCE-VARIABLE ref
	  ((eq (first form) 'self-ref)
	   (iv-ref-for-k form 'li:instance-var-read dest))
	  ((memq (car form) '(function quote breakoff-function))
	   (cond ((and (eq (car form) 'quote)
		       (setq tem (k-find-constant-register (cadr form))))	;if possible, use move in hope
		  (outi-for-k `(k:move ,dest ,tem k:boxed-right) :single-value))	; it can be combined into jump.
		 (t
		  (outi-for-k `(k:movei ,dest ,form k:boxed) :single-value))))
	  (t (ferror nil "this is adrrefp-for-k?? ~s" form)))))


;;;; Compile functions which have their own special instructions.

;;; Here for a "miscellaneous" instruction (no source address field; args always on PDL).
;;; Such functions have no P2 properties.  We recognize them by their QINTCMP
;;; properties, which hold the number of args which the function takes.
(DEFUN P2MISC-for-k (INSN ARGL DEST NARGS)
  (WHEN ( NARGS (LENGTH ARGL))			;Too few args
    (warn nil nil "Wrong number of arguments to ~S." insn))
  (P2ARGC-for-k INSN ARGL (LIST (CONS NARGS '((FEF-ARG-REQ FEF-QT-EVAL))))
		DEST *P2FN*))


(DEFUN P2ARGC-for-k (FCTN ARGL DESC DEST TARGET &OPTIONAL MAPPING-TABLE)
  (LET (COUNT TOKEN-LIST AG1 DSC1 TM
	RESTART-PC
	(*stack-slots* *stack-slots*)		;any stack-slots created for call are removed by callee.
	(previous-stack-slots *stack-slots*)	;cant wait for unbinding to restore this
	(argn 0)				;  see below.
	(call-terms nil)			;total number of args being passed.
	(k-dest nil)				;destination for arg on K.
	(tail-call-switch
	  (and (tail-call-p dest fctn)
	       ( (length argl) *frame-registers-used-for-argument-passing*)))
	(our-open-frame))
    (labels ((generate-call-discard (open-frame operation dest &optional source source-type)
	       (ecase operation
		 ((nil)				;the NIL operation outputs the normal call.
		  (when (null (open-frame-there-p open-frame))
		    (fsignal "tried to output frame before it exists"))
		  (cond (tail-call-switch
			 (outi-for-k `(k:tail-call (,target ,argn)) source-type)
			 (values dest source))
			(t (outi-for-k `(k:call (,target ,argn) ,dest)
				       source-type)
			   (values dest dest))))
		 ((:exist)
		  (setf (open-frame-there-p open-frame) t))
		 ((:discard :return)
		  (cond ((open-frame-there-p open-frame)
			 (when (> *stack-slots* previous-stack-slots)
			   ;; Clean up any stack slots allocated to args for this call.
			   (generate-dealloc-stack-slots (- *stack-slots* previous-stack-slots)))
			 (cond ((not tail-call-switch)
				(outi-for-k `(k:call (li::discard-open-frame 0) k:ignore)))
			       (t
				(discard-tail-call-frame)
				(pop-frame))))
			(t (pop-frame)))
		  (values dest source)))))
      (SETQ AG1 ARGL)
      (setq call-terms (length ag1))
      (SETQ DSC1 DESC)
      (COND ((NOT (SYMBOLP FCTN))
	     (fsignal "funcall")
	     (SETQ TM FCTN))	;Non-symbolic fctn; it's address for CALL
	    (T (SETQ TM `(QUOTE-VECTOR (FUNCTION ,TARGET)))))
      (when (null ag1)		;if zero args, open frame now.
	(tail-call-open fctn tail-call-switch #'generate-call-discard :subr-value)
	; Remember which frame we opened, so we can be sure we close the same one.
	(setq our-open-frame *open-frames*))

      (PROG ()
	   L4 (COND ((NULL DSC1) (GO X2)))
	      (SETQ COUNT (CAAR DSC1))
	      (SETQ TOKEN-LIST (CADAR DSC1))
	      (COND ((MEMQ 'FEF-ARG-REST TOKEN-LIST)
		     (SETQ COUNT #o1005)))
	   L3 (setq k-dest (cond ((null ag1))  ;no args, k-dest unused, frame opened above.
				 ((zerop argn)
				  ;; If our destination is to be a new open, we pass along
				  ;; the additional information about the call to match that
				  ;; open.  Thus, once it takes effect, *OPEN-FRAMES* will be
				  ;; synchronously updated to reflect what needs to be done to
				  ;; complete or discard the call.  But it is here that the information
				  ;; is known, not when the destination finally becomes a call to
				  ;; OUTI-FOR-K.
				  (outi-open-for-k-internal (if tail-call-switch
								`(k:tail-open ,fctn)
							      `(k:open ,fctn))
							    tail-call-switch nil #'generate-call-discard)
				  (setq our-open-frame *open-frames*)
				  (if tail-call-switch
				      `(k:new-tail-open 0 ,target ,(first our-open-frame))
				    `(k:new-open 0 ,target ,(first our-open-frame))))
				 ((< argn *frame-registers-used-for-argument-passing*) (o-n argn))
				 (t 'k:r2)))	;then put it in stack-slot
	      (COND ((= 0 COUNT) (SETQ DSC1 (CDR DSC1)) (GO L4))
		    ((AND (MEMQ 'FEF-ARG-REST TOKEN-LIST)
			  (MEMQ 'FEF-QT-QT TOKEN-LIST))
		     (fsignal "Call of FEXPR")
		     (GO RET))
		    ((NULL AG1) (GO RET))	;OUT OF ARG LIST
		    ((MEMQ 'FEF-QT-QT TOKEN-LIST)
		     (if (not (zerop argn))
			 (outi-for-k `(k:move ,k-dest (quote ,(car ag1)) k:boxed-right))
		       (outi-for-k `(k:move ,k-dest (quote-vector ',(car ag1)) k:boxed-right))))
		    ((MEMQL '(FEF-QT-EVAL FEF-QT-DONTCARE) TOKEN-LIST)
		     (COND ((AND (NULL (CDR AG1))
				 (MEMQ 'LEXPR-FUNCALL TOKEN-LIST))
			    (fsignal "%spread")
			    (P2-for-k (CAR AG1)
				      (PROGN (FSIGNAL "D-PDL") 'K:R0))	;Arg to %SPREAD
			    (OUTI-for-k (LIST 'MISC k-dest '%SPREAD)))
			   (T (P2-for-k (CAR AG1) k-dest))))
		    (T (BARF TOKEN-LIST
			     'TOKEN-LIST-LOSES-P2
			     'BARF)))
	      (if (>= argn *frame-registers-used-for-argument-passing*)
		  (k-push-stack-arg k-dest))	;this will increment *stack-slots*
	      (incf argn)
	      (SETQ AG1 (CDR AG1))
	      (DECF COUNT)
	      (GO L3)
	   X2
	      (COND (AG1 (SETQ DSC1 '((#o1005 (FEF-ARG-OPT FEF-QT-EVAL))))	;Compile the rest
			 (GO L4)))		;of them; he may possibly know what he's doing
	   RET
	      (setq *stack-slots* previous-stack-slots)
	      (outi-close-for-k our-open-frame dest nil nil :subr-value)

	      (COND (MAPPING-TABLE
		     (fsignal "Can't compile the mapping-table code yet.")))
	      (COND (RESTART-PC
		     (SETQ *DROPTHRU* T)
		     (OUTF-for-k (LIST 'RESTART-TAG RESTART-PC))))
	      (COND ((AND (EQ DEST 'D-RETURN)
			  (NULL RESTART-PC))
		     (TAKE-DELAYED-TRANSFER)))
	      (RETURN NIL)

	      ))))