home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / type-vops.lisp < prev    next >
Encoding:
Text File  |  1992-05-26  |  16.0 KB  |  475 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: type-vops.lisp,v 1.5 92/05/26 13:55:12 wlott Exp $
  11. ;;; 
  12. ;;; This file contains the VM definition of type testing and checking VOPs
  13. ;;; for the IBM RT.
  14. ;;;
  15. ;;; Written by William Lott.
  16. ;;; Converted to IBM RT by Bill Chiles.
  17. ;;;
  18.  
  19. (in-package "RT")
  20.  
  21.  
  22.  
  23. ;;;; Simple type checking and testing.
  24.  
  25. ;;; These types are represented by a single type code and are easily open-coded
  26. ;;; as a mask and compare.
  27. ;;;
  28.  
  29. ;;; CHECK-TYPE -- VOP.
  30. ;;;
  31. ;;; Type checking VOPs include this.  Instances of this either returns value
  32. ;;; in result, or they jump to error code if the type is wrong.
  33. ;;;
  34. (define-vop (check-type)
  35.   (:args (value :target result :scs (any-reg descriptor-reg)))
  36.   (:results (result :scs (any-reg descriptor-reg)))
  37.   (:temporary (:type random :scs (non-descriptor-reg)) temp)
  38.   (:vop-var vop)
  39.   (:save-p :compute-only))
  40.  
  41. ;;; TYPE-PREDICATE -- VOP.
  42. ;;;
  43. ;;; Type predicate VOPs include this.  They jump to target when value is of the
  44. ;;; appropriate type; otherwise, they drop through.  When not-p is true, they
  45. ;;; drop through if value is of the type and jumps to target if not.
  46. ;;;
  47. (define-vop (type-predicate)
  48.   (:args (value :scs (any-reg descriptor-reg)))
  49.   (:conditional)
  50.   (:info target not-p)
  51.   (:policy :fast-safe)
  52.   (:temporary (:scs (non-descriptor-reg)) temp))
  53.  
  54.  
  55. (eval-when (compile eval)
  56.  
  57. (defun cost-to-test-types (type-codes)
  58.   (+ (* 2 (length type-codes))
  59.      (if (> (apply #'max type-codes) vm:lowtag-limit) 7 2)))
  60.  
  61. (defmacro def-type-vops (pred-name check-name ptype error-code
  62.                    &rest type-codes)
  63.   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
  64.     `(progn
  65.        ,@(when pred-name
  66.        `((define-vop (,pred-name type-predicate)
  67.            (:translate ,pred-name)
  68.            (:generator ,cost
  69.          (test-type value temp target not-p ,@type-codes)))))
  70.        ,@(when check-name
  71.        `((define-vop (,check-name check-type)
  72.            (:generator ,cost
  73.          (let ((err-lab
  74.             (generate-error-code vop ,error-code value)))
  75.            (test-type value temp err-lab t ,@type-codes)
  76.            (move result value))))))
  77.        ,@(when ptype
  78.        `((primitive-type-vop ,check-name (:check) ,ptype))))))
  79.  
  80. ); eval-when (compile eval)
  81.  
  82.  
  83. (def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
  84.   vm:even-fixnum-type vm:odd-fixnum-type)
  85.  
  86. (def-type-vops functionp check-function function
  87.   object-not-function-error vm:function-pointer-type)
  88.  
  89. (def-type-vops listp check-list list
  90.   object-not-list-error vm:list-pointer-type)
  91.  
  92. (def-type-vops structurep check-structure structure
  93.   object-not-structure-error vm:structure-pointer-type)
  94.  
  95. (def-type-vops bignump check-bigunm bignum
  96.   object-not-bignum-error vm:bignum-type)
  97.  
  98. (def-type-vops ratiop check-ratio ratio
  99.   object-not-ratio-error vm:ratio-type)
  100.  
  101. (def-type-vops complexp check-complex complex
  102.   object-not-complex-error vm:complex-type)
  103.  
  104. (def-type-vops single-float-p check-single-float nil ;single-float
  105.   object-not-single-float-error vm:single-float-type)
  106.  
  107. (def-type-vops double-float-p check-double-float nil ;double-float
  108.   object-not-double-float-error vm:double-float-type)
  109.  
  110. (def-type-vops simple-string-p check-simple-string simple-string
  111.   object-not-simple-string-error vm:simple-string-type)
  112.  
  113. (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
  114.   object-not-simple-bit-vector-error vm:simple-bit-vector-type)
  115.  
  116. (def-type-vops simple-vector-p check-simple-vector simple-vector
  117.   object-not-simple-vector-error vm:simple-vector-type)
  118.  
  119. (def-type-vops simple-array-unsigned-byte-2-p
  120.   check-simple-array-unsigned-byte-2
  121.   simple-array-unsigned-byte-2
  122.   object-not-simple-array-unsigned-byte-2-error
  123.   vm:simple-array-unsigned-byte-2-type)
  124.  
  125. (def-type-vops simple-array-unsigned-byte-4-p
  126.   check-simple-array-unsigned-byte-4
  127.   simple-array-unsigned-byte-4
  128.   object-not-simple-array-unsigned-byte-4-error
  129.   vm:simple-array-unsigned-byte-4-type)
  130.  
  131. (def-type-vops simple-array-unsigned-byte-8-p
  132.   check-simple-array-unsigned-byte-8
  133.   simple-array-unsigned-byte-8
  134.   object-not-simple-array-unsigned-byte-8-error
  135.   vm:simple-array-unsigned-byte-8-type)
  136.  
  137. (def-type-vops simple-array-unsigned-byte-16-p
  138.   check-simple-array-unsigned-byte-16
  139.   simple-array-unsigned-byte-16
  140.   object-not-simple-array-unsigned-byte-16-error
  141.   vm:simple-array-unsigned-byte-16-type)
  142.  
  143. (def-type-vops simple-array-unsigned-byte-32-p
  144.   check-simple-array-unsigned-byte-32
  145.   simple-array-unsigned-byte-32
  146.   object-not-simple-array-unsigned-byte-32-error
  147.   vm:simple-array-unsigned-byte-32-type)
  148.  
  149. (def-type-vops simple-array-single-float-p check-simple-array-single-float
  150.   simple-array-single-float object-not-simple-array-single-float-error
  151.   vm:simple-array-single-float-type)
  152.  
  153. (def-type-vops simple-array-double-float-p check-simple-array-double-float
  154.   simple-array-double-float object-not-simple-array-double-float-error
  155.   vm:simple-array-double-float-type)
  156.  
  157. (def-type-vops base-char-p check-base-char base-char
  158.   object-not-base-char-error vm:base-char-type)
  159.  
  160. (def-type-vops system-area-pointer-p check-system-area-pointer
  161.   system-area-pointer object-not-sap-error vm:sap-type)
  162.  
  163. (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
  164.   object-not-weak-pointer-error vm:weak-pointer-type)
  165.  
  166. (def-type-vops array-header-p nil nil nil
  167.   vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type
  168.   vm:complex-vector-type vm:complex-array-type)
  169.  
  170. (def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error
  171.   vm:function-pointer-type vm:symbol-header-type)
  172.  
  173. (def-type-vops stringp check-string nil object-not-string-error
  174.   vm:simple-string-type vm:complex-string-type)
  175.  
  176. (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
  177.   vm:simple-bit-vector-type vm:complex-bit-vector-type)
  178.  
  179. (def-type-vops vectorp check-vector nil object-not-vector-error
  180.   vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type
  181.   vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type
  182.   vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type
  183.   vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type
  184.   vm:simple-array-double-float-type vm:complex-string-type
  185.   vm:complex-bit-vector-type vm:complex-vector-type)
  186.  
  187. (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
  188.   vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
  189.   vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
  190.   vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
  191.   vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
  192.   vm:simple-array-single-float-type vm:simple-array-double-float-type)
  193.  
  194. (def-type-vops arrayp check-array nil object-not-array-error
  195.   vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
  196.   vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
  197.   vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
  198.   vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
  199.   vm:simple-array-single-float-type vm:simple-array-double-float-type
  200.   vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type
  201.   vm:complex-array-type)
  202.  
  203. (def-type-vops numberp check-number nil object-not-number-error
  204.   vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type
  205.   vm:single-float-type vm:double-float-type vm:complex-type)
  206.  
  207. (def-type-vops rationalp check-rational nil object-not-rational-error
  208.   vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type)
  209.  
  210. (def-type-vops integerp check-integer nil object-not-integer-error
  211.   vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type)
  212.  
  213. (def-type-vops floatp check-float nil object-not-float-error
  214.   vm:single-float-type vm:double-float-type)
  215.  
  216. (def-type-vops realp check-real nil object-not-real-error
  217.   vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type
  218.   vm:single-float-type vm:double-float-type)
  219.  
  220. (def-type-vops code-component-p nil nil nil code-header-type)
  221. (def-type-vops lra-p nil nil nil return-pc-header-type)
  222. (def-type-vops scavenger-hook-p nil nil nil 0)
  223.  
  224. (def-type-vops funcallable-instance-p nil nil nil
  225.   vm:funcallable-instance-header-type)
  226.  
  227.  
  228. ;;;; Other integer ranges.
  229.  
  230. ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
  231. ;;; exactly one digit.
  232. ;;;
  233.  
  234. (define-vop (signed-byte-32-p type-predicate)
  235.   (:translate signed-byte-32-p)
  236.   (:generator 45
  237.     (let ((not-target (gen-label)))
  238.       (multiple-value-bind
  239.       (yep nope)
  240.       (if not-p
  241.           (values not-target target)
  242.           (values target not-target))
  243.     ;; Is it a fisnum?
  244.     (inst nilz temp value #x3)
  245.     (inst bc :eq yep)
  246.     ;; If not, is it an other pointer?
  247.     (test-type value temp nope t vm:other-pointer-type)
  248.     ;; If so, get the header.
  249.     (loadw temp value 0 vm:other-pointer-type)
  250.     ;; Is it a bignum of length one?
  251.     (inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type))
  252.     (if not-p
  253.         (inst bnc :eq target)
  254.         (inst bc :eq target))
  255.     (emit-label not-target)))))
  256.  
  257. (define-vop (check-signed-byte-32 check-type)
  258.   (:generator 45
  259.     (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
  260.       (yep (gen-label)))
  261.       (inst nilz temp value #x3)
  262.       (inst bc :eq yep)
  263.       (test-type value temp nope t vm:other-pointer-type)
  264.       (loadw temp value 0 vm:other-pointer-type)
  265.       (inst c temp
  266.         ;; Header word representing a bignum of length one.
  267.         (logior (ash 1 vm:type-bits) vm:bignum-type))
  268.       (inst bnc :eq nope)
  269.       (emit-label yep)
  270.       (move result value))))
  271.  
  272.  
  273. ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
  274. ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
  275. ;;; and the second digit all zeros.
  276.  
  277. (define-vop (unsigned-byte-32-p type-predicate)
  278.   (:translate unsigned-byte-32-p)
  279.   (:generator 45
  280.     (let ((not-target (gen-label))
  281.       (single-word (gen-label))
  282.       (fixnum (gen-label)))
  283.       (multiple-value-bind
  284.       (yep nope)
  285.       (if not-p
  286.           (values not-target target)
  287.           (values target not-target))
  288.     ;; Is it a fixnum?
  289.     (inst nilz temp value #x3)
  290.     (inst bcx :eq fixnum)
  291.     (inst c value 0)
  292.     ;; If not, is it an other pointer?
  293.     (test-type value temp nope t vm:other-pointer-type)
  294.     ;; Get the header.
  295.     (loadw temp value 0 vm:other-pointer-type)
  296.     ;; Is it a bignum of length one?
  297.     (inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type))
  298.     (inst bcx :eq single-word)
  299.     ;; If it length is other than two, we can't be an (unsigned-byte 32).
  300.     (inst c temp (+ (ash 2 vm:type-bits) vm:bignum-type))
  301.     (inst bncx :eq nope)
  302.     ;; Get the second digit.
  303.     (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
  304.     ;; All zeros, its an (unsigned-byte 32).
  305.     (inst c temp 0)
  306.     (inst bc :eq yep)
  307.     ;; Otherwise, it isn't.
  308.     (inst b nope)
  309.     
  310.     (emit-label single-word)
  311.     ;; Get the single digit.
  312.     (loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
  313.     (inst c temp 0)
  314.  
  315.     ;; positive implies (unsigned-byte 32).
  316.     (emit-label fixnum)
  317.     (if not-p
  318.         (inst bc :lt target)
  319.         (inst bnc :lt target))
  320.  
  321.     (emit-label not-target)))))      
  322.  
  323. (define-vop (check-unsigned-byte-32 check-type)
  324.   (:generator 45
  325.     (let ((nope
  326.        (generate-error-code vop object-not-unsigned-byte-32-error value))
  327.       (yep (gen-label))
  328.       (fixnum (gen-label))
  329.       (single-word (gen-label)))
  330.       ;; Is it a fixnum?
  331.       (inst nilz temp value #x3)
  332.       (inst bcx :eq fixnum)
  333.       (inst c value 0)
  334.  
  335.       ;; If not, is it an other pointer?
  336.       (test-type value temp nope t vm:other-pointer-type)
  337.       ;; Get the number of digits.
  338.       (loadw temp value 0 vm:other-pointer-type)
  339.       ;; Is it one?
  340.       (inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type))
  341.       (inst bcx :eq single-word)
  342.       ;; If it's length is other than two, we can't be an (unsigned-byte 32).
  343.       (inst c temp (+ (ash 2 vm:type-bits) vm:bignum-type))
  344.       (inst bncx :eq nope)
  345.       ;; Get the second digit.
  346.       (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
  347.       ;; All zeros, its an (unsigned-byte 32).
  348.       (inst c temp 0)
  349.       (inst bc :eq yep)
  350.       ;; Otherwise, it isn't.
  351.       (inst bnc :eq nope)
  352.       
  353.       (emit-label single-word)
  354.       ;; Get the single digit.
  355.       (loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
  356.       ;; positive implies (unsigned-byte 32).
  357.       (inst c temp 0)
  358.       
  359.       (emit-label fixnum)
  360.       (inst bc :lt nope)
  361.       
  362.       (emit-label yep)
  363.       (move result value))))
  364.  
  365.  
  366.  
  367.  
  368. ;;;; List/symbol types:
  369.  
  370. ;;; SYMBOLP -- VOP.
  371. ;;;
  372. ;;; This is (or symbol (eq nil)).
  373. ;;;
  374. (define-vop (symbolp type-predicate)
  375.   (:translate symbolp)
  376.   (:generator 12
  377.     (let* ((drop-thru (gen-label))
  378.        (is-symbol-label (if not-p drop-thru target)))
  379.       (inst c value null-tn)
  380.       (inst bc :eq is-symbol-label)
  381.       (test-type value temp target not-p vm:symbol-header-type)
  382.       (emit-label drop-thru))))
  383. ;;;
  384. (define-vop (check-symbol check-type)
  385.   (:generator 12
  386.     (let ((drop-thru (gen-label))
  387.       (error (generate-error-code vop object-not-symbol-error value)))
  388.       (inst c value null-tn)
  389.       (inst bc :eq drop-thru)
  390.       (test-type value temp error t vm:symbol-header-type)
  391.       (emit-label drop-thru)
  392.       (move result value))))
  393.   
  394. ;;; CONSP -- VOP.
  395. ;;;
  396. ;;; This is (and list (not (eq nil))).
  397. ;;;
  398. (define-vop (consp type-predicate)
  399.   (:translate consp)
  400.   (:generator 8
  401.     (let* ((drop-thru (gen-label))
  402.        (is-not-cons-label (if not-p target drop-thru)))
  403.       (inst c value null-tn)
  404.       (inst bc :eq is-not-cons-label)
  405.       (test-type value temp target not-p vm:list-pointer-type)
  406.       (emit-label drop-thru))))
  407. ;;;
  408. (define-vop (check-cons check-type)
  409.   (:generator 8
  410.     (let ((error (generate-error-code vop object-not-cons-error value)))
  411.       (inst c value null-tn)
  412.       (inst bc :eq error)
  413.       (test-type value temp error t vm:list-pointer-type)
  414.       (move result value))))
  415.  
  416.  
  417.  
  418. ;;;; Function Coercion
  419.  
  420. ;;; If not a function, get the symbol value and test for that being a
  421. ;;; function.  Since we test for a function rather than the unbound
  422. ;;; marker, this works on NIL.
  423. ;;;
  424. (define-vop (coerce-to-function)
  425.   (:args (object :scs (descriptor-reg)
  426.          :target result))
  427.   (:results (result :scs (descriptor-reg)))
  428.   (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
  429.   (:temporary (:scs (descriptor-reg)) saved-object)
  430.   (:vop-var vop)
  431.   (:save-p :compute-only)
  432.   (:generator 0
  433.     (let ((not-function-label (gen-label))
  434.       (not-coercable-label (gen-label))
  435.       (done-label (gen-label)))
  436.       (test-type object nd-temp not-function-label t
  437.          vm:function-pointer-type)
  438.       (move result object)
  439.       (emit-label done-label)
  440.  
  441.       (assemble (*elsewhere*)
  442.     (emit-label not-function-label)
  443.     (test-type object nd-temp not-coercable-label t
  444.            vm:symbol-header-type)
  445.     (move saved-object object)
  446.     (loadw result object vm:symbol-function-slot vm:other-pointer-type)
  447.     (test-type result nd-temp done-label nil
  448.            vm:function-pointer-type)
  449.     (error-call vop undefined-symbol-error saved-object)
  450.     
  451.     (emit-label not-coercable-label)
  452.     (error-call vop object-not-coercable-to-function-error object)))))
  453.  
  454. (define-vop (fast-safe-coerce-to-function)
  455.   (:args (object :scs (descriptor-reg)
  456.          :target result))
  457.   (:results (result :scs (descriptor-reg)))
  458.   (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
  459.   (:temporary (:scs (descriptor-reg)) saved-object)
  460.   (:vop-var vop)
  461.   (:save-p :compute-only)
  462.   (:generator 10
  463.     (let ((not-function-label (gen-label))
  464.       (done-label (gen-label)))
  465.       (test-type object nd-temp not-function-label t vm:function-pointer-type)
  466.       (move result object)
  467.       (emit-label done-label)
  468.  
  469.       (assemble (*elsewhere*)
  470.     (emit-label not-function-label)
  471.     (move saved-object object)
  472.     (loadw result object vm:symbol-function-slot vm:other-pointer-type)
  473.     (test-type result nd-temp done-label nil vm:function-pointer-type)
  474.     (error-call vop undefined-symbol-error saved-object)))))
  475.