Skip to content
Snippets Groups Projects
vm.lisp 14.7 KiB
Newer Older
ram's avatar
ram committed
;;; -*- 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/vm.lisp,v 1.3 1997/07/26 17:05:10 dtc Exp $")
ram's avatar
ram committed
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419
;;;
;;; **********************************************************************
;;;
;;; 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))
ram's avatar
ram committed
       (sc-number-or-lose 'fp-single-constant *backend*)))
    (double-float
     (when (or (eql value 0d0) (eql value 1d0))
ram's avatar
ram committed
       (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))))))