home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / sap.lisp < prev    next >
Encoding:
Text File  |  1992-03-12  |  11.6 KB  |  414 lines
  1. ;;; -*- Package: RT; Log: c.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the Spice 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 Spice Lisp, please contact
  7. ;;; Scott Fahlman (FAHLMAN@CMUC). 
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; $Header: sap.lisp,v 1.15 92/03/11 20:47:38 wlott Exp $
  11. ;;;
  12. ;;; This file contains the IBM RT VM definition of SAP operations.
  13. ;;;
  14. ;;; Written by William Lott.
  15. ;;;
  16.  
  17. (in-package "RT")
  18.  
  19.  
  20.  
  21. ;;;; Moves and coercions:
  22.  
  23. ;;; MOVE-TO-SAP -- VOP.
  24. ;;;
  25. ;;; Move a tagged SAP to an untagged representation.
  26. ;;;
  27. (define-vop (move-to-sap)
  28.   (:args (x :scs (any-reg descriptor-reg)))
  29.   (:results (y :scs (sap-reg)))
  30.   (:generator 1
  31.     (loadw y x vm:sap-pointer-slot vm:other-pointer-type)))
  32. ;;;
  33. (define-move-vop move-to-sap :move
  34.   (descriptor-reg) (sap-reg))
  35.  
  36.  
  37. ;;; MOVE-FROM-SAP -- VOP.
  38. ;;;
  39. ;;; Move an untagged SAP to a tagged representation.
  40. ;;;
  41. (define-vop (move-from-sap)
  42.   (:args (sap :scs (sap-reg) :to :save))
  43.   (:temporary (:sc any-reg) header)
  44.   (:temporary (:sc word-pointer-reg) alloc)
  45.   (:results (y :scs (descriptor-reg)))
  46.   (:generator 1
  47.     (with-fixed-allocation (y header alloc sap-type sap-size)
  48.       (storew sap y sap-pointer-slot other-pointer-type))))
  49. ;;;
  50. (define-move-vop move-from-sap :move
  51.   (sap-reg) (descriptor-reg))
  52.  
  53.  
  54. ;;; SAP-MOVE -- VOP.
  55. ;;;
  56. ;;; Move untagged sap values.
  57. ;;;
  58. (define-vop (sap-move)
  59.   (:args (x :target y
  60.         :scs (sap-reg)
  61.         :load-if (not (location= x y))))
  62.   (:results (y :scs (sap-reg)
  63.            :load-if (not (location= x y))))
  64.   (:effects)
  65.   (:affected)
  66.   (:generator 0
  67.     (move y x)))
  68. ;;;
  69. (define-move-vop sap-move :move
  70.   (sap-reg) (sap-reg))
  71.  
  72.  
  73. ;;; MOVE-SAP-ARGUMENT -- VOP.
  74. ;;;
  75. ;;; Move untagged sap arguments/return-values.
  76. ;;;
  77. (define-vop (move-sap-argument)
  78.   (:args (x :target y
  79.         :scs (sap-reg))
  80.      (fp :scs (word-pointer-reg)
  81.          :load-if (not (sc-is y sap-reg))))
  82.   (:results (y))
  83.   (:generator 0
  84.     (sc-case y
  85.       (sap-reg
  86.        (move y x))
  87.       (sap-stack
  88.        (storew x fp (tn-offset y))))))
  89. ;;;
  90. (define-move-vop move-sap-argument :move-argument
  91.   (descriptor-reg sap-reg) (sap-reg))
  92.  
  93.  
  94. ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
  95. ;;; descriptor passing location.
  96. ;;;
  97. (define-move-vop move-argument :move-argument
  98.   (sap-reg) (descriptor-reg))
  99.  
  100.  
  101.  
  102. ;;;; SAP-INT and INT-SAP
  103.  
  104. (define-vop (sap-int)
  105.   (:args (sap :scs (sap-reg) :target int))
  106.   (:arg-types system-area-pointer)
  107.   (:results (int :scs (unsigned-reg)))
  108.   (:result-types unsigned-num)
  109.   (:translate sap-int)
  110.   (:policy :fast-safe) 
  111.  (:generator 1
  112.     (move int sap)))
  113.  
  114. (define-vop (int-sap)
  115.   (:args (int :scs (unsigned-reg) :target sap))
  116.   (:arg-types unsigned-num)
  117.   (:results (sap :scs (sap-reg)))
  118.   (:result-types system-area-pointer)
  119.   (:translate int-sap)
  120.   (:policy :fast-safe)
  121.   (:generator 1
  122.     (move sap int)))
  123.  
  124.  
  125.  
  126. ;;;; POINTER+ and POINTER-
  127.  
  128. (define-vop (pointer+)
  129.   (:translate sap+)
  130.   (:args (ptr :scs (sap-reg) :target res)
  131.      (offset :scs (signed-reg) :to :save))
  132.   (:arg-types system-area-pointer signed-num)
  133.   (:results (res :scs (sap-reg)))
  134.   (:result-types system-area-pointer)
  135.   (:policy :fast-safe)
  136.   (:generator 2
  137.     ;; Can't use CAS since offset and ptr may be register 0, so we have to move.
  138.     (move res ptr)
  139.     (inst a res offset)))
  140. ;;;
  141. (define-vop (pointer+-c pointer+)
  142.   (:args (ptr :scs (sap-reg)))
  143.   (:info offset)
  144.   (:arg-types system-area-pointer (:constant (signed-byte 16)))
  145.   (:generator 1
  146.     (inst a res ptr offset)))
  147.  
  148. (define-vop (pointer-)
  149.   (:translate sap-)
  150.   (:args (ptr1 :scs (sap-reg) :target res)
  151.      (ptr2 :scs (sap-reg) :to :save))
  152.   (:arg-types system-area-pointer system-area-pointer)
  153.   (:policy :fast-safe)
  154.   (:results (res :scs (signed-reg)))
  155.   (:result-types signed-num)
  156.   (:generator 1
  157.     (move res ptr1)
  158.     (inst s res ptr2)))
  159.  
  160.  
  161.  
  162. ;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
  163.  
  164. (eval-when (compile eval)
  165.  
  166. ;;; DEFINE-SYSTEM-REF -- Internal Interface.
  167. ;;;
  168. ;;; Name is the name of a computed system-ref offset, from which we generate a
  169. ;;; <name>-c VOP for immediate constant offsets.  Shift is the multiples of two
  170. ;;; for which we must adjust the offset to make it an index in terms of bytes
  171. ;;; (the machines address units).  Translate and signed-translate are the Lisp
  172. ;;; function calls for which these VOP's are in-line expansions.
  173. ;;;
  174. (defmacro define-system-ref (name size translate result-sc result-type
  175.                   &optional
  176.                   signed-translate signed-result-sc
  177.                   signed-result-type)
  178.   (let ((access-form 
  179.      (ecase size
  180.        (:byte
  181.         '((inst lc result base offset)
  182.           (when signed
  183.         (inst sl result 24)
  184.         (inst sar result 24))))
  185.        (:halfword
  186.         '((if signed
  187.           (inst lha result base offset)
  188.           (inst lh result base offset))))
  189.        (:word
  190.         '(signed ; suppress silly warnings.
  191.           (inst l result base offset)))))
  192.     (name-c (symbolicate name "-C")))
  193.     `(progn
  194.        (define-vop (,name-c)
  195.      (:policy :fast-safe)
  196.      (:translate ,translate)
  197.      (:args (base :scs (sap-reg)))
  198.      (:results (result :scs (,result-sc)))
  199.      (:result-types ,result-type)
  200.      (:arg-types system-area-pointer (:constant (unsigned-byte 15)))
  201.      (:info offset)
  202.      (:variant-vars signed)
  203.      (:variant nil)
  204.      (:generator 5
  205.        ,@access-form))
  206.        
  207.        (define-vop (,name)
  208.      (:policy :fast-safe)
  209.      (:translate ,translate)
  210.      (:args (object :scs (sap-reg))
  211.         (offset :scs (unsigned-reg) :target base))
  212.      (:results (result :scs (,result-sc)))
  213.      (:arg-types system-area-pointer positive-fixnum)
  214.      (:result-types ,result-type)
  215.      (:temporary (:scs (sap-reg) :from (:argument 1) :to :eval) base)
  216.      (:variant-vars signed)
  217.      (:variant nil)
  218.      (:generator 7
  219.        (inst cas base offset object)
  220.        (let ((offset 0))
  221.          ,@access-form)))
  222.        
  223.        ,@(when signed-translate
  224.        `((define-vop (,(symbolicate "SIGNED-" name-c) ,name-c)
  225.            (:translate ,signed-translate)
  226.            (:results (result :scs (,signed-result-sc)))
  227.            (:result-types ,signed-result-type)
  228.            (:variant t))
  229.          
  230.          (define-vop (,(symbolicate "SIGNED-" name) ,name)
  231.            (:translate ,signed-translate)
  232.            (:results (result :scs (,signed-result-sc)))
  233.            (:result-types ,signed-result-type)
  234.            (:variant t)))))))
  235.  
  236. ) ;eval-when
  237.  
  238. (define-system-ref 8bit-system-ref :byte
  239.   sap-ref-8 unsigned-reg positive-fixnum
  240.   signed-sap-ref-8 signed-reg tagged-num)
  241.  
  242. (define-system-ref 16bit-system-ref :halfword
  243.   sap-ref-16 unsigned-reg positive-fixnum
  244.   signed-sap-ref-16 signed-reg tagged-num)
  245.  
  246. (define-system-ref 32bit-system-ref :word
  247.   sap-ref-32 unsigned-reg unsigned-num
  248.   signed-sap-ref-32 signed-reg signed-num)
  249.  
  250. (define-system-ref sap-system-ref :word
  251.   sap-ref-sap sap-reg system-area-pointer)
  252.  
  253.  
  254. (eval-when (compile eval)
  255.  
  256. ;;; DEFINE-SYSTEM-SET -- Internal.
  257. ;;;
  258. ;;; Name is the name of a computed system-ref offset, from which we generate a
  259. ;;; <name>-c VOP for immediate constant offsets.  Shift is the multiples of two
  260. ;;; for which we must adjust the offset to make it an index in terms of bytes
  261. ;;; (the machines address units).  Translate and signed-translate are the Lisp
  262. ;;; function calls for which these VOP's are in-line expansions.
  263. ;;;
  264. (defmacro define-system-set (name size translate data-sc data-type)
  265.   (let ((set-form 
  266.      (ecase size
  267.        (:byte '(inst stc data base offset))
  268.        (:halfword '(inst sth data base offset))
  269.        (:word '(inst st data base offset))))
  270.     (name-c (symbolicate name "-C")))
  271.     `(progn
  272.        (define-vop (,name-c)
  273.      (:policy :fast-safe)
  274.      (:translate ,translate)
  275.      (:args (base :scs (sap-reg))
  276.         (data :scs (,data-sc) :target result :to (:result 0)))
  277.      (:arg-types system-area-pointer
  278.              (:constant (unsigned-byte 15))
  279.              ,data-type)
  280.      (:results (result :scs (,data-sc)))
  281.      (:result-types ,data-type)
  282.      (:info offset)
  283.      (:generator 5
  284.        ,set-form
  285.        (move result data)))
  286.        
  287.        (define-vop (,name)
  288.      (:policy :fast-safe)
  289.      (:translate ,translate)
  290.      (:args (object :scs (sap-reg))
  291.         (offset :scs (unsigned-reg))
  292.         (data :scs (,data-sc) :target result))
  293.      (:arg-types system-area-pointer positive-fixnum ,data-type)
  294.      (:temporary (:scs (sap-reg) :from (:argument 1)) base)
  295.      (:results (result :scs (,data-sc)))
  296.      (:result-types ,data-type)
  297.      (:generator 7
  298.        (inst cas base offset object)
  299.        (let ((offset 0))
  300.          ,set-form)
  301.        (move result data))))))
  302.  
  303. ) ;EVAL-WHEN
  304.  
  305. (define-system-set 8bit-system-set :byte %set-sap-ref-8
  306.   unsigned-reg positive-fixnum)
  307.  
  308. (define-system-set 16bit-system-set :halfword %set-sap-ref-16
  309.   unsigned-reg positive-fixnum)
  310.  
  311. (define-system-set 32bit-system-set :word %set-sap-ref-32
  312.   unsigned-reg unsigned-num)
  313.  
  314. (define-system-set signed-8bit-system-set :byte %set-signed-sap-ref-8
  315.   signed-reg tagged-num)
  316.  
  317. (define-system-set signed-16bit-system-set :halfword %set-signed-sap-ref-16
  318.   signed-reg tagged-num)
  319.  
  320. (define-system-set signed-32bit-system-set :word %set-signed-sap-ref-32
  321.   signed-reg signed-num)
  322.  
  323.  
  324. (define-system-set sap-system-set :word %set-sap-ref-sap
  325.   sap-reg system-area-pointer)
  326.  
  327. #| 
  328.  
  329. Maybe we can get away with using define-system-set now that offsets don't 
  330. need to be shifted.
  331.  
  332. ;;; Ugly, because there are only 2 free sap-regs.  We stash the data value in
  333. ;;; NARGS to free up a sap-reg for BASE.
  334. ;;;
  335. (define-vop (sap-system-set)
  336.   (:policy :fast-safe)
  337.   (:translate %set-sap-ref-sap)
  338.   (:args (object :scs (sap-reg))
  339.      (offset :scs (unsigned-reg) :target base)
  340.      (data :scs (sap-reg sap-stack)))
  341.   (:arg-types system-area-pointer positive-fixnum system-area-pointer)
  342.   (:temporary (:scs (sap-reg) :from (:eval 0) :to (:eval 1)) base)
  343.   (:temporary (:scs (non-descriptor-reg) :offset nargs-offset
  344.            :from (:eval 0) :to (:eval 1))
  345.           save)
  346.   (:vop-var vop)
  347.   (:results (result :scs (sap-reg)))
  348.   (:result-types system-area-pointer)
  349.   (:generator 7
  350.     (sc-case data
  351.       (sap-reg (move save data))
  352.       (sap-stack
  353.        (loadw save (current-nfp-tn vop) (* (tn-offset data) vm:word-bytes))))
  354.        
  355.     (inst cas base offset object)
  356.     (inst st save base)
  357.     (move result save)))
  358.  
  359. (define-vop (sap-system-set-c)
  360.   (:policy :fast-safe)
  361.   (:translate %set-sap-ref-sap)
  362.   (:args (object :scs (sap-reg))
  363.      (data :scs (sap-reg) :target result))
  364.   (:info offset)
  365.   (:arg-types system-area-pointer
  366.           (:constant (unsigned-byte 16))
  367.           system-area-pointer)
  368.   (:results (result :scs (sap-reg)))
  369.   (:result-types system-area-pointer)
  370.   (:generator 4
  371.     (inst st data object offset)
  372.     (move result data)))
  373.  
  374. |#
  375.  
  376. ;;; fake the presence of sap-ref-single and sap-ref-double.
  377.  
  378. (def-source-transform sap-ref-single (sap offset)
  379.   `(make-single-float (signed-sap-ref-32 ,sap ,offset)))
  380.  
  381. (def-source-transform %set-sap-ref-single (sap offset value)
  382.   (once-only ((sap sap) (offset offset) (value value))
  383.     `(progn
  384.        (setf (signed-sap-ref-32 ,sap ,offset)
  385.          (single-float-bits ,value))
  386.        ,value)))
  387.  
  388. (def-source-transform sap-ref-double (sap offset)
  389.   (once-only ((sap sap) (offset offset))
  390.     `(make-double-float (signed-sap-ref-32 ,sap ,offset)
  391.             (sap-ref-32 ,sap (+ ,offset word-bytes)))))
  392.  
  393. (def-source-transform %set-sap-ref-double (sap offset value)
  394.   (once-only ((sap sap) (offset offset) (value value))
  395.     `(progn
  396.        (setf (signed-sap-ref-32 ,sap ,offset)
  397.          (double-float-high-bits ,value))
  398.        (setf (sap-ref-32 ,sap (+ ,offset word-bytes))
  399.          (double-float-low-bits ,value))
  400.        ,value)))
  401.  
  402.  
  403. ;;;; Noise to convert normal lisp data objects into SAPs.
  404.  
  405. (define-vop (vector-sap)
  406.   (:translate vector-sap)
  407.   (:policy :fast-safe)
  408.   (:args (vector :scs (descriptor-reg)))
  409.   (:results (sap :scs (sap-reg)))
  410.   (:result-types system-area-pointer)
  411.   (:generator 2
  412.     (inst cal sap vector
  413.       (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type))))
  414.