home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / alloc.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  7.5 KB  |  216 lines
  1. ;;; -*- Package: C -*-
  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: alloc.lisp,v 1.15 91/03/20 03:06:34 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: alloc.lisp,v 1.15 91/03/20 03:06:34 wlott Exp $
  15. ;;;
  16. ;;; Allocation VOPs for the MIPS port.
  17. ;;;
  18. ;;; Written by William Lott.
  19. ;;; 
  20.  
  21. (in-package "MIPS")
  22.  
  23.  
  24. ;;;; LIST and LIST*
  25.  
  26. (define-vop (list-or-list*)
  27.   (:args (things :more t))
  28.   (:temporary (:scs (descriptor-reg) :type list) ptr)
  29.   (:temporary (:scs (descriptor-reg)) temp)
  30.   (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
  31.           res)
  32.   (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
  33.   (:info num)
  34.   (:results (result :scs (descriptor-reg)))
  35.   (:variant-vars star)
  36.   (:policy :safe)
  37.   (:generator 0
  38.     (cond ((zerop num)
  39.        (move result null-tn))
  40.       ((and star (= num 1))
  41.        (move result (tn-ref-tn things)))
  42.       (t
  43.        (macrolet
  44.            ((store-car (tn list &optional (slot vm:cons-car-slot))
  45.           `(let ((reg
  46.               (sc-case ,tn
  47.                 ((any-reg descriptor-reg) ,tn)
  48.                 (zero zero-tn)
  49.                 (null null-tn)
  50.                 (control-stack
  51.                  (load-stack-tn temp ,tn)
  52.                  temp))))
  53.              (storew reg ,list ,slot vm:list-pointer-type))))
  54.          (let ((cons-cells (if star (1- num) num)))
  55.            (pseudo-atomic (ndescr)
  56.          (inst addu res alloc-tn vm:list-pointer-type)
  57.          (inst addu alloc-tn alloc-tn
  58.                (* (vm:pad-data-block vm:cons-size) cons-cells))
  59.          (move ptr res)
  60.          (dotimes (i (1- cons-cells))
  61.            (store-car (tn-ref-tn things) ptr)
  62.            (setf things (tn-ref-across things))
  63.            (inst addu ptr ptr (vm:pad-data-block vm:cons-size))
  64.            (storew ptr ptr
  65.                (- vm:cons-cdr-slot vm:cons-size)
  66.                vm:list-pointer-type))
  67.          (store-car (tn-ref-tn things) ptr)
  68.          (cond (star
  69.             (setf things (tn-ref-across things))
  70.             (store-car (tn-ref-tn things) ptr vm:cons-cdr-slot))
  71.                (t
  72.             (storew null-tn ptr
  73.                 vm:cons-cdr-slot vm:list-pointer-type)))
  74.          (assert (null (tn-ref-across things)))
  75.          (move result res))))))))
  76.  
  77. (define-vop (list list-or-list*)
  78.   (:variant nil))
  79.  
  80. (define-vop (list* list-or-list*)
  81.   (:variant t))
  82.  
  83.  
  84. ;;;; Special purpose inline allocators.
  85.  
  86. (define-vop (allocate-code-object)
  87.   (:args (boxed-arg :scs (any-reg))
  88.      (unboxed-arg :scs (any-reg)))
  89.   (:results (result :scs (descriptor-reg)))
  90.   (:temporary (:scs (non-descriptor-reg)) ndescr)
  91.   (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
  92.   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
  93.   (:generator 100
  94.     (inst li ndescr (lognot vm:lowtag-mask))
  95.     (inst addu boxed boxed-arg (fixnum (1+ vm:code-trace-table-offset-slot)))
  96.     (inst and boxed ndescr)
  97.     (inst srl unboxed unboxed-arg vm:word-shift)
  98.     (inst addu unboxed unboxed vm:lowtag-mask)
  99.     (inst and unboxed ndescr)
  100.     (pseudo-atomic (ndescr)
  101.       (inst addu result alloc-tn vm:other-pointer-type)
  102.       (inst addu alloc-tn boxed)
  103.       (inst addu alloc-tn unboxed)
  104.       (inst sll ndescr boxed (- vm:type-bits vm:word-shift))
  105.       (inst or ndescr vm:code-header-type)
  106.       (storew ndescr result 0 vm:other-pointer-type)
  107.       (storew unboxed result vm:code-code-size-slot vm:other-pointer-type)
  108.       (storew null-tn result vm:code-entry-points-slot vm:other-pointer-type)
  109.       (storew null-tn result vm:code-debug-info-slot vm:other-pointer-type))))
  110.  
  111. (define-vop (make-symbol)
  112.   (:args (name :scs (descriptor-reg) :to :eval))
  113.   (:temporary (:scs (non-descriptor-reg)) temp)
  114.   (:results (result :scs (descriptor-reg) :from :argument))
  115.   (:policy :fast-safe)
  116.   (:translate make-symbol)
  117.   (:generator 37
  118.     (with-fixed-allocation (result temp vm:symbol-header-type vm:symbol-size)
  119.       (inst li temp vm:unbound-marker-type)
  120.       (storew temp result vm:symbol-value-slot vm:other-pointer-type)
  121.       (storew temp result vm:symbol-function-slot vm:other-pointer-type)
  122.       (storew temp result vm:symbol-setf-function-slot vm:other-pointer-type)
  123.       (inst li temp (make-fixup "undefined_tramp" :foreign))
  124.       (storew temp result vm:symbol-raw-function-addr-slot
  125.           vm:other-pointer-type)
  126.       (storew null-tn result vm:symbol-plist-slot vm:other-pointer-type)
  127.       (storew name result vm:symbol-name-slot vm:other-pointer-type)
  128.       (storew null-tn result vm:symbol-package-slot vm:other-pointer-type))))
  129.  
  130.  
  131. ;;;; Automatic allocators for primitive objects.
  132.  
  133. (vm:define-for-each-primitive-object (obj)
  134.   (collect ((forms))
  135.     (let* ((options (vm:primitive-object-options obj))
  136.        (obj-type (getf options :type t))
  137.        (alloc-trans (getf options :alloc-trans))
  138.        (alloc-vop (getf options :alloc-vop alloc-trans))
  139.        (header (vm:primitive-object-header obj))
  140.        (lowtag (vm:primitive-object-lowtag obj))
  141.        (size (vm:primitive-object-size obj))
  142.        (variable-length (vm:primitive-object-variable-length obj))
  143.        (need-unbound-marker nil))
  144.       (collect ((args) (init-forms))
  145.     (when (and alloc-vop variable-length)
  146.       (args 'extra-words))
  147.     (dolist (slot (vm:primitive-object-slots obj))
  148.       (let* ((name (vm:slot-name slot))
  149.          (offset (vm:slot-offset slot)))
  150.         (ecase (getf (vm:slot-options slot) :init :zero)
  151.           (:zero)
  152.           (:null
  153.            (init-forms `(storew null-tn result ,offset ,lowtag)))
  154.           (:unbound
  155.            (setf need-unbound-marker t)
  156.            (init-forms `(storew temp result ,offset ,lowtag)))
  157.           (:arg
  158.            (args name)
  159.            (init-forms `(storew ,name result ,offset ,lowtag))))))
  160.     (when (and (null alloc-vop) (args))
  161.       (error "Slots ~S want to be initialized, but there is no alloc vop ~
  162.               defined for ~S."
  163.          (args) (vm:primitive-object-name obj)))
  164.     (when alloc-vop
  165.       (forms
  166.        `(define-vop (,alloc-vop)
  167.           (:args ,@(mapcar #'(lambda (name)
  168.                    `(,name :scs (any-reg descriptor-reg)))
  169.                    (args)))
  170.           (:temporary (:scs (non-descriptor-reg) :type random)
  171.               ndescr
  172.               ,@(when (or need-unbound-marker header
  173.                       variable-length)
  174.                   '(temp)))
  175.           (:temporary (:scs (descriptor-reg) :to (:result 0)
  176.                 :target real-result) result)
  177.           (:results (real-result :scs (descriptor-reg)))
  178.           (:policy :fast-safe)
  179.           ,@(when alloc-trans
  180.           `((:translate ,alloc-trans)))
  181.           (:generator 37
  182.         (pseudo-atomic (ndescr)
  183.           (inst addu result alloc-tn ,lowtag)
  184.           ,@(cond ((and header variable-length)
  185.                `((inst addu temp extra-words
  186.                    (fixnum (1- ,size)))
  187.                  (inst addu alloc-tn alloc-tn temp)
  188.                  (inst sll temp temp
  189.                    (- vm:type-bits vm:word-shift))
  190.                  (inst or temp temp ,header)
  191.                  (storew temp result 0 ,lowtag)
  192.                  (inst addu alloc-tn alloc-tn
  193.                    (+ (fixnum 1) vm:lowtag-mask))
  194.                  (inst li temp (lognot vm:lowtag-mask))
  195.                  (inst and alloc-tn alloc-tn temp)))
  196.               (variable-length
  197.                (error ":REST-P T with no header in ~S?"
  198.                   (vm:primitive-object-name obj)))
  199.               (header
  200.                `((inst addu alloc-tn alloc-tn
  201.                    (vm:pad-data-block ,size))
  202.                  (inst li temp
  203.                    ,(logior (ash (1- size) vm:type-bits)
  204.                         (symbol-value header)))
  205.                  (storew temp result 0 ,lowtag)))
  206.               (t
  207.                `((inst addu alloc-tn alloc-tn
  208.                    (vm:pad-data-block ,size)))))
  209.           ,@(when need-unbound-marker
  210.               `((inst li temp vm:unbound-marker-type)))
  211.           ,@(init-forms)
  212.           (move real-result result))))))))
  213.     (when (forms)
  214.       `(progn
  215.      ,@(forms)))))
  216.