home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / primops / mipsprimops.t < prev    next >
Encoding:
Text File  |  1990-04-12  |  8.1 KB  |  220 lines
  1. (herald mipsprimops
  2.         (env (*value orbit-env 'base-early-binding-env) constants))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define-constant call-foreign 
  28.   (primop call-foreign ()
  29.     ((primop.make-closed self)
  30.      '(lambda args (error "DEFINE-FOREIGN cannot be interpreted")))
  31.     ((primop.generate self node)
  32.      (generate-foreign-call node))))
  33.  
  34. ;;; COMPARATORS
  35. ;;;===========================================================================
  36.  
  37. (define-constant eq?
  38.   (primop eq? ()
  39.     ((primop.generate self node)
  40.      (eq?-comparator node))
  41.     ((primop.presimplify self node)
  42.      (presimplify-to-conditional node))
  43.     ((primop.simplify self node)
  44.      (simplify-eq? node))
  45.     ((primop.make-closed self)
  46.      (make-closed-conditional self))
  47.     ((primop.conditional? self) t)
  48.     ((primop.conditional-type self node)
  49.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  50.     ((primop.type self node)
  51.      '#[type (proc #f (proc #f boolean) top top)])))
  52.        
  53. ;;; TYPE PREDICATES
  54. ;;;===========================================================================
  55.  
  56. (define-local-syntax (define-tag-type-predicate name tag)
  57.   `(define-constant ,name
  58.      (make-tag-type-predicate ',name ,tag)))
  59.  
  60. (define-local-syntax (define-header-type-predicate name header)
  61.   `(define-constant ,name
  62.      (make-header-type-predicate ',name ,header)))
  63.  
  64.  
  65. (define-constant make-tag-type-predicate 
  66.   (primop make-tag-type-predicate (name tag)
  67.  
  68.     (((primop.simplify self node)
  69.       (simplify-parameterized-primop self node)))
  70.  
  71.     ((primop.test-code self node #f)      
  72.      (generate-tag-type-test node tag))
  73.     ((primop.presimplify self node)
  74.      (presimplify-predicate node))
  75.     ((primop.make-closed self)
  76.      (make-closed-predicate self))
  77.     ((primop.type-predicate? self) t)
  78.     ((primop.type self node)
  79.      '#[type (proc #f (proc #f boolean) top)])
  80.     ((primop.predicate-type self node)
  81.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  82.     ((primop.variant-id self) name)))
  83.  
  84. (define-constant make-header-type-predicate
  85.   (primop make-header-type-predicate (name header)
  86.  
  87.     (((primop.simplify self node)
  88.       (simplify-parameterized-primop self node)))
  89.  
  90.     ((primop.test-code self node #f)
  91.      (generate-header-type-test node header))
  92.     ((primop.presimplify self node)
  93.      (presimplify-predicate node))
  94.     ((primop.make-closed self)
  95.      (make-closed-predicate self))
  96.     ((primop.type-predicate? self) t)
  97.     ((primop.type self node)
  98.      '#[type (proc #f (proc #f boolean) top)])
  99.     ((primop.predicate-type self node)
  100.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  101.     ((primop.variant-id self) name)))
  102.  
  103.                      
  104. (define-tag-type-predicate list?    tag/pair)         ; low 2 bits
  105. (define-tag-type-predicate extend? tag/extend)
  106. (define-tag-type-predicate immediate? tag/immediate)
  107. (define-tag-type-predicate fixnum?   tag/fixnum)
  108.  
  109. (define-header-type-predicate char?                   header/char)
  110. (define-header-type-predicate general-vector-header?  header/general-vector)
  111. (define-header-type-predicate bytev-header?           header/bytev)
  112. (define-header-type-predicate text-header?            header/text)
  113. (define-header-type-predicate string-header?          header/slice)
  114. (define-header-type-predicate symbol-header?          header/symbol)
  115. (define-header-type-predicate foreign-header?         header/foreign)
  116. (define-header-type-predicate vcell-header?           header/vcell)
  117. (define-header-type-predicate true-header?            header/true)
  118. (define-header-type-predicate unit-header?            header/unit)
  119. (define-header-type-predicate interrupt-frame-header? header/interrupt-frame)
  120. (define-header-type-predicate fault-frame-header? header/fault-frame)
  121. (define-header-type-predicate bignum-header?          header/bignum) 
  122. (define-header-type-predicate double-float-header?    header/double-float)
  123. (define-header-type-predicate template-header?        header/template)
  124.                        
  125. (define-header-type-predicate weak-set-header?    header/weak-set)
  126. (define-header-type-predicate weak-alist-header?  header/weak-alist)
  127. (define-header-type-predicate weak-table-header?  header/weak-table)
  128. (define-header-type-predicate weak-cell-header?   header/weak-cell)
  129.  
  130.                                                       
  131. (define-constant nonvalue?
  132.   (primop nonvalue? ()
  133.     ((primop.test-code self node #f)
  134.      (generate-nonvalue-test node))
  135.     ((primop.presimplify self node)
  136.      (presimplify-predicate node))
  137.     ((primop.make-closed self)
  138.      (make-closed-predicate self))
  139.     ((primop.type-predicate? self) t)
  140.     ((primop.type self node)
  141.      '#[type (proc #f (proc #f boolean) top)])
  142.     ((primop.predicate-type self node)
  143.      '#[type (proc #f (proc #f) (proc #f) top top top)])))
  144.                                                       
  145.  
  146.                                                 
  147.  
  148. ;;; MAKE-VECTORS
  149. ;;;=========================================================================
  150.  
  151. (define-constant make-vector-extend
  152.   (primop make-vector-extend ()
  153.     ((primop.generate self node)
  154.      (generate-make-vector-extend node))))
  155.  
  156. (define-constant %make-extend
  157.   (primop %make-extend ()
  158.     ((primop.generate self node)
  159.      (generate-make-extend node))
  160.     ((primop.type self node)
  161.      '#[type (proc #f (proc #f top) template fixnum)])))
  162.  
  163. ;;; MAKE-PAIR
  164.  
  165. (define-constant %make-pair
  166.   (primop %make-pair ()
  167.     ((primop.generate self node)
  168.      (generate-make-pair node))
  169.     ((primop.type self node)
  170.      '#[type (proc #f (proc #f pair))])))
  171.  
  172. ;;; ONE-ARG-PRIMITIVES
  173. ;;;==========================================================================
  174.                       
  175. (define-constant descriptor->fixnum
  176.   (primop descriptor->fixnum ()
  177.     ((primop.generate self node)
  178.      (generate-one-arg
  179.       node
  180.       (lambda (acc t-reg)
  181.     (emit risc/srl (machine-num 2) acc scratch)
  182.     (emit risc/sll (machine-num 2) scratch t-reg)
  183.     (mark-continuation node t-reg))))
  184.     ((primop.type self node)
  185.      '#[type (proc #f (proc #f fixnum) top)])))
  186.  
  187. (define-constant descriptor-tag
  188.   (primop descriptor-tag ()
  189.     ((primop.generate self node)
  190.      (generate-one-arg
  191.       node
  192.       (lambda (acc t-reg)
  193.     (emit risc/sll (machine-num 2) acc t-reg)
  194.     (emit risc/and (machine-num #xF) t-reg t-reg)
  195.     (mark-continuation node t-reg))))
  196.     ((primop.type self node)
  197.      '#[type (proc #f (proc #f fixnum) top)])))
  198.                                            
  199. (define-constant header-type
  200.   (primop header-type ()
  201.     ((primop.generate self node)
  202.      (generate-one-arg
  203.       node
  204.       (lambda (acc t-reg)
  205.     (emit risc/and (machine-num #x7c) acc t-reg)
  206.     (mark-continuation node t-reg))))
  207.     ((primop.type self node)
  208.      '#[type (proc #f (proc #f fixnum) top)])))
  209.  
  210.  
  211.                             
  212. (define-constant %chdr
  213.   (primop %chdr ()
  214.     ((primop.side-effects? self) t)
  215.     ((primop.generate self node)
  216.      (generate-%chdr node))))
  217.  
  218.  
  219.  
  220.