home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / system.lisp < prev    next >
Encoding:
Text File  |  1992-02-15  |  7.5 KB  |  264 lines
  1. ;;; -*- Package: MIPS -*-
  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: system.lisp,v 1.43 92/02/14 23:50:32 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: system.lisp,v 1.43 92/02/14 23:50:32 wlott Exp $
  15. ;;;
  16. ;;;    MIPS VM definitions of various system hacking operations.
  17. ;;;
  18. ;;; Written by Rob MacLachlan
  19. ;;;
  20. ;;; Mips conversion by William Lott and Christopher Hoover.
  21. ;;;
  22. (in-package "MIPS")
  23.  
  24.  
  25. ;;;; Random pointer comparison VOPs
  26.  
  27. (define-vop (pointer-compare)
  28.   (:args (x :scs (sap-reg))
  29.      (y :scs (sap-reg)))
  30.   (:arg-types system-area-pointer system-area-pointer)
  31.   (:temporary (:type random  :scs (non-descriptor-reg)) temp)
  32.   (:conditional)
  33.   (:info target not-p)
  34.   (:policy :fast-safe)
  35.   (:note "inline comparison")
  36.   (:variant-vars condition)
  37.   (:generator 3
  38.     (three-way-comparison x y condition :unsigned not-p target temp)))
  39.  
  40. (macrolet ((frob (name cond)
  41.          `(progn
  42.         (def-primitive-translator ,name (x y) `(,',name ,x ,y))
  43.         (defknown ,name (t t) boolean (movable foldable flushable))
  44.         (define-vop (,name pointer-compare)
  45.           (:translate ,name)
  46.           (:variant ,cond)))))
  47.   (frob pointer< :lt)
  48.   (frob pointer> :gt))
  49.  
  50.  
  51.  
  52. ;;;; Type frobbing VOPs
  53.  
  54. (define-vop (get-lowtag)
  55.   (:translate get-lowtag)
  56.   (:policy :fast-safe)
  57.   (:args (object :scs (any-reg descriptor-reg)))
  58.   (:results (result :scs (unsigned-reg)))
  59.   (:result-types positive-fixnum)
  60.   (:generator 1
  61.     (inst and result object vm:lowtag-mask)))
  62.  
  63. (define-vop (get-type)
  64.   (:translate get-type)
  65.   (:policy :fast-safe)
  66.   (:args (object :scs (descriptor-reg)))
  67.   (:temporary (:scs (non-descriptor-reg)) ndescr)
  68.   (:results (result :scs (unsigned-reg)))
  69.   (:result-types positive-fixnum)
  70.   (:generator 6
  71.     (let ((other-ptr (gen-label))
  72.       (lowtag-only (gen-label))
  73.       (function-ptr (gen-label))
  74.       (done (gen-label)))
  75.       ;; Pick off objects with headers.
  76.       (simple-test-simple-type object ndescr other-ptr
  77.                    nil vm:other-pointer-type)
  78.       (simple-test-simple-type object ndescr function-ptr
  79.                    nil vm:function-pointer-type)
  80.  
  81.       ;; Pick off fixnums.
  82.       (inst and result object 3)
  83.       (inst beq result done)
  84.  
  85.       ;; Pick off structure and list pointers.
  86.       (inst and result object 1)
  87.       (inst bne result lowtag-only)
  88.       (inst nop)
  89.  
  90.       ;; Must be an other immediate.
  91.       (inst b done)
  92.       (inst and result object vm:type-mask)
  93.  
  94.       (emit-label function-ptr)
  95.       (load-type result object (- vm:function-pointer-type))
  96.       (inst b done)
  97.       (inst nop)
  98.  
  99.       (emit-label lowtag-only)
  100.       (inst b done)
  101.       (inst and result object lowtag-mask)
  102.  
  103.       (emit-label other-ptr)
  104.       (load-type result object (- vm:other-pointer-type))
  105.       (inst nop)
  106.       
  107.       (emit-label done))))
  108.  
  109. (define-vop (get-header-data)
  110.   (:translate get-header-data)
  111.   (:policy :fast-safe)
  112.   (:args (x :scs (descriptor-reg)))
  113.   (:results (res :scs (unsigned-reg)))
  114.   (:result-types positive-fixnum)
  115.   (:generator 6
  116.     (loadw res x 0 vm:other-pointer-type)
  117.     (inst srl res res vm:type-bits)))
  118.  
  119. (define-vop (get-closure-length)
  120.   (:translate get-closure-length)
  121.   (:policy :fast-safe)
  122.   (:args (x :scs (descriptor-reg)))
  123.   (:results (res :scs (unsigned-reg)))
  124.   (:result-types positive-fixnum)
  125.   (:generator 6
  126.     (loadw res x 0 vm:function-pointer-type)
  127.     (inst srl res res vm:type-bits)))
  128.  
  129. (define-vop (set-header-data)
  130.   (:translate set-header-data)
  131.   (:policy :fast-safe)
  132.   (:args (x :scs (descriptor-reg) :target res)
  133.      (data :scs (any-reg immediate zero)))
  134.   (:arg-types * positive-fixnum)
  135.   (:results (res :scs (descriptor-reg)))
  136.   (:temporary (:scs (non-descriptor-reg) :type random) t1 t2)
  137.   (:generator 6
  138.     (loadw t1 x 0 vm:other-pointer-type)
  139.     (inst and t1 vm:type-mask)
  140.     (sc-case data
  141.       (any-reg
  142.        (inst sll t2 data (- vm:type-bits 2))
  143.        (inst or t1 t2))
  144.       (immediate
  145.        (inst or t1 (ash (tn-value data) vm:type-bits)))
  146.       (zero))
  147.     (storew t1 x 0 vm:other-pointer-type)
  148.     (move res x)))
  149.  
  150. (define-vop (c::make-fixnum)
  151.   (:args (ptr :scs (any-reg descriptor-reg)))
  152.   (:results (res :scs (any-reg descriptor-reg)))
  153.   (:generator 1
  154.     ;;
  155.     ;; Some code (the hash table code) depends on this returning a
  156.     ;; positive number so make sure it does.
  157.     (inst sll res ptr 3)
  158.     (inst srl res res 1)))
  159.  
  160. (define-vop (c::make-other-immediate-type)
  161.   (:args (val :scs (any-reg descriptor-reg))
  162.      (type :scs (any-reg descriptor-reg immediate unsigned-immediate)
  163.            :target temp))
  164.   (:results (res :scs (any-reg descriptor-reg)))
  165.   (:temporary (:type random  :scs (non-descriptor-reg)) temp)
  166.   (:generator 2
  167.     (sc-case type
  168.       ((immediate unsigned-immediate)
  169.        (inst sll temp val vm:type-bits)
  170.        (inst or res temp (tn-value type)))
  171.       (t
  172.        (inst sra temp type 2)
  173.        (inst sll res val (- vm:type-bits 2))
  174.        (inst or res res temp)))))
  175.  
  176.  
  177. ;;;; Allocation
  178.  
  179. (define-vop (dynamic-space-free-pointer)
  180.   (:results (int :scs (sap-reg)))
  181.   (:result-types system-area-pointer)
  182.   (:translate dynamic-space-free-pointer)
  183.   (:policy :fast-safe)
  184.   (:generator 1
  185.     (move int alloc-tn)))
  186.  
  187. (define-vop (binding-stack-pointer-sap)
  188.   (:results (int :scs (sap-reg)))
  189.   (:result-types system-area-pointer)
  190.   (:translate binding-stack-pointer-sap)
  191.   (:policy :fast-safe)
  192.   (:generator 1
  193.     (move int bsp-tn)))
  194.  
  195. (define-vop (control-stack-pointer-sap)
  196.   (:results (int :scs (sap-reg)))
  197.   (:result-types system-area-pointer)
  198.   (:translate control-stack-pointer-sap)
  199.   (:policy :fast-safe)
  200.   (:generator 1
  201.     (move int csp-tn)))
  202.  
  203.  
  204. ;;;; Code object frobbing.
  205.  
  206. (define-vop (code-instructions)
  207.   (:translate code-instructions)
  208.   (:policy :fast-safe)
  209.   (:args (code :scs (descriptor-reg)))
  210.   (:temporary (:scs (non-descriptor-reg)) ndescr)
  211.   (:results (sap :scs (sap-reg)))
  212.   (:result-types system-area-pointer)
  213.   (:generator 10
  214.     (loadw ndescr code 0 vm:other-pointer-type)
  215.     (inst srl ndescr vm:type-bits)
  216.     (inst sll ndescr vm:word-shift)
  217.     (inst subu ndescr vm:other-pointer-type)
  218.     (inst addu sap code ndescr)))
  219.  
  220. (define-vop (compute-function)
  221.   (:args (code :scs (descriptor-reg))
  222.      (offset :scs (signed-reg unsigned-reg)))
  223.   (:arg-types * positive-fixnum)
  224.   (:results (func :scs (descriptor-reg)))
  225.   (:temporary (:scs (non-descriptor-reg)) ndescr)
  226.   (:generator 10
  227.     (loadw ndescr code 0 vm:other-pointer-type)
  228.     (inst srl ndescr vm:type-bits)
  229.     (inst sll ndescr vm:word-shift)
  230.     (inst addu ndescr offset)
  231.     (inst addu ndescr (- vm:function-pointer-type vm:other-pointer-type))
  232.     (inst addu func code ndescr)))
  233.  
  234.  
  235. ;;;; Other random VOPs.
  236.  
  237.  
  238. (defknown unix::do-pending-interrupt () (values))
  239. (define-vop (unix::do-pending-interrupt)
  240.   (:policy :fast-safe)
  241.   (:translate unix::do-pending-interrupt)
  242.   (:generator 1
  243.     (inst break vm:pending-interrupt-trap)))
  244.  
  245.  
  246. (define-vop (halt)
  247.   (:generator 1
  248.     (inst break vm:halt-trap)))
  249.  
  250.  
  251. ;;;; Dynamic vop count collection support
  252.  
  253. (define-vop (count-me)
  254.   (:args (count-vector :scs (descriptor-reg)))
  255.   (:info index)
  256.   (:temporary (:scs (non-descriptor-reg)) count)
  257.   (:generator 1
  258.     (let ((offset
  259.        (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
  260.       (inst lw count count-vector offset)
  261.       (inst nop)
  262.       (inst addu count 1)
  263.       (inst sw count count-vector offset))))
  264.