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 / mips / machin.scm < prev    next >
Text File  |  1999-01-02  |  14KB  |  391 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: machin.scm,v 1.15 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 MIPS
  23. ;;; package: (compiler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Architecture Parameters
  28.  
  29. (define use-pre/post-increment? false)
  30. (define endianness 'LITTLE)
  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 2) ; 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.   ;;   JALR/JAL
  68.   ;;   ADDI
  69.   3)
  70.  
  71. ;; Given: the number of entry points in a closure, and a particular
  72. ;; entry point number. Return: the distance from that entry point to
  73. ;; the first variable slot in the closure (in words).
  74.  
  75. (define (closure-first-offset nentries entry)
  76.   (if (zero? nentries)
  77.       1                    ; Strange boundary case
  78.       (- (* closure-entry-size (- nentries entry)) 1)))
  79.  
  80. ;; Like the above, but from the start of the complete closure object,
  81. ;; viewed as a vector, and including the header word.
  82.  
  83. (define (closure-object-first-offset nentries)
  84.   (case nentries
  85.     ((0)
  86.      ;; Vector header only
  87.      1)
  88.     ((1)
  89.      ;; Manifest closure header followed by single entry point
  90.      (+ 1 closure-entry-size))
  91.     (else
  92.      ;; Manifest closure header, number of entries, then entries.
  93.      (+ 1 1 (* closure-entry-size nentries)))))
  94.  
  95. ;; Bump from one entry point to another -- distance in BYTES
  96.  
  97. (define (closure-entry-distance nentries entry entry*)
  98.   nentries                ; ignored
  99.   (* (* closure-entry-size 4) (- entry* entry)))
  100.  
  101. ;; Bump to the canonical entry point.  On a RISC (which forces
  102. ;; longword alignment for entry points anyway) there is no need to
  103. ;; canonicalize.
  104.  
  105. (define (closure-environment-adjustment nentries entry)
  106.   nentries entry            ; ignored
  107.   0)
  108.  
  109. ;;;; Machine Registers
  110.  
  111. (define-integrable g0 0)
  112. (define-integrable g1 1)
  113. (define-integrable g2 2)
  114. (define-integrable g3 3)
  115. (define-integrable g4 4)
  116. (define-integrable g5 5)
  117. (define-integrable g6 6)
  118. (define-integrable g7 7)
  119. (define-integrable g8 8)
  120. (define-integrable g9 9)
  121. (define-integrable g10 10)
  122. (define-integrable g11 11)
  123. (define-integrable g12 12)
  124. (define-integrable g13 13)
  125. (define-integrable g14 14)
  126. (define-integrable g15 15)
  127. (define-integrable g16 16)
  128. (define-integrable g17 17)
  129. (define-integrable g18 18)
  130. (define-integrable g19 19)
  131. (define-integrable g20 20)
  132. (define-integrable g21 21)
  133. (define-integrable g22 22)
  134. (define-integrable g23 23)
  135. (define-integrable g24 24)
  136. (define-integrable g25 25)
  137. (define-integrable g26 26)
  138. (define-integrable g27 27)
  139. (define-integrable g28 28)
  140. (define-integrable g29 29)
  141. (define-integrable g30 30)
  142. (define-integrable g31 31)
  143.  
  144. ;; Floating point general registers --  the odd numbered ones are
  145. ;; only used when transferring to/from the CPU
  146. (define-integrable fp0 32)
  147. (define-integrable fp1 33)
  148. (define-integrable fp2 34)
  149. (define-integrable fp3 35)
  150. (define-integrable fp4 36)
  151. (define-integrable fp5 37)
  152. (define-integrable fp6 38)
  153. (define-integrable fp7 39)
  154. (define-integrable fp8 40)
  155. (define-integrable fp9 41)
  156. (define-integrable fp10 42)
  157. (define-integrable fp11 43)
  158. (define-integrable fp12 44)
  159. (define-integrable fp13 45)
  160. (define-integrable fp14 46)
  161. (define-integrable fp15 47)
  162. (define-integrable fp16 48)
  163. (define-integrable fp17 49)
  164. (define-integrable fp18 50)
  165. (define-integrable fp19 51)
  166. (define-integrable fp20 52)
  167. (define-integrable fp21 53)
  168. (define-integrable fp22 54)
  169. (define-integrable fp23 55)
  170. (define-integrable fp24 56)
  171. (define-integrable fp25 57)
  172. (define-integrable fp26 58)
  173. (define-integrable fp27 59)
  174. (define-integrable fp28 60)
  175. (define-integrable fp29 61)
  176. (define-integrable fp30 62)
  177. (define-integrable fp31 63)
  178.  
  179. (define-integrable number-of-machine-registers 63)
  180. (define-integrable number-of-temporary-registers 256)
  181.  
  182. ;;; Fixed-use registers for Scheme compiled code.
  183. (define-integrable regnum:return-value g2)
  184. (define-integrable regnum:stack-pointer g3)
  185. (define-integrable regnum:memtop g8)
  186. (define-integrable regnum:free g9)
  187. (define-integrable regnum:scheme-to-interface g10)
  188. (define-integrable regnum:dynamic-link g11)
  189. (define-integrable regnum:closure-free g19)
  190. (define-integrable regnum:address-mask g20)
  191. (define-integrable regnum:regs-pointer g21)
  192. (define-integrable regnum:quad-bits g22)
  193. (define-integrable regnum:closure-hook g23)
  194. (define-integrable regnum:interface-index g25)
  195.  
  196. ;;; Fixed-use registers due to architecture or OS calling conventions.
  197. (define-integrable regnum:zero g0)
  198. (define-integrable regnum:assembler-temp g1)
  199. (define-integrable regnum:C-return-value g2)
  200. (define-integrable regnum:first-arg g4)
  201. (define-integrable regnum:second-arg g5)
  202. (define-integrable regnum:third-arg g6)
  203. (define-integrable regnum:fourth-arg g7)
  204. (define-integrable regnum:kernel-reserved-1 g26)
  205. (define-integrable regnum:kernel-reserved-2 g27)
  206. (define-integrable regnum:C-global-pointer g28)
  207. (define-integrable regnum:C-stack-pointer g29)
  208. (define-integrable regnum:linkage g31)
  209.  
  210. (define machine-register-value-class
  211.   (let ((special-registers
  212.      `((,regnum:return-value        . ,value-class=object)
  213.        (,regnum:stack-pointer       . ,value-class=address)
  214.        (,regnum:memtop              . ,value-class=address)
  215.        (,regnum:free                . ,value-class=address)
  216.        (,regnum:scheme-to-interface . ,value-class=unboxed)
  217.        (,regnum:closure-hook    . ,value-class=unboxed)
  218.        (,regnum:closure-free    . ,value-class=unboxed)
  219.        (,regnum:dynamic-link        . ,value-class=address)
  220.        (,regnum:address-mask        . ,value-class=immediate)
  221.        (,regnum:regs-pointer        . ,value-class=unboxed)
  222.        (,regnum:quad-bits           . ,value-class=immediate)
  223.        (,regnum:assembler-temp      . ,value-class=unboxed)
  224.        (,regnum:kernel-reserved-1   . ,value-class=unboxed)
  225.        (,regnum:kernel-reserved-2   . ,value-class=unboxed)
  226.        (,regnum:C-global-pointer    . ,value-class=unboxed)
  227.        (,regnum:C-stack-pointer     . ,value-class=unboxed)
  228.        (,regnum:linkage             . ,value-class=address))))
  229.     (lambda (register)
  230.       (let ((lookup (assv register special-registers)))
  231.     (cond
  232.      ((not (null? lookup)) (cdr lookup))
  233.      ((<= g0 register g31) value-class=word)
  234.      ((<= fp0 register fp31) value-class=float)
  235.      (else (error "illegal machine register" register)))))))
  236.  
  237. (define-integrable (machine-register-known-value register)
  238.   register                ;ignore
  239.   false)
  240.  
  241. ;;;; Interpreter Registers
  242.  
  243. (define-integrable (interpreter-free-pointer)
  244.   (rtl:make-machine-register regnum:free))
  245.  
  246. (define (interpreter-free-pointer? expression)
  247.   (and (rtl:register? expression)
  248.        (= (rtl:register-number expression) regnum:free)))
  249.  
  250. (define-integrable (interpreter-regs-pointer)
  251.   (rtl:make-machine-register regnum:regs-pointer))
  252.  
  253. (define (interpreter-regs-pointer? expression)
  254.   (and (rtl:register? expression)
  255.        (= (rtl:register-number expression) regnum:regs-pointer)))
  256.  
  257. (define-integrable (interpreter-value-register)
  258.   (rtl:make-machine-register regnum:return-value))
  259.  
  260. (define (interpreter-value-register? expression)
  261.   (and (rtl:register? expression)
  262.        (= (rtl:register-number expression) regnum:return-value)))
  263.  
  264. (define-integrable (interpreter-stack-pointer)
  265.   (rtl:make-machine-register regnum:stack-pointer))
  266.  
  267. (define (interpreter-stack-pointer? expression)
  268.   (and (rtl:register? expression)
  269.        (= (rtl:register-number expression) regnum:stack-pointer)))
  270.  
  271. (define-integrable (interpreter-dynamic-link)
  272.   (rtl:make-machine-register regnum:dynamic-link))
  273.  
  274. (define (interpreter-dynamic-link? expression)
  275.   (and (rtl:register? expression)
  276.        (= (rtl:register-number expression) regnum:dynamic-link)))
  277.  
  278. (define-integrable (interpreter-environment-register)
  279.   (rtl:make-offset (interpreter-regs-pointer)
  280.            (rtl:make-machine-constant 3)))
  281.  
  282. (define (interpreter-environment-register? expression)
  283.   (and (rtl:offset? expression)
  284.        (interpreter-regs-pointer? (rtl:offset-base expression))
  285.        (let ((offset (rtl:offset-offset expression)))
  286.      (and (rtl:machine-constant? offset)
  287.           (= 3 (rtl:machine-constant-value offset))))))
  288.  
  289. (define-integrable (interpreter-register:access)
  290.   (rtl:make-machine-register regnum:C-return-value))
  291.  
  292. (define-integrable (interpreter-register:cache-reference)
  293.   (rtl:make-machine-register regnum:C-return-value))
  294.  
  295. (define-integrable (interpreter-register:cache-unassigned?)
  296.   (rtl:make-machine-register regnum:C-return-value))
  297.  
  298. (define-integrable (interpreter-register:lookup)
  299.   (rtl:make-machine-register regnum:C-return-value))
  300.  
  301. (define-integrable (interpreter-register:unassigned?)
  302.   (rtl:make-machine-register regnum:C-return-value))
  303.  
  304. (define-integrable (interpreter-register:unbound?)
  305.   (rtl:make-machine-register regnum:C-return-value))
  306.  
  307. ;;;; RTL Registers, Constants, and Primitives
  308.  
  309. (define (rtl:machine-register? rtl-register)
  310.   (case rtl-register
  311.     ((STACK-POINTER)
  312.      (interpreter-stack-pointer))
  313.     ((DYNAMIC-LINK)
  314.      (interpreter-dynamic-link))
  315.     ((VALUE)
  316.      (interpreter-value-register))
  317.     ((MEMORY-TOP)
  318.      (rtl:make-machine-register regnum:memtop))
  319.     ((FREE)
  320.      (interpreter-free-pointer))
  321.     ((INTERPRETER-CALL-RESULT:ACCESS)
  322.      (interpreter-register:access))
  323.     ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
  324.      (interpreter-register:cache-reference))
  325.     ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
  326.      (interpreter-register:cache-unassigned?))
  327.     ((INTERPRETER-CALL-RESULT:LOOKUP)
  328.      (interpreter-register:lookup))
  329.     ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
  330.      (interpreter-register:unassigned?))
  331.     ((INTERPRETER-CALL-RESULT:UNBOUND?)
  332.      (interpreter-register:unbound?))
  333.     (else false)))
  334.  
  335. (define (rtl:interpreter-register? rtl-register)
  336.   (case rtl-register
  337.     ((INT-MASK) 1)
  338.     ((ENVIRONMENT) 3)
  339.     ((TEMPORARY) 4)
  340.     (else false)))
  341.  
  342. (define (rtl:interpreter-register->offset locative)
  343.   (or (rtl:interpreter-register? locative)
  344.       (error "Unknown register type" locative)))
  345.  
  346. (define (rtl:constant-cost expression)
  347.   ;; Magic numbers.
  348.   (let ((if-integer
  349.      (lambda (value)
  350.        (cond ((zero? value) 1)
  351.          ((or (fits-in-16-bits-signed? value)
  352.               (fits-in-16-bits-unsigned? value)
  353.               (top-16-bits-only? value))
  354.           2)
  355.          (else 3)))))
  356.     (let ((if-synthesized-constant
  357.        (lambda (type datum)
  358.          (if-integer (make-non-pointer-literal type datum)))))
  359.       (case (rtl:expression-type expression)
  360.     ((CONSTANT)
  361.      (let ((value (rtl:constant-value expression)))
  362.        (if (non-pointer-object? value)
  363.            (if-synthesized-constant (object-type value)
  364.                     (object-datum value))
  365.            3)))
  366.     ((MACHINE-CONSTANT)
  367.      (if-integer (rtl:machine-constant-value expression)))
  368.     ((ENTRY:PROCEDURE ENTRY:CONTINUATION
  369.       ASSIGNMENT-CACHE VARIABLE-CACHE
  370.       OFFSET-ADDRESS BYTE-OFFSET-ADDRESS FLOAT-OFFSET-ADDRESS)
  371.      3)
  372.     ((CONS-NON-POINTER)
  373.      (and (rtl:machine-constant? (rtl:cons-non-pointer-type expression))
  374.           (rtl:machine-constant? (rtl:cons-non-pointer-datum expression))
  375.           (if-synthesized-constant
  376.            (rtl:machine-constant-value
  377.         (rtl:cons-non-pointer-type expression))
  378.            (rtl:machine-constant-value
  379.         (rtl:cons-non-pointer-datum expression)))))
  380.     (else false)))))
  381.  
  382. (define compiler:open-code-floating-point-arithmetic?
  383.   true)
  384.  
  385. (define compiler:primitives-with-no-open-coding
  386.   '(DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER
  387.     INTEGER-QUOTIENT INTEGER-REMAINDER &/ QUOTIENT REMAINDER
  388.     FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS FLONUM-ATAN2
  389.     FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-REMAINDER FLONUM-SQRT
  390.     FLONUM-TRUNCATE FLONUM-ROUND FLONUM-CEILING FLONUM-FLOOR
  391.     VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS))