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