home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / machines / sparc / machin.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  13.5 KB  |  401 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: machin.scm,v 1.3 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Machine Model for SPARC
  23. ;;; package: (compiler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Architecture Parameters
  28.  
  29. (define use-pre/post-increment? false)
  30. (define endianness 'BIG)
  31. (define-integrable addressing-granularity 8)
  32. (define-integrable scheme-object-width 32)
  33. (define-integrable scheme-type-width 6)    ;or 8
  34. (define-integrable type-scale-factor (expt 2 (- 8 scheme-type-width)))
  35.  
  36. (define-integrable scheme-datum-width
  37.   (- scheme-object-width scheme-type-width))
  38.  
  39. (define-integrable float-width 64)
  40. (define-integrable float-alignment 64)
  41.  
  42. (define-integrable address-units-per-float
  43.   (quotient float-width addressing-granularity))
  44.  
  45. ;;; It is currently required that both packed characters and objects
  46. ;;; be integrable numbers of address units.  Furthermore, the number
  47. ;;; of address units per object must be an integral multiple of the
  48. ;;; number of address units per character.  This will cause problems
  49. ;;; on a machine that is word addressed, in which case we will have to
  50. ;;; rethink the character addressing strategy.
  51.  
  52. (define-integrable address-units-per-object
  53.   (quotient scheme-object-width addressing-granularity))
  54.  
  55. (define-integrable address-units-per-packed-char 1)
  56.  
  57. (define-integrable signed-fixnum/upper-limit (expt 2 (-1+ scheme-datum-width)))
  58. (define-integrable signed-fixnum/lower-limit (- signed-fixnum/upper-limit))
  59. (define-integrable unsigned-fixnum/upper-limit (* 2 signed-fixnum/upper-limit))
  60.  
  61. (define-integrable (stack->memory-offset offset) offset)
  62. (define-integrable ic-block-first-parameter-offset 2)
  63. (define-integrable execute-cache-size 3) ; Long words per UUO link slot
  64. (define-integrable closure-entry-size
  65.   ;; Long words in a single closure entry:
  66.   ;;   Format + GC offset word
  67.   ;;   SETHI
  68.   ;;   JALR/JAL
  69.   ;;   ADDI
  70.   4)
  71.  
  72. ;; Given: the number of entry points in a closure, and a particular
  73. ;; entry point number. Return: the distance from that entry point to
  74. ;; the first variable slot in the closure (in words).
  75.  
  76. (define (closure-first-offset nentries entry)
  77.   (if (zero? nentries)
  78.       1                    ; Strange boundary case
  79.       (- (* closure-entry-size (- nentries entry)) 1)))
  80.  
  81. ;; Like the above, but from the start of the complete closure object,
  82. ;; viewed as a vector, and including the header word.
  83.  
  84. (define (closure-object-first-offset nentries)
  85.   (case nentries
  86.     ((0)
  87.      ;; Vector header only
  88.      1)
  89.     ((1)
  90.      ;; Manifest closure header followed by single entry point
  91.      (+ 1 closure-entry-size))
  92.     (else
  93.      ;; Manifest closure header, number of entries, then entries.
  94.      (+ 1 1 (* closure-entry-size nentries)))))
  95.  
  96. ;; Bump from one entry point to another -- distance in BYTES
  97.  
  98. (define (closure-entry-distance nentries entry entry*)
  99.   nentries                ; ignored
  100.   (* (* closure-entry-size 4) (- entry* entry)))
  101.  
  102. ;; Bump to the canonical entry point.  On a RISC (which forces
  103. ;; longword alignment for entry points anyway) there is no need to
  104. ;; canonicalize.
  105.  
  106. (define (closure-environment-adjustment nentries entry)
  107.   nentries entry            ; ignored
  108.   0)
  109.  
  110. ;;;; Machine Registers
  111.  
  112. (define-integrable g0 0)
  113. (define-integrable g1 1)
  114. (define-integrable g2 2)
  115. (define-integrable g3 3)
  116. (define-integrable g4 4)
  117. (define-integrable g5 5)
  118. (define-integrable g6 6)
  119. (define-integrable g7 7)
  120. (define-integrable g8 8)
  121. (define-integrable g9 9)
  122. (define-integrable g10 10)
  123. (define-integrable g11 11)
  124. (define-integrable g12 12)
  125. (define-integrable g13 13)
  126. (define-integrable g14 14)
  127. (define-integrable g15 15)
  128. (define-integrable g16 16)
  129. (define-integrable g17 17)
  130. (define-integrable g18 18)
  131. (define-integrable g19 19)
  132. (define-integrable g20 20)
  133. (define-integrable g21 21)
  134. (define-integrable g22 22)
  135. (define-integrable g23 23)
  136. (define-integrable g24 24)
  137. (define-integrable g25 25)
  138. (define-integrable g26 26)
  139. (define-integrable g27 27)
  140. (define-integrable g28 28)
  141. (define-integrable g29 29)
  142. (define-integrable g30 30)
  143. (define-integrable g31 31)
  144.  
  145. ;; Floating point general registers --  the odd numbered ones are
  146. ;; only used when transferring to/from the CPU
  147. (define-integrable fp0 32)
  148. (define-integrable fp1 33)
  149. (define-integrable fp2 34)
  150. (define-integrable fp3 35)
  151. (define-integrable fp4 36)
  152. (define-integrable fp5 37)
  153. (define-integrable fp6 38)
  154. (define-integrable fp7 39)
  155. (define-integrable fp8 40)
  156. (define-integrable fp9 41)
  157. (define-integrable fp10 42)
  158. (define-integrable fp11 43)
  159. (define-integrable fp12 44)
  160. (define-integrable fp13 45)
  161. (define-integrable fp14 46)
  162. (define-integrable fp15 47)
  163. (define-integrable fp16 48)
  164. (define-integrable fp17 49)
  165. (define-integrable fp18 50)
  166. (define-integrable fp19 51)
  167. (define-integrable fp20 52)
  168. (define-integrable fp21 53)
  169. (define-integrable fp22 54)
  170. (define-integrable fp23 55)
  171. (define-integrable fp24 56)
  172. (define-integrable fp25 57)
  173. (define-integrable fp26 58)
  174. (define-integrable fp27 59)
  175. (define-integrable fp28 60)
  176. (define-integrable fp29 61)
  177. (define-integrable fp30 62)
  178. (define-integrable fp31 63)
  179.  
  180. (define-integrable number-of-machine-registers 64)
  181. (define-integrable number-of-temporary-registers 256)
  182.  
  183. ;;; Fixed-use registers for Scheme compiled code.
  184. (define-integrable regnum:return-value g16)
  185. (define-integrable regnum:stack-pointer g17)
  186. (define-integrable regnum:memtop g18)
  187. (define-integrable regnum:free g19)
  188. (define-integrable regnum:scheme-to-interface g20)
  189. (define-integrable regnum:dynamic-link g21)
  190. (define-integrable regnum:closure-free g22)
  191. (define-integrable regnum:address-mask g25)
  192. (define-integrable regnum:regs-pointer g26)
  193. (define-integrable regnum:quad-bits g27)
  194. (define-integrable regnum:closure-hook g28)
  195. (define-integrable regnum:interface-index g13)
  196.  
  197. ;;; Fixed-use registers due to architecture or OS calling conventions.
  198. (define-integrable regnum:zero g0)
  199. (define-integrable regnum:assembler-temp g1)
  200. (define-integrable regnum:C-return-receive-value g8)
  201. (define-integrable regnum:C-return-send-value g24)
  202. (define-integrable regnum:C-stack-pointer g14)
  203. (define-integrable regnum:first-arg g8)
  204. (define-integrable regnum:second-arg g9)
  205. (define-integrable regnum:third-arg g10)
  206. (define-integrable regnum:fourth-arg g11)
  207. (define-integrable regnum:fifth-arg g12)
  208. (define-integrable regnum:sixth-arg g13)
  209. (define-integrable regnum:reserved-global-1 g2)
  210. (define-integrable regnum:reserved-global-2 g3)
  211. (define-integrable regnum:reserved-global-3 g4)
  212. (define-integrable regnum:reserved-global-4 g5)
  213. (define-integrable regnum:reserved-global-5 g6)
  214. (define-integrable regnum:reserved-global-6 g7)
  215. (define-integrable regnum:linkage g31)
  216. (define-integrable regnum:call-result g15)
  217.  
  218. (define address-regs
  219.   (list regnum:stack-pointer regnum:memtop regnum:free regnum:dynamic-link
  220.     regnum:linkage))
  221.  
  222. (define object-regs
  223.   (list regnum:return-value regnum:C-return-send-value))
  224.  
  225. (define immediate-regs
  226.   (list regnum:address-mask regnum:quad-bits))
  227.  
  228. (define unboxed-regs
  229.   (list regnum:scheme-to-interface
  230.     regnum:regs-pointer regnum:assembler-temp
  231.     regnum:reserved-global-4
  232.     regnum:reserved-global-5
  233.     regnum:reserved-global-6
  234.     regnum:C-stack-pointer
  235.     ))
  236.     
  237. (define machine-register-value-class
  238.   (lambda (register)
  239.     (cond ((member register address-regs) value-class=address)
  240.       ((member register object-regs) value-class=object)
  241.       ((member register immediate-regs) value-class=immediate)
  242.       ((member register unboxed-regs) value-class=unboxed)
  243.       ((<= g0 register g31) value-class=word)
  244.       ((<= fp0 register fp31) value-class=float)
  245.       (else (error "illegal machine register" register)))))
  246.  
  247. (define-integrable (machine-register-known-value register)
  248.   register                ;ignore
  249.   false)
  250.  
  251. ;;;; Interpreter Registers
  252.  
  253. (define-integrable (interpreter-free-pointer)
  254.   (rtl:make-machine-register regnum:free))
  255.  
  256. (define (interpreter-free-pointer? expression)
  257.   (and (rtl:register? expression)
  258.        (= (rtl:register-number expression) regnum:free)))
  259.  
  260. (define-integrable (interpreter-regs-pointer)
  261.   (rtl:make-machine-register regnum:regs-pointer))
  262.  
  263. (define (interpreter-regs-pointer? expression)
  264.   (and (rtl:register? expression)
  265.        (= (rtl:register-number expression) regnum:regs-pointer)))
  266.  
  267. (define-integrable (interpreter-value-register)
  268.   (rtl:make-machine-register regnum:return-value))
  269.  
  270. (define (interpreter-value-register? expression)
  271.   (and (rtl:register? expression)
  272.        (= (rtl:register-number expression) regnum:return-value)))
  273.  
  274. (define-integrable (interpreter-stack-pointer)
  275.   (rtl:make-machine-register regnum:stack-pointer))
  276.  
  277. (define (interpreter-stack-pointer? expression)
  278.   (and (rtl:register? expression)
  279.        (= (rtl:register-number expression) regnum:stack-pointer)))
  280.  
  281. (define-integrable (interpreter-dynamic-link)
  282.   (rtl:make-machine-register regnum:dynamic-link))
  283.  
  284. (define (interpreter-dynamic-link? expression)
  285.   (and (rtl:register? expression)
  286.        (= (rtl:register-number expression) regnum:dynamic-link)))
  287.  
  288. (define-integrable (interpreter-environment-register)
  289.   (rtl:make-offset (interpreter-regs-pointer) 3))
  290.  
  291. (define (interpreter-environment-register? expression)
  292.   (and (rtl:offset? expression)
  293.        (interpreter-regs-pointer? (rtl:offset-base expression))
  294.        (= 3 (rtl:offset-number expression))))
  295.  
  296. (define-integrable (interpreter-register:access)
  297.   (rtl:make-machine-register regnum:C-return-send-value))
  298.  
  299. (define-integrable (interpreter-register:cache-reference)
  300.   (rtl:make-machine-register regnum:C-return-send-value))
  301.  
  302. (define-integrable (interpreter-register:cache-unassigned?)
  303.   (rtl:make-machine-register regnum:C-return-send-value))
  304.  
  305. (define-integrable (interpreter-register:lookup)
  306.   (rtl:make-machine-register regnum:C-return-send-value))
  307.  
  308. (define-integrable (interpreter-register:unassigned?)
  309.   (rtl:make-machine-register regnum:C-return-send-value))
  310.  
  311. (define-integrable (interpreter-register:unbound?)
  312.   (rtl:make-machine-register regnum:C-return-send-value))
  313.  
  314. ;;;; RTL Registers, Constants, and Primitives
  315.  
  316. (define (rtl:machine-register? rtl-register)
  317.   (case rtl-register
  318.     ((STACK-POINTER)
  319.      (interpreter-stack-pointer))
  320.     ((DYNAMIC-LINK)
  321.      (interpreter-dynamic-link))
  322.     ((VALUE)
  323.      (interpreter-value-register))
  324.     ((INTERPRETER-CALL-RESULT:ACCESS)
  325.      (interpreter-register:access))
  326.     ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
  327.      (interpreter-register:cache-reference))
  328.     ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
  329.      (interpreter-register:cache-unassigned?))
  330.     ((INTERPRETER-CALL-RESULT:LOOKUP)
  331.      (interpreter-register:lookup))
  332.     ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
  333.      (interpreter-register:unassigned?))
  334.     ((INTERPRETER-CALL-RESULT:UNBOUND?)
  335.      (interpreter-register:unbound?))
  336.     (else false)))
  337.  
  338. (define (rtl:interpreter-register? rtl-register)
  339.   (case rtl-register
  340.     ((MEMORY-TOP) 0)
  341.     ((STACK-GUARD) 1)
  342.     ((ENVIRONMENT) 3)
  343.     ((TEMPORARY) 4)
  344.     (else false)))
  345.  
  346. (define (rtl:interpreter-register->offset locative)
  347.   (or (rtl:interpreter-register? locative)
  348.       (error "Unknown register type" locative)))
  349.  
  350. (define (rtl:constant-cost expression)
  351.   ;; Magic numbers.
  352.   (let ((if-integer
  353.      (lambda (value)
  354.        (cond ((zero? value) 1)
  355.          ((or (fits-in-16-bits-signed? value)
  356.               (fits-in-16-bits-unsigned? value)
  357.               (top-16-bits-only? value))
  358.           2)
  359.          (else 3)))))
  360.     (let ((if-synthesized-constant
  361.        (lambda (type datum)
  362.          (if-integer (make-non-pointer-literal type datum)))))
  363.       (case (rtl:expression-type expression)
  364.     ((CONSTANT)
  365.      (let ((value (rtl:constant-value expression)))
  366.        (if (non-pointer-object? value)
  367.            (if-synthesized-constant (object-type value)
  368.                     (object-datum value))
  369.            3)))
  370.     ((MACHINE-CONSTANT)
  371.      (if-integer (rtl:machine-constant-value expression)))
  372.     ((ENTRY:PROCEDURE
  373.       ENTRY:CONTINUATION
  374.       ASSIGNMENT-CACHE
  375.       VARIABLE-CACHE
  376.       OFFSET-ADDRESS)
  377.      3)
  378.     ((CONS-NON-POINTER)
  379.      (and (rtl:machine-constant? (rtl:cons-non-pointer-type expression))
  380.           (rtl:machine-constant? (rtl:cons-non-pointer-datum expression))
  381.           (if-synthesized-constant
  382.            (rtl:machine-constant-value
  383.         (rtl:cons-non-pointer-type expression))
  384.            (rtl:machine-constant-value
  385.         (rtl:cons-non-pointer-datum expression)))))
  386.     (else false)))))
  387.  
  388. (define compiler:open-code-floating-point-arithmetic?
  389.   true)
  390.  
  391. (set! compiler:open-code-primitives? #f)
  392.  
  393. (define compiler:primitives-with-no-open-coding
  394.   '(DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER
  395.     FIXNUM-NOT FIXNUM-AND FIXNUM-ANDC FIXNUM-OR FIXNUM-XOR FIXNUM-LSH
  396.     INTEGER-QUOTIENT INTEGER-REMAINDER &/ QUOTIENT REMAINDER
  397.     FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS
  398.     FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE FLONUM-ROUND
  399.     FLONUM-REMAINDER FLONUM-SQRT
  400.     VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
  401.     FLOATING-VECTOR-REF FLOATING-VECTOR-SET!))