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 / spectrum / machin.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  13.1 KB  |  409 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: machin.scm,v 4.30 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 Spectrum
  23. ;;; package: (compiler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Architecture Parameters
  28.  
  29. (define use-pre/post-increment? true)
  30. (define-integrable 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.  
  35. ;; NOTE: expt is not being constant-folded now.
  36. ;; For the time being, some of the parameters below are
  37. ;; pre-computed and marked with ***
  38. ;; There are similar parameters in lapgen.scm
  39. ;; Change them if any of the parameters above do.
  40.  
  41. (define-integrable scheme-datum-width
  42.   (- scheme-object-width scheme-type-width))
  43.  
  44. (define-integrable type-scale-factor
  45.   ;; (expt 2 (- 8 scheme-type-width)) ***
  46.   4)
  47.  
  48. (define-integrable float-width 64)
  49. (define-integrable float-alignment 64)
  50.  
  51. (define-integrable address-units-per-float
  52.   (quotient float-width addressing-granularity))
  53.  
  54. ;;; It is currently required that both packed characters and objects
  55. ;;; be integrable numbers of address units.  Furthermore, the number
  56. ;;; of address units per object must be an integral multiple of the
  57. ;;; number of address units per character.  This will cause problems
  58. ;;; on a machine that is word addressed: we will have to rethink the
  59. ;;; character addressing strategy.
  60.  
  61. (define-integrable address-units-per-object
  62.   (quotient scheme-object-width addressing-granularity))
  63.  
  64. (define-integrable address-units-per-packed-char 1)
  65.  
  66. (define-integrable signed-fixnum/upper-limit
  67.   ;; (expt 2 (-1+ scheme-datum-width)) ***
  68.   33554432)
  69.  
  70. (define-integrable signed-fixnum/lower-limit
  71.   (- signed-fixnum/upper-limit))
  72.  
  73. (define-integrable unsigned-fixnum/upper-limit
  74.   (* 2 signed-fixnum/upper-limit))
  75.  
  76. (define-integrable (stack->memory-offset offset) offset)
  77. (define-integrable ic-block-first-parameter-offset 2)
  78. (define-integrable execute-cache-size 3) ; Long words per UUO link slot
  79.  
  80. ;;;; Closures and multi-closures
  81.  
  82. ;; On the 68k, to save space, entries can be at 2 mod 4 addresses,
  83. ;; which makes it impossible to use an arbitrary closure entry-point
  84. ;; to reference closed-over variables since the compiler only uses
  85. ;; long-word offsets.  Instead, all closure entry points are bumped
  86. ;; back to the first entry point, which is always long-word aligned.
  87.  
  88. ;; On the HP-PA, and all other RISCs, all the entry points are
  89. ;; long-word aligned, so there is no need to bump back to the first
  90. ;; entry point.
  91.  
  92. (define-integrable closure-entry-size
  93.   #|
  94.      Long words in a single closure entry:
  95.        GC offset word
  96.        LDIL    L'target,26
  97.        BLE    R'target(5,26)
  98.        ADDI    -12,31,31
  99.    |#
  100.   4)
  101.  
  102. ;; Given: the number of entry points in a closure, and a particular
  103. ;; entry point number, compute the distance from that entry point to
  104. ;; the first variable slot in the closure object (in long words).
  105.  
  106. (define (closure-first-offset nentries entry)
  107.   (if (zero? nentries)
  108.       1                    ; Strange boundary case
  109.       (- (* closure-entry-size (- nentries entry)) 1)))
  110.  
  111. ;; Like the above, but from the start of the complete closure object,
  112. ;; viewed as a vector, and including the header word.
  113.  
  114. (define (closure-object-first-offset nentries)
  115.   (case nentries
  116.     ((0)
  117.      ;; Vector header only
  118.      1)
  119.     ((1)
  120.      ;; Manifest closure header followed by single entry point
  121.      (+ 1 closure-entry-size))
  122.     (else
  123.      ;; Manifest closure header, number of entries, then entries.
  124.      (+ 1 1 (* closure-entry-size nentries)))))
  125.  
  126. ;; Bump distance in bytes from one entry point to another.
  127. ;; Used for invocation purposes.
  128.  
  129. (define (closure-entry-distance nentries entry entry*)
  130.   nentries                ; ignored
  131.   (* (* closure-entry-size 4) (- entry* entry)))
  132.  
  133. ;; Bump distance in bytes from one entry point to the entry point used
  134. ;; for variable-reference purposes.
  135. ;; On a RISC, this is the entry point itself.
  136.  
  137. (define (closure-environment-adjustment nentries entry)
  138.   nentries entry            ; ignored
  139.   0)
  140.  
  141. ;;;; Machine Registers
  142.  
  143. (define-integrable g0 0)
  144. (define-integrable g1 1)
  145. (define-integrable g2 2)
  146. (define-integrable g3 3)
  147. (define-integrable g4 4)
  148. (define-integrable g5 5)
  149. (define-integrable g6 6)
  150. (define-integrable g7 7)
  151. (define-integrable g8 8)
  152. (define-integrable g9 9)
  153. (define-integrable g10 10)
  154. (define-integrable g11 11)
  155. (define-integrable g12 12)
  156. (define-integrable g13 13)
  157. (define-integrable g14 14)
  158. (define-integrable g15 15)
  159. (define-integrable g16 16)
  160. (define-integrable g17 17)
  161. (define-integrable g18 18)
  162. (define-integrable g19 19)
  163. (define-integrable g20 20)
  164. (define-integrable g21 21)
  165. (define-integrable g22 22)
  166. (define-integrable g23 23)
  167. (define-integrable g24 24)
  168. (define-integrable g25 25)
  169. (define-integrable g26 26)
  170. (define-integrable g27 27)
  171. (define-integrable g28 28)
  172. (define-integrable g29 29)
  173. (define-integrable g30 30)
  174. (define-integrable g31 31)
  175.  
  176. ;; fp0 - fp3 are status registers.  The rest are real registers
  177. (define-integrable fp0 32)
  178. (define-integrable fp1 33)
  179. (define-integrable fp2 34)
  180. (define-integrable fp3 35)
  181. (define-integrable fp4 36)
  182. (define-integrable fp5 37)
  183. (define-integrable fp6 38)
  184. (define-integrable fp7 39)
  185. (define-integrable fp8 40)
  186. (define-integrable fp9 41)
  187. (define-integrable fp10 42)
  188. (define-integrable fp11 43)
  189. (define-integrable fp12 44)
  190. (define-integrable fp13 45)
  191. (define-integrable fp14 46)
  192. (define-integrable fp15 47)
  193.  
  194. ;; The following registers are available only on the newer processors
  195. (define-integrable fp16 48)
  196. (define-integrable fp17 49)
  197. (define-integrable fp18 50)
  198. (define-integrable fp19 51)
  199. (define-integrable fp20 52)
  200. (define-integrable fp21 53)
  201. (define-integrable fp22 54)
  202. (define-integrable fp23 55)
  203. (define-integrable fp24 56)
  204. (define-integrable fp25 57)
  205. (define-integrable fp26 58)
  206. (define-integrable fp27 59)
  207. (define-integrable fp28 60)
  208. (define-integrable fp29 61)
  209. (define-integrable fp30 62)
  210. (define-integrable fp31 63)
  211.  
  212. (define-integrable number-of-machine-registers 64)
  213. (define-integrable number-of-temporary-registers 256)
  214.  
  215. ;;; Fixed-use registers for Scheme compiled code.
  216. (define-integrable regnum:return-value g2)
  217. (define-integrable regnum:scheme-to-interface-ble g3)
  218. (define-integrable regnum:regs-pointer g4)
  219. (define-integrable regnum:quad-bitmask g5)
  220. (define-integrable regnum:dynamic-link g19)
  221. (define-integrable regnum:memtop-pointer g20)
  222. (define-integrable regnum:free-pointer g21)
  223. (define-integrable regnum:stack-pointer g22)
  224.  
  225. ;;; Fixed-use registers due to architecture or OS calling conventions.
  226. (define-integrable regnum:zero g0)
  227. (define-integrable regnum:addil-result g1)
  228. (define-integrable regnum:C-global-pointer g27)
  229. (define-integrable regnum:C-return-value g28)
  230. (define-integrable regnum:C-stack-pointer g30)
  231. (define-integrable regnum:ble-return g31)
  232. (define-integrable regnum:fourth-arg g23)
  233. (define-integrable regnum:third-arg g24)
  234. (define-integrable regnum:second-arg g25)
  235. (define-integrable regnum:first-arg g26)
  236.  
  237. (define (machine-register-value-class register)
  238.   (cond ((or (= register 0)
  239.          (<= 6 register 18)
  240.          (<= 23 register 26)
  241.          (= register 29)
  242.          (= register 31))
  243.      value-class=word)
  244.     ((or (= register 2) (= register 28))
  245.      value-class=object)
  246.     ((or (= register 1) (= register 3))
  247.      value-class=unboxed)
  248.     ((or (= register 4)
  249.          (<= 19 register 22)
  250.          (= register 27)
  251.          (= register 30))
  252.      value-class=address)
  253.     ((= register 5)
  254.      value-class=immediate)
  255.     ((<= 32 register 63)
  256.      value-class=float)
  257.     (else
  258.      (error "illegal machine register" register))))
  259.  
  260. (define-integrable (machine-register-known-value register)
  261.   register                ;ignore
  262.   false)
  263.  
  264. ;;;; Interpreter Registers
  265.  
  266. (define-integrable (interpreter-free-pointer)
  267.   (rtl:make-machine-register regnum:free-pointer))
  268.  
  269. (define (interpreter-free-pointer? expression)
  270.   (and (rtl:register? expression)
  271.        (= (rtl:register-number expression) regnum:free-pointer)))
  272.  
  273. (define-integrable (interpreter-regs-pointer)
  274.   (rtl:make-machine-register regnum:regs-pointer))
  275.  
  276. (define (interpreter-regs-pointer? expression)
  277.   (and (rtl:register? expression)
  278.        (= (rtl:register-number expression) regnum:regs-pointer)))
  279.  
  280. (define-integrable (interpreter-value-register)
  281.   (rtl:make-machine-register regnum:return-value))
  282.  
  283. (define (interpreter-value-register? expression)
  284.   (and (rtl:register? expression)
  285.        (= (rtl:register-number expression) regnum:return-value)))
  286.  
  287. (define-integrable (interpreter-stack-pointer)
  288.   (rtl:make-machine-register regnum:stack-pointer))
  289.  
  290. (define (interpreter-stack-pointer? expression)
  291.   (and (rtl:register? expression)
  292.        (= (rtl:register-number expression) regnum:stack-pointer)))
  293.  
  294. (define-integrable (interpreter-dynamic-link)
  295.   (rtl:make-machine-register regnum:dynamic-link))
  296.  
  297. (define (interpreter-dynamic-link? expression)
  298.   (and (rtl:register? expression)
  299.        (= (rtl:register-number expression) regnum:dynamic-link)))
  300.  
  301. (define-integrable (interpreter-environment-register)
  302.   (rtl:make-offset (interpreter-regs-pointer)
  303.            (rtl:make-machine-constant 3)))
  304.  
  305. (define (interpreter-environment-register? expression)
  306.   (and (rtl:offset? expression)
  307.        (interpreter-regs-pointer? (rtl:offset-base expression))
  308.        (let ((offset (rtl:offset-offset expression)))
  309.      (and (rtl:machine-constant? offset)
  310.           (= 3 (rtl:machine-constant-value offset))))))
  311.  
  312. (define-integrable (interpreter-register:access)
  313.   (rtl:make-machine-register g28))
  314.  
  315. (define-integrable (interpreter-register:cache-reference)
  316.   (rtl:make-machine-register g28))
  317.  
  318. (define-integrable (interpreter-register:cache-unassigned?)
  319.   (rtl:make-machine-register g28))
  320.  
  321. (define-integrable (interpreter-register:lookup)
  322.   (rtl:make-machine-register g28))
  323.  
  324. (define-integrable (interpreter-register:unassigned?)
  325.   (rtl:make-machine-register g28))
  326.  
  327. (define-integrable (interpreter-register:unbound?)
  328.   (rtl:make-machine-register g28))
  329.  
  330. ;;;; RTL Registers, Constants, and Primitives
  331.  
  332. (define (rtl:machine-register? rtl-register)
  333.   (case rtl-register
  334.     ((STACK-POINTER)
  335.      (interpreter-stack-pointer))
  336.     ((DYNAMIC-LINK)
  337.      (interpreter-dynamic-link))
  338.     ((VALUE)
  339.      (interpreter-value-register))
  340.     ((FREE)
  341.      (interpreter-free-pointer))
  342.     ((MEMORY-TOP)
  343.      (rtl:make-machine-register regnum:memtop-pointer))
  344.     ((INTERPRETER-CALL-RESULT:ACCESS)
  345.      (interpreter-register:access))
  346.     ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
  347.      (interpreter-register:cache-reference))
  348.     ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
  349.      (interpreter-register:cache-unassigned?))
  350.     ((INTERPRETER-CALL-RESULT:LOOKUP)
  351.      (interpreter-register:lookup))
  352.     ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
  353.      (interpreter-register:unassigned?))
  354.     ((INTERPRETER-CALL-RESULT:UNBOUND?)
  355.      (interpreter-register:unbound?))
  356.     (else false)))
  357.  
  358. (define (rtl:interpreter-register? rtl-register)
  359.   (case rtl-register
  360.     ((INT-MASK) 1)
  361.     ((ENVIRONMENT) 3)
  362.     ((TEMPORARY) 4)
  363.     (else false)))
  364.  
  365. (define (rtl:interpreter-register->offset locative)
  366.   (or (rtl:interpreter-register? locative)
  367.       (error "Unknown register type" locative)))
  368.  
  369. (define (rtl:constant-cost expression)
  370.   ;; Magic numbers.
  371.   (let ((if-integer
  372.      (lambda (value)
  373.        (cond ((zero? value) 1)
  374.          ((fits-in-5-bits-signed? value) 2)
  375.          (else 3)))))
  376.     (let ((if-synthesized-constant
  377.        (lambda (type datum)
  378.          (if-integer (make-non-pointer-literal type datum)))))
  379.       (case (rtl:expression-type expression)
  380.     ((CONSTANT)
  381.      (let ((value (rtl:constant-value expression)))
  382.        (if (non-pointer-object? value)
  383.            (if-synthesized-constant (object-type value)
  384.                     (object-datum value))
  385.            3)))
  386.     ((MACHINE-CONSTANT)
  387.      (if-integer (rtl:machine-constant-value expression)))
  388.     ((ENTRY:PROCEDURE
  389.       ENTRY:CONTINUATION
  390.       ASSIGNMENT-CACHE
  391.       VARIABLE-CACHE
  392.       OFFSET-ADDRESS
  393.       BYTE-OFFSET-ADDRESS
  394.       FLOAT-OFFSET-ADDRESS)
  395.      3)
  396.     ((CONS-POINTER)
  397.      (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
  398.           (rtl:machine-constant? (rtl:cons-pointer-datum expression))
  399.           (if-synthesized-constant
  400.            (rtl:machine-constant-value (rtl:cons-pointer-type expression))
  401.            (rtl:machine-constant-value
  402.         (rtl:cons-pointer-datum expression)))))
  403.     (else false)))))
  404.  
  405. (define compiler:open-code-floating-point-arithmetic?
  406.   true)
  407.  
  408. (define compiler:primitives-with-no-open-coding
  409.   '(DIVIDE-FIXNUM GCD-FIXNUM &/))