home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / vm.lisp < prev   
Encoding:
Text File  |  1991-12-22  |  20.5 KB  |  685 lines
  1. ;;; -*- Package: RT; Log: c.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public
  6. ;;; domain.  If you want to use this code or any part of CMU Common
  7. ;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; This file contains the VM definition for the IBM RT.
  11. ;;;
  12. ;;; Written by William Lott, Rob Maclachlan, and Bill Chiles.
  13. ;;;
  14.  
  15. (in-package "RT")
  16.  
  17.  
  18.  
  19. ;;;; SB and SC definition:
  20.  
  21. (define-storage-base registers :finite :size 16)
  22. (define-storage-base mc68881-float-registers :finite :size 8)
  23. (define-storage-base AFPA-float-registers :finite :size 64)
  24. (define-storage-base FPA-float-registers :finite :size 16)
  25. (define-storage-base control-stack :unbounded :size 8)
  26. (define-storage-base non-descriptor-stack :unbounded :size 0)
  27. ;; These are constants in components.
  28. (define-storage-base constant :non-packed)
  29. ;; Anything I can cookup out of nowhere and store somewhere.
  30. (define-storage-base immediate-constant :non-packed)
  31.  
  32. ;;;
  33. ;;; Handy macro so we don't have to keep changing all the numbers whenever
  34. ;;; we insert a new storage class.
  35. ;;; 
  36. (defmacro define-storage-classes (&rest classes)
  37.   (do ((forms (list 'progn)
  38.           (let* ((class (car classes))
  39.              (sc-name (car class))
  40.              (constant-name (intern (concatenate 'simple-string
  41.                              (string sc-name)
  42.                              "-SC-NUMBER"))))
  43.         (list* `(define-storage-class ,sc-name ,index
  44.               ,@(cdr class))
  45.                `(eval-when (compile load eval)
  46.               (defconstant ,constant-name ,index))
  47.                `(export ',constant-name)
  48.                forms)))
  49.        (index 0 (1+ index))
  50.        (classes classes (cdr classes)))
  51.       ((null classes)
  52.        (nreverse forms))))
  53.  
  54. (define-storage-classes
  55.  
  56.   ;; Non-immediate contstants in the constant pool
  57.   (constant constant)
  58.  
  59.  
  60.   (immediate immediate-constant)
  61.   (null immediate-constant)
  62.  
  63.  
  64.   ;; The control stack.  (Scanned by GC)
  65.   (control-stack control-stack)
  66.  
  67.   ;; The non-descriptor stack SC's.
  68.   (signed-stack non-descriptor-stack) ; (signed-byte 32)
  69.   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
  70.   (base-char-stack non-descriptor-stack) ; non-descriptor characters.
  71.   (sap-stack non-descriptor-stack) ; System area pointers.
  72.   (single-stack non-descriptor-stack) ; single-floats
  73.   (double-stack non-descriptor-stack :element-size 2) ; double floats.
  74.  
  75.  
  76.   ;; **** Things that can go in the non-descriptor registers.
  77.  
  78.   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
  79.   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
  80.   (any-reg registers
  81.    :locations (9 10 11 12 13 14 0 2 3 4)
  82.    :constant-scs (immediate)
  83.    :reserve-locations (0 2 3 4)
  84.    :save-p t
  85.    :alternate-scs (control-stack))
  86.  
  87.   ;; Descriptor objects.  Must be seen by GC.
  88.   (descriptor-reg registers
  89.    :locations (9 10 11 12 13 14)
  90.    ;; Immediate (and constant) for moving NULL around (at least).
  91.    :constant-scs (constant immediate null)
  92.    :save-p t
  93.    :alternate-scs (control-stack))
  94.  
  95.   ;; Non-Descriptor characters.
  96.   (base-char-reg registers
  97.    :locations (0 2 3 4)
  98.    :constant-scs (immediate)
  99.    :save-p t
  100.    :alternate-scs (base-char-stack))
  101.  
  102.   ;; Non-Descriptor SAP's (arbitrary pointers into address space).
  103.   (sap-reg registers
  104.    ;; Exclude R0 here because the instructions we would like to use with sap
  105.    ;; TN's use R0 as the constant zero instead of using the contents of R0.
  106.    :locations (2 3 4)
  107.    :constant-scs (immediate)
  108.    :save-p t
  109.    :alternate-scs (sap-stack))
  110.  
  111.   ;; Non-Descriptor (signed or unsigned) numbers.
  112.   (signed-reg registers
  113.    :locations (0 2 3 4)
  114.    :constant-scs (immediate)
  115.    :save-p t
  116.    :alternate-scs (signed-stack))
  117.   (unsigned-reg registers
  118.    :locations (0 2 3 4)
  119.    :constant-scs (immediate)
  120.    :save-p t
  121.    :alternate-scs (unsigned-stack))
  122.  
  123.   ;; Random objects that must not be seen by GC.  Used only as temporaries.
  124.   (non-descriptor-reg registers
  125.    :locations (0 2 3 4))
  126.  
  127.   ;; Word-aligned pointers that cannot be in R0.  Used for temporaries and to
  128.   ;; hold stack pointers.
  129.   (word-pointer-reg registers
  130.    :locations (2 3 4 9 10 11 12 13 14)
  131.    :save-p t
  132.    :alternate-scs (control-stack))
  133.  
  134.   ;; Pointers to the interior of objects.  Used only as an temporary.
  135.   (interior-reg registers
  136.    :locations (15))
  137.  
  138.  
  139.   ;; **** Things that can go in the floating point registers.
  140.  
  141.   ;; Non-Descriptor mc68881-single-floats.
  142.   (mc68881-single-reg mc68881-float-registers
  143.    :locations (0 1 2 3 4 5 6 7)
  144.    :constant-scs ()
  145.    :save-p t
  146.    :alternate-scs (single-stack))
  147.   ;; Non-Descriptor mc68881-double-floats.
  148.   (mc68881-double-reg mc68881-float-registers
  149.    :locations (0 1 2 3 4 5 6 7)
  150.    :constant-scs ()
  151.    :save-p t
  152.    :alternate-scs (double-stack))
  153.  
  154.   ;; Non-Descriptor FPA-single-floats.
  155.   (FPA-single-reg FPA-float-registers
  156.    ;; 14 and 15 are status and exception registers.
  157.    :locations (0 1 2 3 4 5 6 7 8 9 10 11 12 13)
  158.    :constant-scs ()
  159.    :save-p t
  160.    :alternate-scs (single-stack))
  161.   ;; Non-Descriptor FPA-double-floats.
  162.   (FPA-double-reg FPA-float-registers
  163.    :locations (0 2 4 6 8 10 12) ;14 and 15 are status and exception registers.
  164.    :element-size 2
  165.    :constant-scs ()
  166.    :save-p t
  167.    :alternate-scs (double-stack))
  168.  
  169.   ;; Non-Descriptor AFPA-single-floats.  0,1 reserved for loading "immediate"
  170.   ;; operands.
  171.   (AFPA-single-reg AFPA-float-registers
  172.    :locations (2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
  173.            24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44
  174.            45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63)
  175.    :constant-scs ()
  176.    :save-p t
  177.    :alternate-scs (single-stack))
  178.   ;; Non-Descriptor AFPA-double-floats.  0 reserved for loading "immediate"
  179.   ;; operands.
  180.   (AFPA-double-reg AFPA-float-registers
  181.    :locations (2 4 6 8 10 12 14 16 18 20 22 24 26 28
  182.            30 32 34 36 38 40 42 44 46 48 50 52 54 56 58 60 62)
  183.    :element-size 2
  184.    :constant-scs ()
  185.    :save-p t
  186.    :alternate-scs (double-stack))
  187.  
  188.  
  189.   ;; A catch or unwind block.
  190.   (catch-block control-stack :element-size vm:catch-block-size))
  191.  
  192.  
  193. (export '(single-reg-sc-number double-reg-sc-number))
  194. (defconstant single-reg-sc-number
  195.   (list mc68881-single-reg-sc-number
  196.     FPA-single-reg-sc-number
  197.     AFPA-single-reg-sc-number))
  198. (defconstant double-reg-sc-number
  199.   (list mc68881-double-reg-sc-number
  200.     FPA-double-reg-sc-number
  201.     AFPA-double-reg-sc-number))
  202.  
  203.  
  204. ;;;; Primitive Type Definitions
  205.  
  206. ;;; *any-primitive-type*
  207. ;;;
  208. ;;; Other VOP/VM definition files use this when writing interface code for the
  209. ;;; compiler.
  210. ;;;
  211. (def-primitive-type t (descriptor-reg))
  212. (defvar *any-primitive-type* (primitive-type-or-lose 't))
  213. (setf (c:backend-any-primitive-type c:*target-backend*)
  214.       (c:primitive-type-or-lose 't))
  215.  
  216. ;;; Primitive integer types that fit in registers.
  217. ;;;
  218. (def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
  219.   :type (unsigned-byte 29))
  220. (def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
  221.   :type (unsigned-byte 31))
  222. (def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
  223.   :type (unsigned-byte 32))
  224. (def-primitive-type fixnum (any-reg signed-reg)
  225.   :type (signed-byte 30))
  226. (def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
  227.   :type (signed-byte 32))
  228. (def-primitive-type word-pointer (word-pointer-reg descriptor-reg)
  229.   :type fixnum)
  230.  
  231.  
  232. ;;; *word-pointer-type*
  233. ;;;
  234. (defvar *word-pointer-type* (primitive-type-or-lose 'word-pointer))
  235.  
  236.  
  237. ;;; *fixnum-primitive-type*
  238. ;;;
  239. ;;; Other VOP/VM definition files use this when writing interface code for the
  240. ;;; compiler.
  241. ;;;
  242. (defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
  243.  
  244. (def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
  245. (def-primitive-type-alias unsigned-num (:or unsigned-byte-32
  246.                         unsigned-byte-31
  247.                         positive-fixnum))
  248. (def-primitive-type-alias signed-num (:or signed-byte-32
  249.                       fixnum
  250.                       unsigned-byte-31
  251.                       positive-fixnum))
  252.  
  253. ;;; Other primitive immediate types.
  254. (def-primitive-type base-char (base-char-reg any-reg))
  255.  
  256. ;;; Primitive pointer types.
  257. ;;; 
  258. (def-primitive-type function (descriptor-reg))
  259. (def-primitive-type list (descriptor-reg))
  260. (def-primitive-type structure (descriptor-reg))
  261.  
  262. ;;; Primitive other-pointer number types.
  263. ;;; 
  264. (def-primitive-type bignum (descriptor-reg))
  265. (def-primitive-type ratio (descriptor-reg))
  266. (def-primitive-type complex (descriptor-reg))
  267. (def-primitive-type mc68881-single-float (mc68881-single-reg descriptor-reg)
  268.   :type single-float)
  269. (def-primitive-type mc68881-double-float (mc68881-double-reg descriptor-reg)
  270.   :type double-float)
  271. (def-primitive-type FPA-single-float (FPA-single-reg descriptor-reg)
  272.   :type single-float)
  273. (def-primitive-type FPA-double-float (FPA-double-reg descriptor-reg)
  274.   :type double-float)
  275. (def-primitive-type AFPA-single-float (AFPA-single-reg descriptor-reg)
  276.   :type single-float)
  277. (def-primitive-type AFPA-double-float (AFPA-double-reg descriptor-reg)
  278.   :type double-float)
  279. (def-primitive-type any-single-float (descriptor-reg)
  280.   :type single-float)
  281. (def-primitive-type any-double-float (descriptor-reg)
  282.   :type double-float)
  283.  
  284. ;;; Primitive other-pointer array types.
  285. ;;; 
  286. (def-primitive-type simple-string (descriptor-reg) :type simple-base-string)
  287. (def-primitive-type simple-bit-vector (descriptor-reg))
  288. (def-primitive-type simple-vector (descriptor-reg))
  289. (def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
  290.   :type (simple-array (unsigned-byte 2) (*)))
  291. (def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
  292.   :type (simple-array (unsigned-byte 4) (*)))
  293. (def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
  294.   :type (simple-array (unsigned-byte 8) (*)))
  295. (def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
  296.   :type (simple-array (unsigned-byte 16) (*)))
  297. (def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
  298.   :type (simple-array (unsigned-byte 32) (*)))
  299. (def-primitive-type simple-array-single-float (descriptor-reg)
  300.   :type (simple-array single-float (*)))
  301. (def-primitive-type simple-array-double-float (descriptor-reg)
  302.   :type (simple-array double-float (*)))
  303.  
  304. ;;; Note: The complex array types are not included, because it is pointless to
  305. ;;; restrict VOPs to them.
  306.  
  307. ;;; Other primitive other-pointer types.
  308. ;;; 
  309. (def-primitive-type system-area-pointer (sap-reg descriptor-reg))
  310. (def-primitive-type weak-pointer (descriptor-reg))
  311.  
  312. ;;; Random primitive types that don't exist at the LISP level.
  313. ;;; 
  314. (def-primitive-type random (non-descriptor-reg) :type nil)
  315. (def-primitive-type interior (interior-reg) :type nil)
  316. (def-primitive-type catch-block (catch-block) :type nil)
  317.  
  318.  
  319.  
  320.  
  321. ;;;; PRIMITIVE-TYPE-OF and friends.
  322.  
  323. ;;; PRIMITIVE-TYPE-OF  --  Interface.
  324. ;;;
  325. ;;; Return the most restrictive primitive type that contains Object.
  326. ;;;
  327. (def-vm-support-routine primitive-type-of (object)
  328.   (let ((type (ctype-of object)))
  329.     (cond ((not (member-type-p type)) (primitive-type type))
  330.       ((equal (member-type-members type) '(nil))
  331.        (primitive-type-or-lose 'list))
  332.       (t
  333.        *any-primitive-type*))))
  334.  
  335. ;;; 
  336. (defvar *simple-array-primitive-types*
  337.   '((base-char . simple-string)
  338.     (string-char . simple-string)
  339.     (bit . simple-bit-vector)
  340.     ((unsigned-byte 2) . simple-array-unsigned-byte-2)
  341.     ((unsigned-byte 4) . simple-array-unsigned-byte-4)
  342.     ((unsigned-byte 8) . simple-array-unsigned-byte-8)
  343.     ((unsigned-byte 16) . simple-array-unsigned-byte-16)
  344.     ((unsigned-byte 32) . simple-array-unsigned-byte-32)
  345.     (single-float . simple-array-single-float)
  346.     (double-float . simple-array-double-float)
  347.     (t . simple-vector))
  348.   "An a-list for mapping simple array element types to their
  349.   corresponding primitive types.")
  350.  
  351. (defvar *target-float-hardware*)
  352.  
  353. ;;; PRIMITIVE-TYPE -- Internal Interface.
  354. ;;;
  355. ;;; Return the primitive type corresponding to a type descriptor
  356. ;;; structure. The second value is true when the primitive type is
  357. ;;; exactly equivalent to the argument Lisp type.
  358. ;;;
  359. ;;; In a bootstrapping situation, we should be careful to use the
  360. ;;; correct values for the system parameters.
  361. ;;;
  362. (def-vm-support-routine primitive-type (type)
  363.   (declare (type ctype type))
  364.   (macrolet ((any () '(values *any-primitive-type* nil))
  365.          (exactly (type) `(values (primitive-type-or-lose ',type) t))
  366.          (part-of (type) `(values (primitive-type-or-lose ',type) nil)))
  367.     (etypecase type
  368.       (numeric-type
  369.        (let ((lo (numeric-type-low type))
  370.          (hi (numeric-type-high type)))
  371.      (case (numeric-type-complexp type)
  372.        (:real
  373.         (case (numeric-type-class type)
  374.           (integer
  375.            (cond ((and hi lo)
  376.               (dolist (spec
  377.                    '((positive-fixnum 0 #.(1- (ash 1 29)))
  378.                  (unsigned-byte-31 0 #.(1- (ash 1 31)))
  379.                  (unsigned-byte-32 0 #.(1- (ash 1 32)))
  380.                  (fixnum #.(ash -1 29) #.(1- (ash 1 29)))
  381.                  (signed-byte-32 #.(ash -1 31)
  382.                          #.(1- (ash 1 31))))
  383.                    (if (or (< hi (ash -1 29))
  384.                        (> lo (1- (ash 1 29))))
  385.                    (part-of bignum)
  386.                    (any)))
  387.             (let ((type (car spec))
  388.                   (min (cadr spec))
  389.                   (max (caddr spec)))
  390.               (when (<= min lo hi max)
  391.                 (return (values (primitive-type-or-lose type)
  392.                         (and (= lo min) (= hi max))))))))
  393.              ((or (and hi (< hi most-negative-fixnum))
  394.               (and lo (> lo most-positive-fixnum)))
  395.               (part-of bignum))
  396.              (t
  397.               (any))))
  398.           (float
  399.            (float-primitive-type lo hi type))
  400.           (t
  401.            (any))))
  402.        (:complex
  403.         (part-of complex))
  404.        (t
  405.         (any)))))
  406.       (array-type
  407.        (if (array-type-complexp type)
  408.        (any)
  409.        (let* ((dims (array-type-dimensions type))
  410.           (etype (array-type-specialized-element-type type))
  411.           (type-spec (type-specifier etype))
  412.           (ptype (cdr (assoc type-spec *simple-array-primitive-types*
  413.                      :test #'equal))))
  414.          (if (and (consp dims) (null (rest dims)) ptype)
  415.          (values (primitive-type-or-lose ptype) (eq (first dims) '*))
  416.          (any)))))
  417.       (union-type
  418.        (if (type= type (specifier-type 'list))
  419.        (exactly list)
  420.        (let ((types (union-type-types type)))
  421.          (multiple-value-bind (res exact)
  422.                   (primitive-type (first types))
  423.            (dolist (type (rest types) (values res exact))
  424.          (multiple-value-bind (ptype ptype-exact)
  425.                       (primitive-type type)
  426.            (unless ptype-exact (setq exact nil))
  427.            (unless (eq ptype res)
  428.              (return (any)))))))))
  429.       (member-type
  430.        (let* ((members (member-type-members type))
  431.           (res (primitive-type-of (first members))))
  432.      (dolist (mem (rest members) (values res nil))
  433.        (unless (eq (primitive-type-of mem) res)
  434.          (return (values *any-primitive-type* nil))))))
  435.       (named-type
  436.        (case (named-type-name type)
  437.      ((t bignum ratio complex function system-area-pointer weak-pointer
  438.          structure)
  439.       (values (primitive-type-or-lose (named-type-name type)) t))
  440.      ((character base-char string-char)
  441.       (exactly base-char))
  442.      (standard-char
  443.       (part-of base-char))
  444.      (cons
  445.       (part-of list))
  446.      (t
  447.       (any))))
  448.       (function-type
  449.        (exactly function))
  450.       (structure-type
  451.        (part-of structure))
  452.       (ctype
  453.        (any)))))
  454.  
  455. ;;; FLOAT-PRIMITIVE-TYPE -- Internal.
  456. ;;;
  457. (defun float-primitive-type (lo hi type)
  458.   (let ((exact (and (null lo) (null hi))))
  459.     (case (numeric-type-format type)
  460.       ((short-float single-float)
  461.        (ecase *target-float-hardware*
  462.      (:mc68881
  463.       (values (primitive-type-or-lose 'mc68881-single-float) exact))
  464.      (:fpa
  465.       (values (primitive-type-or-lose 'fpa-single-float) exact))
  466.      (:afpa
  467.       (values (primitive-type-or-lose 'afpa-single-float) exact))
  468.      (:any
  469.       (values (primitive-type-or-lose 'any-single-float) exact))))
  470.       ((double-float long-float)
  471.        (ecase *target-float-hardware*
  472.      (:mc68881
  473.       (values (primitive-type-or-lose 'mc68881-double-float) exact))
  474.      (:fpa
  475.       (values (primitive-type-or-lose 'fpa-double-float) exact))
  476.      (:afpa
  477.       (values (primitive-type-or-lose 'afpa-double-float) exact))
  478.      (:any
  479.       (values (primitive-type-or-lose 'any-double-float) exact))))
  480.       (t
  481.        (values *any-primitive-type* nil)))))
  482.  
  483.  
  484.  
  485. ;;;; Magical Registers
  486.  
  487. ;;; Other VOP/VM definition files use the definitions on this page when writing
  488. ;;; interface code for the compiler.
  489. ;;;
  490.  
  491. (eval-when (compile eval load)
  492.   (defconstant nargs-offset 0)
  493.   (defconstant nsp-offset 1)
  494.   (defconstant nl0-offset 2)
  495.   (defconstant ocfp-offset 3)
  496.   (defconstant nfp-offset 4)
  497.   (defconstant csp-offset 5)
  498.   (defconstant cfp-offset 6)
  499.   (defconstant code-offset 7)
  500.   (defconstant null-offset 8)
  501.   (defconstant cname-offset 9)
  502.   (defconstant lexenv-offset 10)
  503.   (defconstant lra-offset 11)
  504.   (defconstant a0-offset 12)
  505.   (defconstant a1-offset 13)
  506.   (defconstant a2-offset 14)
  507.   (defconstant lip-offset 15))
  508.  
  509. ;;; Lisp-interior-pointer register.
  510. ;;;
  511. (defparameter lip-tn
  512.   (make-random-tn :kind :normal
  513.           :sc (sc-or-lose 'any-reg)
  514.           :offset lip-offset))
  515.  
  516. ;;; Nil.
  517. ;;;
  518. (defparameter null-tn
  519.   (make-random-tn :kind :normal
  520.           :sc (sc-or-lose 'descriptor-reg)
  521.           :offset null-offset))
  522.  
  523.  
  524. ;;; Frame Pointer.
  525. ;;;
  526. (defparameter cfp-tn
  527.   (make-random-tn :kind :normal
  528.           :sc (sc-or-lose 'any-reg)
  529.           :offset cfp-offset))
  530.  
  531.  
  532. ;;; Control stack pointer.
  533. ;;;
  534. (defparameter csp-tn
  535.   (make-random-tn :kind :normal
  536.           :sc (sc-or-lose 'any-reg)
  537.           :offset csp-offset))
  538.  
  539. ;;; Number stack pointer.
  540. ;;;
  541. (defparameter nsp-tn
  542.   (make-random-tn :kind :normal
  543.           :sc (sc-or-lose 'any-reg)
  544.           :offset nsp-offset))
  545.  
  546. ;;; Code Pointer.
  547. ;;;
  548. (defparameter code-tn
  549.   (make-random-tn :kind :normal
  550.           :sc (sc-or-lose 'any-reg)
  551.           :offset code-offset))
  552.  
  553. ;;; Random non-descriptor tn
  554. ;;;
  555. (defparameter nl0-tn
  556.   (make-random-tn :kind :normal
  557.           :sc (sc-or-lose 'non-descriptor-reg)
  558.           :offset nl0-offset))
  559.  
  560.  
  561.  
  562. ;;;; Side-Effect Classes
  563.  
  564. (def-boolean-attribute vop
  565.   any)
  566.  
  567.  
  568. ;;;; Constants
  569.  
  570. ;;; IMMEDIATE-CONSTANT-SC  --  Interface.
  571. ;;;
  572. ;;; If value can be represented as an immediate constant, then return the
  573. ;;; appropriate SC number, otherwise return NIL.
  574. ;;;
  575. (def-vm-support-routine immediate-constant-sc (value)
  576.   (typecase value
  577.     ((or fixnum character system-area-pointer)
  578.      (sc-number-or-lose 'immediate))
  579.     (null
  580.      (sc-number-or-lose 'null))
  581.     (symbol
  582.      (if (static-symbol-p value)
  583.      (sc-number-or-lose 'immediate)
  584.      nil))))
  585.  
  586.  
  587.  
  588. ;;;; Function Call Parameters
  589.  
  590. ;;; The SC numbers for register and stack arguments/return values.
  591. ;;;
  592. ;;; Other VOP/VM definition files use this when writing interface code for the
  593. ;;; compiler.
  594. ;;;
  595. (defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
  596. (defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
  597. (defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
  598.  
  599.  
  600. (eval-when (compile load eval)
  601.  
  602. ;;; Offsets of special stack frame locations.
  603. ;;;
  604. (defconstant ocfp-save-offset 0)
  605. (defconstant lra-save-offset 1)
  606. (defconstant nfp-save-offset 2)
  607.  
  608. ); Eval-When (Compile Load Eval)  
  609.  
  610.  
  611. (defparameter nargs-tn
  612.   (make-random-tn :kind :normal
  613.           :sc (sc-or-lose 'any-reg)
  614.           :offset nargs-offset))
  615.  
  616. (defparameter ocfp-tn
  617.   (make-random-tn :kind :normal
  618.           :sc (sc-or-lose 'descriptor-reg)
  619.           :offset ocfp-offset))
  620.  
  621. (defparameter lra-tn
  622.   (make-random-tn :kind :normal
  623.           :sc (sc-or-lose 'descriptor-reg)
  624.           :offset lra-offset))
  625.  
  626.  
  627. (eval-when (compile load eval)
  628.  
  629. ;;; The number of arguments/return values passed in registers.
  630. ;;;
  631. ;;; Other VOP/VM definition files use this when writing interface code for the
  632. ;;; compiler.
  633. ;;;
  634. (defconstant register-arg-count 3)
  635.  
  636. ;;; The offsets within the register-arg SC where we supply values, first value
  637. ;;; first.
  638. ;;;
  639. ;;; Other VOP/VM definition files use this when writing interface code for the
  640. ;;; compiler.
  641. ;;;
  642. (defconstant register-arg-offsets '(12 13 14))
  643.  
  644. ;;; Names to use for the argument registers.
  645. ;;; 
  646. (defconstant register-arg-names '(a0 a1 a2))
  647.  
  648. ); Eval-When (Compile Load Eval)
  649.  
  650.  
  651. ;;; A list of TN's describing the register arguments.
  652. ;;;
  653. (defparameter register-arg-tns
  654.   (mapcar #'(lambda (n)
  655.           (make-random-tn :kind :normal
  656.                   :sc (sc-or-lose 'descriptor-reg)
  657.                   :offset n))
  658.       register-arg-offsets))
  659.  
  660.  
  661.  
  662. ;;;; LOCATION-PRINT-NAME.
  663.  
  664. (defconstant register-names #("NARGS" "NSP" "NL0" "OCFP" "NFP"
  665.                   "CSP" "CFP" "CODE" "NULL" "CNAME" "LEXENV"
  666.                   "LRA" "A0" "A1" "A2" "LIP"))
  667.  
  668. ;;; LOCATION-PRINT-NAME  --  Interface.
  669. ;;;
  670. ;;; This function is called by debug output routines that want a pretty name
  671. ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
  672. ;;;
  673. (def-vm-support-routine location-print-name (tn)
  674.   (declare (type tn tn))
  675.   (let ((sb (sb-name (sc-sb (tn-sc tn))))
  676.     (offset (tn-offset tn)))
  677.     (ecase sb
  678.       (registers (svref register-names (tn-offset tn)))
  679.       ((mc68881-float-registers FPA-float-registers AFPA-float-registers)
  680.        (format nil "F~D" offset))
  681.       (control-stack (format nil "CS~D" offset))
  682.       (non-descriptor-stack (format nil "NS~D" offset))
  683.       (constant (format nil "Const~D" offset))
  684.       (immediate-constant "Immed"))))
  685.