home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / memory.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  5.8 KB  |  183 lines
  1. ;;; -*- Package: RT; Log: c.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the Spice Lisp project at
  5. ;;; Carnegie-Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of Spice Lisp, please contact
  7. ;;; Scott Fahlman (FAHLMAN@CMUC). 
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; $Header: memory.lisp,v 1.1 91/02/18 15:07:59 chiles Exp $
  11. ;;;
  12. ;;; This file contains the IBM RT definitions of some general purpose memory
  13. ;;; reference VOPs inherited by basic memory reference operations.
  14. ;;;
  15. ;;; Written by Rob MacLachlan
  16. ;;;
  17. ;;; Converted by Bill Chiles.
  18. ;;;
  19.  
  20. (in-package "RT")
  21.  
  22.  
  23. ;;; CELL-REF -- VOP.
  24. ;;; CELL-SET -- VOP.
  25. ;;; CELL-SETF -- VOP.
  26. ;;; CELL-SETF-FUNCTION -- VOP.
  27. ;;;
  28. ;;; CELL-REF and CELL-SET are used to define VOPs like CAR, where the offset to
  29. ;;; be read or written is a property of the VOP used.  CELL-SETF is similar to
  30. ;;; CELL-SET, but delivers the new value as the result.  CELL-SETF-FUNCTION
  31. ;;; takes its arguments as if it were a setf function (new value first, as
  32. ;;; apposed to a setf macro, which takes the new value last).
  33. ;;;
  34. (define-vop (cell-ref)
  35.   (:args (object :scs (descriptor-reg)))
  36.   (:results (value :scs (word-pointer-reg descriptor-reg any-reg)))
  37.   (:variant-vars offset lowtag)
  38.   (:policy :fast-safe)
  39.   (:generator 4
  40.     (loadw value object offset lowtag)))
  41. ;;;
  42. (define-vop (cell-set)
  43.   (:args (object :scs (descriptor-reg))
  44.          (value :scs (word-pointer-reg descriptor-reg any-reg)))
  45.   (:variant-vars offset lowtag)
  46.   (:policy :fast-safe)
  47.   (:generator 4
  48.     (storew value object offset lowtag)))
  49. ;;;
  50. (define-vop (cell-setf)
  51.   (:args (object :scs (descriptor-reg))
  52.      (value :scs (word-pointer-reg descriptor-reg any-reg)
  53.         :target result))
  54.   (:results (result :scs (descriptor-reg any-reg)))
  55.   (:variant-vars offset lowtag)
  56.   (:policy :fast-safe)
  57.   (:generator 4
  58.     (storew value object offset lowtag)
  59.     (move result value)))
  60. ;;;
  61. (define-vop (cell-setf-function)
  62.   (:args (value :scs (word-pointer-reg descriptor-reg any-reg)
  63.         :target result)
  64.      (object :scs (descriptor-reg)))
  65.   (:results (result :scs (descriptor-reg any-reg)))
  66.   (:variant-vars offset lowtag)
  67.   (:policy :fast-safe)
  68.   (:generator 4
  69.     (storew value object offset lowtag)
  70.     (move result value)))
  71.  
  72. ;;; DEFINE-CELL-ACCESSORS  --  Interface.
  73. ;;;
  74. ;;; Define accessor VOPs for some cells in an object.  If the operation name is
  75. ;;; NIL, then that operation isn't defined.  If the translate function is null,
  76. ;;; then we don't define a translation.
  77. ;;;
  78. (defmacro define-cell-accessors (offset lowtag ref-op ref-trans set-op set-trans)
  79.   `(progn
  80.      ,@(when ref-op
  81.      `((define-vop (,ref-op cell-ref)
  82.          (:variant ,offset ,lowtag)
  83.          ,@(when ref-trans
  84.          `((:translate ,ref-trans))))))
  85.      ,@(when set-op
  86.      `((define-vop (,set-op cell-setf)
  87.          (:variant ,offset ,lowtag)
  88.          ,@(when set-trans
  89.          `((:translate ,set-trans))))))))
  90.  
  91.  
  92. ;;; SLOT-REF -- VOP.
  93. ;;; SLOT-SET -- VOP.
  94. ;;;
  95. ;;; SLOT-REF and SLOT-SET are used to define VOPs like CLOSURE-REF, where the
  96. ;;; offset is constant at compile time, but varies for different uses.  We add
  97. ;;; in the stardard g-vector overhead.
  98. ;;;
  99. (define-vop (slot-ref)
  100.   (:args (object :scs (descriptor-reg)))
  101.   (:results (value :scs (descriptor-reg any-reg)))
  102.   (:variant-vars base lowtag)
  103.   (:info offset)
  104.   (:generator 4
  105.     (loadw value object (+ base offset) lowtag)))
  106. ;;;
  107. (define-vop (slot-set)
  108.   (:args (object :scs (descriptor-reg))
  109.      (value :scs (descriptor-reg any-reg)))
  110.   (:variant-vars base lowtag)
  111.   (:info offset)
  112.   (:generator 4
  113.     (storew value object (+ base offset) lowtag)))
  114.  
  115.  
  116.  
  117. ;;;; Indexed references:
  118.  
  119. (eval-when (compile eval)
  120.  
  121. ;;; DEFINE-INDEXER  --  Internal.
  122. ;;;
  123. ;;; Define some VOPs for indexed memory reference.  Unless the index is
  124. ;;; constant, we must compute an intermediate result in a boxed temporary,
  125. ;;; since the RT doesn't have any indexed addressing modes.
  126. ;;;
  127. (defmacro define-indexer (name write-p op shift &key gross-hack)
  128.   `(define-vop (,name)
  129.      (:args (object :scs (descriptor-reg) :to :eval)
  130.         (index :scs (any-reg immediate)
  131.            ,@(unless (zerop shift) '(:target temp)))
  132.         ,@(when write-p
  133.         '((value :scs (any-reg descriptor-reg) :target result))))
  134.      (:arg-types * tagged-num ,@(when write-p '(*)))
  135.      (:temporary (:scs (interior-reg) :type interior) lip)
  136.      ,@(unless (zerop shift)
  137.      `((:temporary (:scs (non-descriptor-reg)
  138.                  :type random :from (:argument 1))
  139.                temp)))
  140.      (:results (,(if write-p 'result 'value)
  141.         :scs (any-reg descriptor-reg)))
  142.      (:result-types *)
  143.      (:variant-vars offset lowtag)
  144.      (:policy :fast-safe)
  145.      (:generator 5
  146.        (sc-case index
  147.      ((immediate)
  148.       (inst ,op value object
  149.         (- (+ (if (and (sc-is index immediate) (zerop (tn-value index)))
  150.               0
  151.               (ash (tn-value index) (- word-shift ,shift)))
  152.               (ash offset word-shift))
  153.            lowtag))
  154.       ,@(if write-p
  155.         '((move result value))))
  156.      (t
  157.       ,@(if (zerop shift)
  158.         ;; Object must be the last arg to CAS here since it is cannot
  159.         ;; be in R0.
  160.         `((inst cas lip index object))
  161.         `((move temp index)
  162.           (inst sr temp ,shift)
  163.           (inst cas lip temp object)))
  164.       (inst ,op value lip (- (ash offset word-shift) lowtag))
  165.       ,@(if write-p
  166.         '((move result value)))))
  167.        ;; The RT lacks a signed-byte load instruction, so we have to sign
  168.        ;; extend this case explicitly.  This is gross but obvious and easy.
  169.        ,@(when gross-hack
  170.        '((inst sl value 24)
  171.          (inst sar value 24))))))
  172.  
  173. ) ;EVAL-WHEN
  174.  
  175. (define-indexer word-index-ref nil l 0)
  176. (define-indexer word-index-set t st 0)
  177. (define-indexer halfword-index-ref nil lh 1)
  178. (define-indexer signed-halfword-index-ref nil lha 1)
  179. (define-indexer halfword-index-set t sth 1)
  180. (define-indexer byte-index-ref nil lc 2)
  181. (define-indexer signed-byte-index-ref nil lc 2 :gross-hack t)
  182. (define-indexer byte-index-set t stc 2)
  183.