home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / cell.lisp < prev    next >
Encoding:
Text File  |  1992-03-10  |  11.2 KB  |  349 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. ;;; $Header: cell.lisp,v 1.7 92/03/10 10:00:02 wlott Exp $
  11. ;;;
  12. ;;; This file contains the VM definition of various primitive memory access
  13. ;;; VOPs for the IBM RT.
  14. ;;;
  15. ;;; Written by Rob MacLachlan
  16. ;;;
  17. ;;; Converted by Bill Chiles.
  18. ;;;
  19.  
  20. (in-package "RT")
  21.  
  22.  
  23.  
  24. ;;;; Data object definition macros.
  25.  
  26. (vm:define-for-each-primitive-object (obj)
  27.   (collect ((forms))
  28.     (let ((lowtag (vm:primitive-object-lowtag obj)))
  29.       (dolist (slot (vm:primitive-object-slots obj))
  30.     (let* ((name (vm:slot-name slot))
  31.            (offset (vm:slot-offset slot))
  32.            (rest-p (vm:slot-rest-p slot))
  33.            (slot-opts (vm:slot-options slot))
  34.            (ref-trans (getf slot-opts :ref-trans))
  35.            (ref-vop (getf slot-opts :ref-vop ref-trans))
  36.            (set-trans (getf slot-opts :set-trans))
  37.            (setf-function-p (and (listp set-trans)
  38.                      (= (length set-trans) 2)
  39.                      (eq (car set-trans) 'setf)))
  40.            (setf-vop (getf slot-opts :setf-vop
  41.                    (when setf-function-p
  42.                  (intern (concatenate
  43.                       'simple-string
  44.                       "SET-"
  45.                       (string (cadr set-trans)))))))
  46.            (set-vop (getf slot-opts :set-vop
  47.                   (if setf-vop nil set-trans))))
  48.       (when ref-vop
  49.         (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
  50.                 (:variant ,offset ,lowtag)
  51.               ,@(when ref-trans
  52.               `((:translate ,ref-trans))))))
  53.       (when (or set-vop setf-vop)
  54.         (forms `(define-vop ,(cond ((and rest-p setf-vop)
  55.                     (error "Can't automatically generate ~
  56.                     a setf VOP for :rest-p ~
  57.                     slots: ~S in ~S"
  58.                            name
  59.                            (vm:primitive-object-name obj)))
  60.                        (rest-p `(,set-vop slot-set))
  61.                        ((and set-vop setf-function-p)
  62.                     (error "Setf functions (list ~S) must ~
  63.                     use :setf-vops."
  64.                            set-trans))
  65.                        (set-vop `(,set-vop cell-set))
  66.                        (setf-function-p
  67.                     `(,setf-vop cell-setf-function))
  68.                        (t
  69.                     `(,setf-vop cell-setf)))
  70.               (:variant ,offset ,lowtag)
  71.               ,@(when set-trans
  72.               `((:translate ,set-trans)))))))))
  73.     (when (forms)
  74.       `(progn
  75.      ,@(forms)))))
  76.  
  77.  
  78.  
  79. ;;;; Symbol hacking VOPs:
  80.  
  81. ;;; CHECKED-CELL-REF -- VOP.
  82. ;;;
  83. ;;; Do a cell ref with an error check for being unbound.
  84. ;;;
  85. (define-vop (checked-cell-ref)
  86.   (:args (object :scs (descriptor-reg) :target obj-temp))
  87.   (:results (value :scs (word-pointer-reg descriptor-reg any-reg)))
  88.   (:policy :fast-safe)
  89.   (:vop-var vop)
  90.   (:save-p :compute-only)
  91.   (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
  92.  
  93. ;;; SYMBOL-VALUE -- VOP.
  94. ;;;
  95. ;;; Check that the value isn't the trap object.
  96. ;;;
  97. (define-vop (symbol-value checked-cell-ref)
  98.   (:translate symbol-value)
  99.   (:generator 9
  100.     (move obj-temp object)
  101.     (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type)
  102.     (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
  103.       (inst c value vm:unbound-marker-type)
  104.       (inst bc :eq err-lab))))
  105.  
  106. ;;; SYMBOL-FUNCTION -- VOP.
  107. ;;;
  108. ;;; Check that the result is a function, so NIL is always un-fbound.
  109. ;;;
  110. (define-vop (symbol-function checked-cell-ref)
  111.   (:translate symbol-function)
  112.   (:temporary (:type random  :scs (non-descriptor-reg)) temp)
  113.   (:generator 10
  114.     (move obj-temp object)
  115.     (loadw value obj-temp vm:symbol-function-slot vm:other-pointer-type)
  116.     (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
  117.       (test-type value temp err-lab t vm:function-pointer-type))))
  118.  
  119.  
  120. ;;; BOUNDP-FROB -- VOP.
  121. ;;;
  122. ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
  123. ;;;
  124. (define-vop (boundp-frob)
  125.   (:args (object :scs (descriptor-reg)))
  126.   (:conditional)
  127.   (:info target not-p)
  128.   (:policy :fast-safe)
  129.   (:temporary (:scs (descriptor-reg)) value)
  130.   (:temporary (:type random  :scs (non-descriptor-reg)) temp))
  131.  
  132. (define-vop (boundp boundp-frob)
  133.   (:translate boundp)
  134.   (:generator 9
  135.     (loadw value object vm:symbol-value-slot vm:other-pointer-type)
  136.     (inst c value vm:unbound-marker-type)
  137.     (if not-p
  138.     ;; If they're the same, symbol is unbound, so if not-p (the symbol is
  139.     ;; bound), then go to target.
  140.     (inst bc :eq target)
  141.     (inst bnc :eq target))))
  142.  
  143.  
  144. ;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction
  145. ;;; on the symbol case of fboundp.  Instead, we transform to a funny function.
  146.  
  147. (defknown fboundp/symbol (t) boolean (flushable))
  148. ;;;
  149. (deftransform fboundp ((x) (symbol))
  150.   '(fboundp/symbol x))
  151. ;;;
  152. (define-vop (fboundp/symbol boundp-frob)
  153.   (:translate fboundp/symbol)
  154.   (:generator 10
  155.     (loadw value object vm:symbol-function-slot vm:other-pointer-type)
  156.     (test-type value temp target not-p vm:function-pointer-type)))
  157.  
  158. (define-vop (fast-symbol-value cell-ref)
  159.   (:variant vm:symbol-value-slot vm:other-pointer-type)
  160.   (:policy :fast)
  161.   (:translate symbol-value))
  162.  
  163. (define-vop (fast-symbol-function cell-ref)
  164.   (:variant vm:symbol-function-slot vm:other-pointer-type)
  165.   (:policy :fast)
  166.   (:translate symbol-function))
  167.  
  168. (define-vop (set-symbol-function)
  169.   (:translate %set-symbol-function)
  170.   (:policy :fast-safe)
  171.   (:args (symbol :scs (descriptor-reg))
  172.      (function :scs (descriptor-reg) :target result))
  173.   (:results (result :scs (descriptor-reg)))
  174.   (:temporary (:scs (non-descriptor-reg)) type)
  175.   (:temporary (:scs (any-reg)) temp)
  176.   (:save-p :compute-only)
  177.   (:vop-var vop)
  178.   (:generator 30
  179.     (let ((closure (gen-label))
  180.       (normal-fn (gen-label)))
  181.       (load-type type function vm:function-pointer-type)
  182.       (inst c type vm:closure-header-type)
  183.       (inst bc :eq closure)
  184.       (inst c type funcallable-instance-header-type)
  185.       (inst bc :eq closure)
  186.       (inst c type vm:function-header-type)
  187.       (inst bcx :eq normal-fn)
  188.       (inst a temp function
  189.         (- (ash vm:function-header-code-offset vm:word-shift)
  190.            vm:function-pointer-type))
  191.       (error-call vop kernel:object-not-function-error function)
  192.       (emit-label closure)
  193.       (inst cai temp (make-fixup "closure_tramp" :foreign))
  194.       (emit-label normal-fn)
  195.       (storew function symbol vm:symbol-function-slot vm:other-pointer-type)
  196.       (storew temp symbol vm:symbol-raw-function-addr-slot vm:other-pointer-type)
  197.       (move result function))))
  198.  
  199.  
  200. (defknown fmakunbound/symbol (symbol) symbol (unsafe))
  201. ;;;
  202. (deftransform fmakunbound ((symbol) (symbol))
  203.   '(when symbol
  204.      (fmakunbound/symbol symbol)))
  205. ;;;
  206. (define-vop (fmakunbound/symbol)
  207.   (:translate fmakunbound/symbol)
  208.   (:policy :fast-safe)
  209.   (:args (symbol :scs (descriptor-reg) :target result))
  210.   (:results (result :scs (descriptor-reg)))
  211.   (:temporary (:scs (sap-reg)) temp)
  212.   (:generator 5
  213.     (inst li temp vm:unbound-marker-type)
  214.     (storew temp symbol vm:symbol-function-slot vm:other-pointer-type)
  215.     (inst cai temp (make-fixup "undefined_tramp" :foreign))
  216.     (storew temp symbol vm:symbol-raw-function-addr-slot vm:other-pointer-type)
  217.     (move result symbol)))
  218.  
  219.  
  220. ;;; Binding and Unbinding.
  221.  
  222. ;;; BIND -- Establish VAL as a binding for SYMBOL.  Save the old value and
  223. ;;; the symbol on the binding stack and stuff the new value into the
  224. ;;; symbol.
  225.  
  226. (define-vop (bind)
  227.   (:args (val :scs (any-reg descriptor-reg))
  228.      (symbol :scs (descriptor-reg)))
  229.   (:temporary (:scs (descriptor-reg)) temp)
  230.   (:temporary (:scs (word-pointer-reg)) bsp)
  231.   (:generator 7
  232.     (loadw temp symbol vm:symbol-value-slot vm:other-pointer-type)
  233.     (load-symbol-value bsp *binding-stack-pointer*)
  234.     (inst inc bsp (* vm:binding-size vm:word-bytes))
  235.     (store-symbol-value bsp *binding-stack-pointer*)
  236.     (storew temp bsp (- vm:binding-value-slot vm:binding-size))
  237.     (storew symbol bsp (- vm:binding-symbol-slot vm:binding-size))
  238.     (storew val symbol vm:symbol-value-slot vm:other-pointer-type)))
  239.  
  240. (define-vop (unbind)
  241.   (:temporary (:scs (descriptor-reg)) symbol value)
  242.   (:temporary (:scs (word-pointer-reg)) bsp)
  243.   (:generator 7
  244.     (load-symbol-value bsp *binding-stack-pointer*)
  245.     (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size))
  246.     (loadw value bsp (- vm:binding-value-slot vm:binding-size))
  247.     (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
  248.     (inst li value 0)
  249.     (storew value bsp (- vm:binding-symbol-slot vm:binding-size))
  250.     (inst dec bsp (* vm:binding-size vm:word-bytes))
  251.     (store-symbol-value bsp *binding-stack-pointer*)))
  252.  
  253. (define-vop (unbind-to-here)
  254.   (:args (arg :scs (descriptor-reg any-reg) :target where))
  255.   (:temporary (:scs (any-reg) :from (:argument 0)) where)
  256.   (:temporary (:scs (descriptor-reg)) symbol value)
  257.   (:temporary (:scs (word-pointer-reg)) bsp)
  258.   (:generator 0
  259.     (let ((loop (gen-label))
  260.       (skip (gen-label))
  261.       (done (gen-label)))
  262.       (move where arg)
  263.       (load-symbol-value bsp *binding-stack-pointer*)
  264.       (inst c where bsp)
  265.       (inst bc :eq done)
  266.  
  267.       (emit-label loop)
  268.       (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size))
  269.       (inst c symbol 0)
  270.       (inst bc :eq skip)
  271.       (loadw value bsp (- vm:binding-value-slot vm:binding-size))
  272.       (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
  273.       (inst li value 0)
  274.       (storew value bsp (- vm:binding-symbol-slot vm:binding-size))
  275.  
  276.       (emit-label skip)
  277.       (inst dec bsp (* vm:binding-size vm:word-bytes))
  278.       (store-symbol-value bsp *binding-stack-pointer*)
  279.       (inst c where bsp)
  280.       (inst bnc :eq loop)
  281.  
  282.       (emit-label done))))
  283.  
  284.  
  285.  
  286. ;;;; Closure indexing.
  287.  
  288. (define-vop (closure-index-ref word-index-ref)
  289.   (:variant vm:closure-info-offset vm:function-pointer-type)
  290.   (:translate %closure-index-ref))
  291.  
  292. (define-vop (set-funcallable-instance-info word-index-set)
  293.   (:variant funcallable-instance-info-offset function-pointer-type)
  294.   (:translate %set-funcallable-instance-info))
  295.  
  296.  
  297. ;;;; Structure hackery:
  298.  
  299. (define-vop (structure-length)
  300.   (:policy :fast-safe)
  301.   (:translate structure-length)
  302.   (:args (struct :scs (descriptor-reg)))
  303.   ;;(:temporary (:scs (non-descriptor-reg)) temp)
  304.   (:results (res :scs (unsigned-reg)))
  305.   (:result-types positive-fixnum)
  306.   (:generator 4
  307.     (loadw res struct 0 structure-pointer-type)
  308.     (inst sr res vm:type-bits)))
  309.  
  310. (define-vop (structure-ref slot-ref)
  311.   (:variant structure-slots-offset structure-pointer-type)
  312.   (:policy :fast-safe)
  313.   (:translate structure-ref)
  314.   (:arg-types structure (:constant index)))
  315.  
  316. (define-vop (structure-set slot-set)
  317.   (:policy :fast-safe)
  318.   (:translate structure-set)
  319.   (:variant structure-slots-offset structure-pointer-type)
  320.   (:arg-types structure (:constant index) *))
  321.  
  322. (define-vop (structure-index-ref word-index-ref)
  323.   (:policy :fast-safe) 
  324.   (:translate structure-ref)
  325.   (:variant structure-slots-offset structure-pointer-type)
  326.   (:arg-types structure positive-fixnum))
  327.  
  328. (define-vop (structure-index-set word-index-set)
  329.   (:policy :fast-safe) 
  330.   (:translate structure-set)
  331.   (:variant structure-slots-offset structure-pointer-type)
  332.   (:arg-types structure positive-fixnum *))
  333.  
  334.  
  335.  
  336. ;;;; Extra random indexers.
  337.  
  338. (define-vop (code-header-ref word-index-ref)
  339.   (:translate code-header-ref)
  340.   (:policy :fast-safe)
  341.   (:variant 0 other-pointer-type))
  342.  
  343. (define-vop (code-header-set word-index-set)
  344.   (:translate code-header-set)
  345.   (:policy :fast-safe)
  346.   (:variant 0 other-pointer-type))
  347.  
  348.  
  349.