home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / primops / vaxlow.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  9.0 KB  |  266 lines
  1. (herald vaxlow
  2.         (env (make-empty-early-binding-locale 'nil) constants primops arith locations))
  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 (return . args)
  28.   (ignore args)
  29.   (lap ()                           
  30.     (mnegl NARGS NARGS)             ; !!
  31.     (movl (@r sp) tp)
  32.     (jmp (@r tp))))
  33.                  
  34. (declare simplifier return simplify-values)
  35.  
  36. (define-constant (receive-values recipient thunk)
  37.   (ignore recipient thunk)
  38.   (lap ()
  39.     (pushl A1)                       ; push "recipient"
  40.     (pushal (label receiver))
  41.     (movl A2 P)                      ; prepare to call thunk
  42.     (movl ($ 1) NARGS)               ; thunk takes no arguments
  43.     (jmp (*d@r nil-reg slink/icall))))
  44.  
  45. (lap-template (1 0 -1 t stack handle-receiver)
  46. receiver
  47.     (movl (d@r SP 4) P)              ; prepare to call recipient
  48.     (moval (d@r SP 8) SP)            ; restore continuation
  49.     (mnegl NARGS NARGS)              ; !!
  50.     (jmp (*d@r nil-reg slink/icall))
  51. handle-receiver
  52.   (movl nil-reg AN)
  53.   (rsb))
  54.  
  55. (declare simplifier receive-values simplify-receive-values)
  56.                  
  57.  
  58. (define-constant make-pointer        ; extend and number of bytes
  59.   (primop make-pointer ()                                        
  60.     ((primop.generate self node)
  61.      (generate-make-pointer node))
  62.     ((primop.type self node)
  63.      '#[type (proc #f (proc #f top) top fixnum)])))
  64. ;     '#[type (proc #f (proc #f top) extend fixnum)])))
  65.  
  66.  
  67. (define-constant task-ref
  68.   (primop task-ref ()
  69.     ((primop.generate self node)
  70.      (generate-task-ref node))))
  71.  
  72. (define-constant set-task-ref
  73.   (primop set-task-ref ()
  74.     ((primop.side-effects? self) t)
  75.     ((primop.generate self node)
  76.      (generate-set-task-ref node))))
  77.  
  78. (define-constant slink-ref
  79.   (primop slink-ref ()
  80.     ((primop.generate self node)
  81.      (generate-slink-ref node))))
  82.  
  83. (define-constant set-slink-ref
  84.   (primop set-slink-ref ()
  85.     ((primop.side-effects? self) t)
  86.     ((primop.generate self node)
  87.      (generate-set-slink-ref node))))
  88.  
  89. (define-constant system-global
  90.   (object (lambda (i) (slink-ref i))
  91.     ((setter self)
  92.      (lambda (i val) (set-slink-ref i val)))))
  93.  
  94. (define-constant process-global
  95.   (object (lambda (i) (task-ref i))
  96.     ((setter self)
  97.      (lambda (i val) (set-task-ref i val)))))
  98.  
  99.  
  100. (define-constant stack-pointer
  101.   (primop stack-pointer ()
  102.     ((primop.generate self node)
  103.      (generate-stack-pointer node))))
  104.                                                    
  105. (define-constant current-continuation
  106.   (primop current-continuation ()
  107.     ((primop.generate self node)
  108.      (generate-current-continuation node))))
  109.  
  110. (define-constant disable-interrupts
  111.   (primop disable-interrupts ()
  112.     ((primop.side-effects? self) t)
  113.     ((primop.generate self node)
  114.      (emit vax/bisb2 
  115.           (machine-num #b10000000) 
  116.           (reg-offset TASK (fx+ task/critical-count 3))))
  117.     ((primop.type self node)
  118.      '#[type (proc #f (proc #f top))])))
  119.                        
  120. (define-constant really-enable-interrupts
  121.   (primop really-enable-interrupts ()
  122.     ((primop.side-effects? self) t)
  123.     ((primop.test-code self node arg)
  124.      (emit vax/bicb2 
  125.            (machine-num #b10000000) 
  126.            (reg-offset TASK (fx+ task/critical-count 3))))
  127.     ((primop.presimplify self node)
  128.      (presimplify-no-argument-predicate node))
  129.     ((primop.type self node)
  130.      '#[type (proc #f (proc #f top))])))
  131.                        
  132. (define-constant (enable-interrupts)
  133.   (if (not (really-enable-interrupts))
  134.       (handle-queued-interrupt (process-global task/critical-count))))
  135.  
  136.           
  137.  
  138. ;; template junk, see template.doc
  139.                                          
  140.                       
  141. (define-constant template-enclosing-object
  142.   (primop template-enclosing-object ()
  143.     ((primop.generate self node)
  144.      (receive (source target rep) (one-arg-primitive node)
  145.        (let ((reg (get-register 'scratch node '*)))
  146.          (generate-move source target)
  147.          (emit vax/movzwl (reg-offset target -6) reg)    ; offset field in bytes
  148.          (emit vax/subl2 reg target)
  149.          (mark-continuation node target))))
  150.     ((primop.type self node)
  151.      '#[type (proc #f (proc #f top) template)])))
  152.  
  153. (define-constant gc-extend->pair
  154.   (primop gc-extend->pair ()
  155.     ((primop.generate self node)
  156.      (receive (source target rep) (one-arg-primitive node)
  157.        (generate-move source target)
  158.        (emit vax/incl target)
  159.        (mark-continuation node target)))
  160.     ((primop.type self node) 
  161.      '#[type (proc #f (proc #f top) top)])))
  162.  
  163. (define-constant gc-pair->extend
  164.   (primop gc-pair->extend ()
  165.     ((primop.generate self node)
  166.      (receive (source target rep) (one-arg-primitive node)
  167.        (generate-move source target)
  168.        (emit vax/decl target)
  169.        (mark-continuation node target)))
  170.     ((primop.type self node)
  171.      '#[type (proc #f (proc #f top) top)])))
  172. ;     '#[type (proc #f (proc #f pair) extend)])))
  173.  
  174.                       
  175.                       
  176. (define-constant closure-enclosing-object
  177.   (primop closure-enclosing-object ()
  178.     ((primop.generate self node)
  179.      (generate-closure-enclosing-object node))
  180.     ((primop.type self node)
  181.      '#[type (proc #f (proc #f top) top)])))
  182. ;     '#[type (proc #f (proc #f top) extend)])))
  183.  
  184.                               
  185. (define-constant (bit-test operand bit)    ; true if bit is on
  186.   (if (fixnum-equal? (fixnum-logand operand (fixnum-ashl 1 bit)) 0)
  187.       '#f
  188.       '#t))
  189.                                    
  190. (define-constant (template-internal-bit? tem)
  191.   (let ((tem (if (fixnum-equal? (mref-16-u tem -2) vax-jump-absolute)
  192.                  (extend-pointer-elt tem 0)
  193.                  tem)))
  194.     (bit-test (mref-16-u tem -12) 0)))
  195.  
  196. (define-constant (template-superior-bit? tem) ; no cit's on stack
  197.   (bit-test (mref-16-u tem -12) 2))
  198.                                     
  199. (define-constant (template-nary? tem)
  200.   (bit-test (mref-8-u tem -4) 7))
  201.  
  202. (define-constant (template-pointer-slots tem)
  203.   (mref-8-u tem -5))
  204.  
  205. (define-constant (template-scratch-slots tem)
  206.   (mref-8-u tem -6))
  207.  
  208. (define-constant (template-nargs tem)
  209.   (mref-8-s tem -3))
  210.  
  211. (define-constant (template-encloser-offset template)
  212.   (fixnum-ashr (mref-16-u template -8) 2))
  213.  
  214. (define-constant (template-handler-offset template)
  215.   (mref-16-u template -10))
  216.  
  217. (define-constant (closure-encloser-offset closure)
  218.   (fixnum-ashr (mref-16-u (extend-header closure) -6) 2))
  219.  
  220.  
  221. (define-constant (unit-top-level-forms unit)
  222.   (make-pointer unit 3))
  223.  
  224. (define-constant (alt-bit-set? extend)            ; if bit 7 of header is on
  225.   (fixnum-less? (mref-8-s extend -4) 0))
  226.  
  227. (define-constant set-alt-bit!
  228.   (primop set-alt-bit! ()
  229.     ((primop.side-effects? self) t)
  230.     ((primop.generate self node)                               
  231.      (let ((reg (->register 'pointer node (leaf-value ((call-arg 2) node)) '*)))
  232.        (emit vax/bisb2 (machine-num #b10000000) (reg-offset reg -2))))
  233.     ((primop.type self node)
  234.      '#[type (proc #f (proc #f top) top)])))
  235. ;     '#[type (proc #f (proc #f top) extend)])))
  236.  
  237. (define-constant clear-alt-bit!
  238.   (primop clear-alt-bit! ()
  239.     ((primop.side-effects? self) t)
  240.     ((primop.generate self node)                               
  241.      (let ((reg (->register 'pointer node (leaf-value ((call-arg 2) node)) '*)))
  242.        (emit vax/bicb2 (machine-num #b10000000) (reg-offset reg -2))))
  243.     ((primop.type self node)
  244.      '#[type (proc #f (proc #f top) top)])))
  245. ;     '#[type (proc #f (proc #f top) extend)])))
  246.  
  247. (define-constant vcell-defined? alt-bit-set?)
  248.  
  249. (define-constant set-vcell-defined set-alt-bit!)
  250.  
  251. (define-constant set-vcell-undefined clear-alt-bit!)
  252.  
  253. (define-constant pure? alt-bit-set?)
  254.  
  255. (define-constant (purify! x)
  256.   (set-alt-bit! x)
  257.   (return))
  258.  
  259. (define (vframe-pointer-slots vframe)
  260.   (mref-8-u vframe -2))
  261.  
  262. (define (vframe-scratch-slots vframe)
  263.   (mref-8-u vframe -3))
  264.  
  265.  
  266.