;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: python-x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
 "$Header: /home/pvaneynd/fakeroot/cvs2.cons.org/src/compiler/x86/vm.lisp,v 1.2.2.1 1997/07/26 17:09:07 dtc Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the VM defintion noise for the x86.
;;;
;;; Written by William Lott
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;;

(in-package :x86)


;;;; Register specs

(eval-when (compile eval)

(defmacro defreg (name offset size)
  (let ((offset-sym (symbolicate name "-OFFSET"))
	(names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
    `(progn
       (eval-when (compile eval load)
	 (defconstant ,offset-sym ,offset))
       (setf (svref ,names-vector ,offset-sym) ,(symbol-name name)))))

(defmacro defregset (name &rest regs)
  `(eval-when (compile eval load)
     (defconstant ,name
       (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))

); eval-when 

;;; Byte registers.
;;;
;;; Note: the encoding here is different then that used by the chip.  We
;;; use this encoding so that the compiler thinks that AX (and EAX) overlap
;;; AL and AH instead of AL and CL.
;;; 
(eval-when (compile load eval)
  (defvar *byte-register-names* (make-array 8 :initial-element nil)))
;;;
(defreg al 0 :byte)
(defreg ah 1 :byte)
(defreg cl 2 :byte)
(defreg ch 3 :byte)
(defreg dl 4 :byte)
(defreg dh 5 :byte)
(defreg bl 6 :byte)
(defreg bh 7 :byte)
;;;
(defregset byte-regs al ah cl ch dl dh bl bh)

;;; Word registers.
;;;
(eval-when (compile load eval)
  (defvar *word-register-names* (make-array 16 :initial-element nil)))
;;;
(defreg ax 0 :word)
(defreg cx 2 :word)
(defreg dx 4 :word)
(defreg bx 6 :word)
(defreg sp 8 :word)
(defreg bp 10 :word)
(defreg si 12 :word)
(defreg di 14 :word)
;;;
(defregset word-regs ax cx dx bx si di)

;;; Double Word registers.
;;;
(eval-when (compile load eval)
  (defvar *dword-register-names* (make-array 16 :initial-element nil)))
;;;
(defreg eax 0 :dword)
(defreg ecx 2 :dword)
(defreg edx 4 :dword)
(defreg ebx 6 :dword)
(defreg esp 8 :dword)
(defreg ebp 10 :dword)
(defreg esi 12 :dword)
(defreg edi 14 :dword)
;;;
(defregset dword-regs eax ecx edx ebx esi edi)

;;; added by jrd
(eval-when (compile load eval)
  (defvar *float-register-names* (make-array 8 :initial-element nil)))
(defreg fr0 0 :float)
(defreg fr1 1 :float)
(defreg fr2 2 :float)
(defreg fr3 3 :float)
(defreg fr4 4 :float)
(defreg fr5 5 :float)
(defreg fr6 6 :float)
(defreg fr7 7 :float)
(defregset float-regs fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)

;(defvar *double-float-register-names* (make-array 8 :initial-element nil))
;(defreg dfr0 0 :double-float)
;(defreg dfr1 1 :double-float)
;(defreg dfr2 2 :double-float)
;(defreg dfr3 3 :double-float)
;(defreg dfr4 4 :double-float)
;(defreg dfr5 5 :double-float)
;(defreg dfr6 6 :double-float)
;(defreg dfr7 7 :double-float)
;(defregset double-float-regs dfr0 dfr1 dfr2 dfr3 dfr4 dfr5 dfr6 dfr7)


;;;; SB definitions.

;;; Despite the fact that there are only 8 different registers, we consider
;;; them 16 in order to describe the overlap of byte registers.  The only
;;; thing we need to represent is what registers overlap.  Therefore, we
;;; consider bytes to take one unit, and words or dwords to take two.  We
;;; don't need to tell the difference between words and dwords, because
;;; you can't put two words in a dword.

(define-storage-base registers :finite :size 16)

;;;
;;; jrd changed this from size 1 to size 8.  it doesn't seem to make much
;;; sense to use the 387's idea of a stack.  8 separate registers is easier
;;; to deal with.
;;; (define-storage-base float-registers :finite :size 1)
(define-storage-base float-registers :finite :size 8)

(define-storage-base stack :unbounded :size 8)
(define-storage-base constant :non-packed)
(define-storage-base immediate-constant :non-packed)
(define-storage-base noise :unbounded :size 2)



;;;; SC definitions.

;;;
;;; Handy macro so we don't have to keep changing all the numbers whenever
;;; we insert a new storage class.
;;; 
(defmacro define-storage-classes (&rest classes)
  (collect ((forms))
    (let ((index 0))
      (dolist (class classes)
	(let* ((sc-name (car class))
	       (constant-name (symbolicate sc-name "-SC-NUMBER")))
	  (forms `(define-storage-class ,sc-name ,index
		    ,@(cdr class)))
	  (forms `(defconstant ,constant-name ,index))
	  (forms `(export ',constant-name))
	  (incf index))))
    `(progn
       ,@(forms))))

(define-storage-classes

  ;; Non-immediate contstants in the constant pool
  (constant constant)

    ;; Some FP constants can be generated in the i387 silicon.

    (fp-single-constant immediate-constant)
    (fp-double-constant immediate-constant)
    
  (immediate immediate-constant)

  ;; **** The stacks.

  ;; The control stack.
  (descriptor-stack stack)		; may be pointers, scanned by GC
  (immediate-stack stack)		; isn't pointers, ignored by GC

  ;; The non-descriptor stacks.
  (signed-stack stack)			; (signed-byte 32)
  (unsigned-stack stack)		; (unsigned-byte 32)
  (base-char-stack stack)		; non-descriptor characters.
  (sap-stack stack)			; System area pointers.
  (single-stack stack)			; single-floats
  (double-stack stack :element-size 2)	; double floats.

  ;; **** Magic SCs.

  (ignore-me noise)

  ;; **** Things that can go in the integer registers.

  ;; We don't have to distinguish between descriptor and non-descriptor
  ;; registers, because we dump explicit information about what descriptor
  ;; values are live at any potential GC point.  Therefore, we only different
  ;; scs to distinguish between descriptor and non-descriptor values and
  ;; to specify size.

  (any-reg registers
	   :locations #.dword-regs
	   :element-size 2
	   :reserve-locations (#.eax-offset)
	   :constant-scs (immediate)
	   :save-p t
	   :alternate-scs (immediate-stack))

  ;; Pointer descriptor objects.  Must be seen by GC.
  (descriptor-reg registers
		  :locations #.dword-regs
		  :element-size 2
		  :reserve-locations (#.eax-offset)
		  :constant-scs
		  (constant immediate 
			    ;; zzz jrd added IMMEDIATE-STACK here.  
			    ;; it seems right, and references elsewhere
			    ;; in the code suggest that we expect to be
			    ;; able to do this.  see 
			    ;; DEFINE-MOVE-VOP MOVE :MOVE in MOVE.LISP
			    
			    ;; zzz this may not be right after all
			    ;; immediate-stack
			    )
		  :save-p t
		  :alternate-scs (descriptor-stack))

  ;; Non-Descriptor characters
  (base-char-reg registers
		 :locations #.byte-regs
		 :reserve-locations (#.ah-offset #.al-offset)
		 :constant-scs (immediate)
		 :save-p t
		 :alternate-scs (base-char-stack))

  ;; Non-Descriptor SAP's (arbitrary pointers into address space)
  (sap-reg registers
	   :locations #.dword-regs
	   :element-size 2
	   :reserve-locations (#.eax-offset)
	   :constant-scs (immediate)
	   :save-p t
	   :alternate-scs (sap-stack))

  ;; Non-Descriptor (signed or unsigned) numbers.
  (signed-reg registers
	      :locations #.dword-regs
	      :element-size 2
	      :reserve-locations (#.eax-offset)
	      :constant-scs (immediate)
	      :save-p t
	      :alternate-scs (signed-stack))
  (unsigned-reg registers
		:locations #.dword-regs
		:element-size 2
		:reserve-locations (#.eax-offset)
		:constant-scs (immediate)
		:save-p t
		:alternate-scs (unsigned-stack))

  ;; Random objects that must not be seen by GC.  Used only as temporaries.
  (dword-reg registers
	     :locations #.dword-regs
	     :element-size 2
	     :reserve-locations (#.eax-offset))
  (word-reg registers
	    :locations #.word-regs
	    :element-size 2
	    :reserve-locations (#.ax-offset))
  (byte-reg registers
	    :locations #.byte-regs
	    :reserve-locations (#.al-offset #.ah-offset))

  ;; **** Things that can go in the floating point registers.

  ;; Non-Descriptor single-floats.
  (single-reg float-registers
	      :locations (0 1 2 3 4 5 6 7)
	      :constant-scs (fp-single-constant)
	      :save-p t
	      :alternate-scs (single-stack))

  ;; Non-Descriptor double-floats.
  (double-reg float-registers
	      :locations (0 1 2 3 4 5 6 7)
	      :constant-scs (fp-double-constant)
	      :save-p t
	      :alternate-scs (double-stack))

  ;; A catch or unwind block.
  (catch-block stack :element-size vm:catch-block-size)
  
  ;; added by jrd.  need to define non-descriptor-reg-sc-number for the
  ;; debug code, among others.  this doesn't actually get used in any code.
  (non-descriptor-reg registers
		      :locations #.dword-regs
		      :element-size 2
		      :reserve-locations ())
  ;; this one too
  (interior-reg registers
		      :locations #.dword-regs
		      :element-size 2
		      :reserve-locations ())
  )

;;; zzz added by jrd; has somebody been changing names of these things on me?
(export 'control-stack-sc-number)
(defconstant control-stack-sc-number descriptor-stack-sc-number)


(eval-when (compile load eval)

(defconstant byte-sc-names '(base-char-reg byte-reg base-char-stack))
(defconstant word-sc-names '(word-reg))
(defconstant dword-sc-names
  '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg dword-reg
    descriptor-stack immediate-stack signed-stack unsigned-stack
    sap-stack single-stack constant))

;;;
;;; added by jrd.  I guess the right thing to do is to treat floats
;;; as a separate size...
;;;
;;; These are used to (at least) determine operand size.
(defconstant float-sc-names '(single-reg))
(defconstant double-sc-names '(double-reg double-stack))
)



;;;; Random TNs for the various registers.

(eval-when (compile eval)
  (defmacro def-random-reg-tns (sc-name &rest reg-names)
    (collect ((forms))
      (dolist (reg-name reg-names)
	(let ((reg-tn-name (symbolicate reg-name "-TN"))
	      (reg-offset-name (symbolicate reg-name "-OFFSET")))
	  ;;(forms `(export ',reg-tn-name))
	  (forms `(defparameter ,reg-tn-name
		    (make-random-tn :kind :normal
				    :sc (sc-or-lose ',sc-name)
				    :offset ,reg-offset-name)))))
      `(progn ,@(forms)))))

(def-random-reg-tns dword-reg eax ebx ecx edx ebp esp edi esi)
(def-random-reg-tns word-reg ax bx cx dx bp sp di si)
(def-random-reg-tns byte-reg al ah bl bh cl ch dl dh)

;; added by jrd
(def-random-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)

;; Added by pw.

(defparameter fp-single-constant-tn
  (make-random-tn :kind :normal
		  :sc (sc-or-lose 'fp-single-constant)
		  :offset 31))		; Offset doesn't get used.
(defparameter fp-double-constant-tn
  (make-random-tn :kind :normal
		  :sc (sc-or-lose 'fp-single-constant)
		  :offset 31))




;;; Immediate-Constant-SC
;;;
;;; Basically, if it's easier to represent the value as an immediate in
;;; some instruction instead of in the constants pool, then return
;;; the immediate SC.
;;;

#+nil ;; pw-- the way it was.
(def-vm-support-routine immediate-constant-sc (value)
  (if (or (and (symbolp value) (static-symbol-p value))
	  #-cross-compiler
	  (typep value 'fixnum)
	  #+cross-compiler
	  (and (typep value 'integer)
	       (>= value (info variable constant-value 'most-negative-fixnum))
	       (<= value (info variable constant-value 'most-positive-fixnum)))
	  #-cross-compiler
	  (typep value 'system-area-pointer)
	  (typep value 
                 #+lispworks3 'lisp::base-character 
                 #-lispworks3 'base-char))
      (sc-number-or-lose 'immediate *backend*)
      nil))

;;; I probably should use double-from-bits here
;;; to avoid any compilation errors, but lets see
;;; what happens. These should be part of lisp like PI?
(defconstant i387-lg2 3.010299956639811952137389d0)
(defconstant i387-ln2 0.6931471805599453094172321d0)
(defconstant i387-l10 2.3025850929940456840179915d0)
(defconstant i387-l2e (/ i387-ln2))
(defconstant i387-l2t (/ i387-l10 i387-ln2))
(export '(i387-lg2 i387-ln2 i387-l10 i387-l2e i387-l2t))


;;; pw-- A good try and it works, but it also results in
;;; extra consing when the constant is an argument to
;;; some function. The descriptor from the constants vector
;;; would normally be passed instead. DTC processes zero and
;;; one in move-from-single|double as static symbols to
;;; save on CV space for these common values.

(def-vm-support-routine immediate-constant-sc (value)
  (typecase value
    ((or fixnum system-area-pointer character)
     (sc-number-or-lose 'immediate *backend*))
    (symbol
     (if (static-symbol-p value)
	 (sc-number-or-lose 'immediate *backend*)
	 nil))
    (single-float
     (when (or (eql value 0f0) (eql value 1f0))
       (sc-number-or-lose 'fp-single-constant *backend*)))
    (double-float
     (when (or (eql value 0d0) (eql value 1d0))
       (sc-number-or-lose 'fp-double-constant *backend*)))))


;;;; Function Call Parameters

;;; Offsets of special stack frame locations
(defconstant old-fp-save-offset 0)
(defconstant return-pc-save-offset 1)
(defconstant code-save-offset 2)


;;; names of these things seem to have changed.  these aliases by jrd
(defconstant ocfp-save-offset old-fp-save-offset)
(defconstant lra-save-offset return-pc-save-offset)

(defconstant cfp-offset ebp-offset)	; pfw - needed by stuff in /code
					; related to sigcontext stuff
;;; The number of arguments/return values passed in registers.
;;;
(defconstant register-arg-count 3)

;;; Names, Offsets, and TNs to use for the argument registers.
;;; 
(defconstant register-arg-names '(edx edi esi))
(defregset register-arg-offsets edx edi esi)
(defparameter register-arg-tns (list edx-tn edi-tn esi-tn))

;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
;;;
;;; This is used by the debugger.
;;;
(export 'single-value-return-byte-offset)
(defconstant single-value-return-byte-offset 2)


;;; LOCATION-PRINT-NAME  --  Interface
;;;
;;;    This function is called by debug output routines that want a pretty name
;;; for a TN's location.  It returns a thing that can be printed with PRINC.
;;;
(def-vm-support-routine location-print-name (tn)
  (declare (type tn tn))
  (let* ((sc (tn-sc tn))
	 (sb (sb-name (sc-sb sc)))
	 (offset (tn-offset tn)))
    (ecase sb
      (registers
       (let* ((sc-name (sc-name sc))
	      (name-vec (cond ((member sc-name byte-sc-names)
			       *byte-register-names*)
			      ((member sc-name word-sc-names)
			       *word-register-names*)
			      ((member sc-name dword-sc-names)
			       *dword-register-names*))))
	 (or (and name-vec
		  (< -1 offset (length name-vec))
		  (svref name-vec offset))
	     (format nil "<Unknown Reg: off=~D, sc=~A>" offset sc-name))))
      ;; (float-registers "FloatStackTop")
      (float-registers (format nil "FR~D" offset))
      (stack (format nil "S~D" offset))
      (constant (format nil "Const~D" offset))
      (immediate-constant "Immed")
      (noise (symbol-name (sc-name sc))))))
