static.scm 6.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217
  1. ; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
  2. ; This little utility converts a heap image into a C file.
  3. ;
  4. ; For example:
  5. ; (do-it 100000 "~/s48/debug/little.image" "little-heap.c")
  6. ;
  7. ; The first argument to do-it should be somewhat larger than the size,
  8. ; in bytes, of the image file to be converted (which you can obtain with
  9. ; "ls -l").
  10. ;
  11. ; If the image contains 0-length stored objects, then the .c file will
  12. ; have to be compiled by gcc, since 0-length arrays aren't allowed in
  13. ; ANSI C. This wouldn't be difficult to work around.
  14. ;
  15. ; For loading instructions, see load-static.scm.
  16. (define *comments?* #f)
  17. ; 800,000 bytes => 200,000 words => at least 100,000 objects
  18. ; 50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk
  19. (define *chunk-size* 10000)
  20. (define (do-it bytes infile outfile)
  21. (let ((start (init bytes infile)))
  22. (call-with-output-file outfile
  23. (lambda (port)
  24. (format port "#define D(x) (long)(&x)+7~%")
  25. (format port "#define H unsigned long~%")
  26. (emit-area-declarations "p" immutable? "const " port)
  27. (emit-area-declarations "i" mutable? "" port)
  28. (emit-area-initializers "p" immutable? "const " port)
  29. (emit-area-initializers "i" mutable? "" port)
  30. (display "const long entry = " port)
  31. (emit-descriptor start port)
  32. (write-char #\; port)
  33. (newline port)))))
  34. (define (init bytes infile)
  35. (create-memory (quotient bytes 2) quiescent) ;Output of ls -l
  36. (initialize-heap (memory-begin) (memory-size))
  37. (let ((start (read-image infile 0)))
  38. (message (nchunks)
  39. " chunks")
  40. start))
  41. (define (nchunks) (+ (chunk-number (heap-pointer)) 1))
  42. ; emit struct declarations for areas
  43. (define (emit-area-declarations name in-area? const port)
  44. (for-each-stored-object
  45. (lambda (chunk)
  46. (message name chunk " declaration")
  47. (display "struct " port) (display name port) (display chunk port)
  48. (display " {" port) (newline port))
  49. (lambda (x)
  50. (if (in-area? x)
  51. (emit-declaration x port)))
  52. (lambda (chunk)
  53. (display "};" port)
  54. (newline port)
  55. (display const port)
  56. (display "extern struct " port) (display name port) (display chunk port)
  57. (write-char #\space port) (display name port) (display chunk port)
  58. (write-char #\; port) (newline port)
  59. chunk)))
  60. (define (emit-declaration x port)
  61. (display " H x" port)
  62. (writex x port)
  63. (cond ((d-vector? x)
  64. (display "; long d" port)
  65. (writex x port)
  66. (write-char #\[ port)
  67. (write (d-vector-length x) port))
  68. ((vm-string? x)
  69. (display "; char d" port)
  70. (writex x port)
  71. (write-char #\[ port)
  72. ;; Ensure alignment (thanks Ian)
  73. (write (cells->bytes (bytes->cells (b-vector-length x)))
  74. port))
  75. (else
  76. (display "; unsigned char d" port)
  77. (writex x port)
  78. (write-char #\[ port)
  79. ;; Ensure alignment
  80. (write (cells->bytes (bytes->cells (b-vector-length x)))
  81. port)))
  82. (display "];" port)
  83. (if *comments?*
  84. (begin (display " /* " port)
  85. (display (enumerand->name (stob-type x) stob) port)
  86. (display " */" port)))
  87. (newline port))
  88. ; Emit initializers for areas
  89. (define (emit-area-initializers name in-area? const port)
  90. (for-each-stored-object
  91. (lambda (chunk)
  92. (message name chunk " initializer")
  93. (display const port)
  94. (display "struct " port) (display name port) (write chunk port)
  95. (write-char #\space port) (display name port) (write chunk port)
  96. (display " =" port) (newline port)
  97. (write-char #\{ port) (newline port))
  98. (lambda (x)
  99. (if (in-area? x)
  100. (emit-initializer x port)))
  101. (lambda (chunk)
  102. (display "};" port) (newline port)))
  103. (let ((n (nchunks)))
  104. (format port "const long ~a_count = ~s;~%" name n)
  105. (format port "~a long * const ~a_areas[~s] = {" const name n)
  106. (do ((i 0 (+ i 1)))
  107. ((= i n))
  108. (format port "(~a long *)&~a~s, " const name i))
  109. (format port "};~%const long ~a_sizes[~s] = {" name n)
  110. (do ((i 0 (+ i 1)))
  111. ((= i n))
  112. (format port "sizeof(~a~s), " name i))
  113. (format port "};~%")))
  114. (define (message . stuff)
  115. (for-each display stuff) (newline))
  116. (define (emit-initializer x port)
  117. (display " " port)
  118. (write (stob-header x) port)
  119. (write-char #\, port)
  120. (cond ((d-vector? x)
  121. (emit-d-vector-initializer x port))
  122. ((vm-string? x)
  123. (write-char #\" port)
  124. (let ((len (vm-string-length x)))
  125. (do ((i 0 (+ i 1)))
  126. ((= i len) (write-char #\" port))
  127. (let ((c (vm-string-ref x i)))
  128. (cond ((or (char=? c #\") (char=? c #\\))
  129. (write-char #\\ port))
  130. ((char=? c #\newline)
  131. (display "\\n\\" port)))
  132. (write-char c port)))))
  133. (else
  134. (write-char #\{ port)
  135. (let ((len (b-vector-length x)))
  136. (do ((i 0 (+ i 1)))
  137. ((= i len) (write-char #\} port))
  138. (write (b-vector-ref x i) port)
  139. (write-char #\, port)))))
  140. (write-char #\, port)
  141. (if *comments?*
  142. (begin (display " /* " port)
  143. (writex x port)
  144. (display " */" port)))
  145. (newline port))
  146. (define (emit-d-vector-initializer x port)
  147. (write-char #\{ port)
  148. (let ((len (d-vector-length x)))
  149. (do ((i 0 (+ i 1)))
  150. ((= i len) (write-char #\} port))
  151. (emit-descriptor (d-vector-ref x i) port)
  152. (write-char #\, port))))
  153. (define (emit-descriptor x port)
  154. (if (stob? x)
  155. (begin (if (immutable? x)
  156. (display "D(p" port)
  157. (display "D(i" port))
  158. (display (chunk-number x) port)
  159. (display ".x" port)
  160. (writex x port)
  161. (write-char #\) port))
  162. (write x port)))
  163. ; Foo
  164. (define (writex x port)
  165. (write (quotient (- (- x (memory-begin)) 7) 4) port))
  166. (define (chunk-number x)
  167. (quotient (- (- x (memory-begin)) 7) *chunk-size*))
  168. ; Image traversal utility
  169. (define (for-each-stored-object chunk-start proc chunk-end)
  170. (let ((limit (heap-pointer)))
  171. (let chunk-loop ((addr (newspace-begin))
  172. (i 0)
  173. (chunk (+ (newspace-begin) *chunk-size*)))
  174. (if (addr< addr limit)
  175. (begin (chunk-start i)
  176. (let loop ((addr addr))
  177. (if (and (addr< addr limit)
  178. (addr< addr chunk))
  179. (let ((d (fetch addr)))
  180. (if (not (header? d))
  181. (warn "heap is in an inconsistent state" d))
  182. (proc (address->stob-descriptor (addr1+ addr)))
  183. (loop (addr1+ (addr+ addr (header-a-units d)))))
  184. (begin (chunk-end i)
  185. (chunk-loop addr
  186. (+ i 1)
  187. (+ chunk *chunk-size*))))))))))
  188. (define (mutable? x) (not (immutable? x)))