;;; Package for Static heaps for the Scheme Shell
;;; Copyright (c) 1995 by Brian D. Carlstrom. See file COPYING.

;;; based on Scheme48 implementation.
;;; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; prefix for temp files - in their own dir
(define *temp-dir*   "/tmp")

(define (test) 
  (scsh-do-it *scsh-image* *temp-dir* *image-lib* "gcc -c" "ar cq"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record heap
  (length    0)
  (objects '())
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (scsh-do-it infile tempdir outfile cc-command ar-command)
  (let* ((temp-dir (format #f "~a/scsh~s" tempdir (pid)))
	 (prefix (string-append temp-dir "/static"))
	 (start (read-heap-image infile)))
    (receive (pure impure reloc externs)
	(create-heaps-and-tables)
      (if (file-exists? temp-dir)
	  (if (file-directory? temp-dir)
	      (with-cwd temp-dir
			(map delete-file (directory-files temp-dir #t)))
	      (delete-file temp-dir)))
      (create-directory temp-dir #o755 #t)
      (with-cwd temp-dir
		(write-c-header-file pure impure externs infile outfile prefix)
		(write-c-image pure impure reloc externs prefix)
		(write-main-c-file start reloc prefix)
		(compile-c-files cc-command prefix))
      (archive-files ar-command outfile prefix)
      )))


(define debug #f)

(define (vm-string->string x)
  (cond ((vm-string? x)
	 (let ((len (vm-string-length x)))
	   (let loop ((i 0) 
		      (l '()))
	     (cond ((= i len) 
		    (list->string (reverse l)))
		   (else
		    (loop (+ i 1) (cons (vm-string-ref x i) l)))))))
	(else
	 (message x " is not a vm-string"))))

(define (read-heap-image infile)
  (let ((bytes (file-info:size (file-info infile))))
    (init (inexact->exact (floor (* 1.1 bytes))) infile)))
; XXX need little extra space for find-all-xs

(define (create-heaps-and-tables)
  (let* ((n       (nchunks))
	 (  pure  (make-vector n))
	 (impure  (make-vector n))
	 (reloc   (make-vector n))
	 (externs (make-table   )))
    ;; initialize to blanks
    (let loop ((i 0))
      (cond ((not (= i n))
	     (vector-set!   pure i (make-heap ))
	     (vector-set! impure i (make-heap ))
	     (vector-set!  reloc i (make-table))
	     (loop (+ i 1)))))
    (scsh-for-each-stored-object
     (lambda (chunk)
       (format #t "Reading chunk number ~s" chunk))
     (lambda (chunk x len)
       (if debug
	   (write x))
       (let* ((mutable (mutable? x))
	      (heap (vector-ref (if mutable impure pure) chunk)))
	 (table-set! (vector-ref reloc chunk) x (heap:length heap))
	 (set-heap:objects heap (cons x (heap:objects heap)))
	 (set-heap:length  heap (+ len  (heap:length  heap)))
	 (cond (debug
		(display (if mutable "   mutable " " immutable "))
		(cond ((d-vector? x)  (display " d-vector"))
		      ((vm-string? x) (display "vm-string"))
		      (else           (display " b-vector")))
		(let ((m (heap:length (vector-ref impure chunk)))
		      (i (heap:length (vector-ref   pure chunk))))
		  (message " m" m "+i" i "=" (+ m i))))))
       (if (= (header-type (stob-header x)) (enum stob external))
	   (table-set! externs 
		       (external-value x) 
		       (vm-string->string (external-name x))))
       )
     (lambda (chunk) 
       (newline)))
    (let loop ((i 0))
      (cond ((not (= i n))
	     (let ((p (vector-ref   pure i))
		   (i (vector-ref impure i)))
	       (set-heap:objects p (reverse (heap:objects p)))
	       (set-heap:objects i (reverse (heap:objects i))))
	     (loop (+ i 1)))))
    (values pure impure reloc externs)))

(define (write-c-header-file pure impure externs infile outfile prefix)
  (message "Writing header file")
  (call-with-output-file (string-append prefix ".h")
    (lambda (port)
      (format port "/* Static Heap File Automatically Generated~%")
      (format port " * by   scsh/static.scm~%")
      (format port " * from ~a~%" infile)
      (format port " * to   ~a~%" outfile)
      (format port " */~%")
      (let ((n (nchunks)))
	(do ((i 0 (+ i 1)))
	    ((= i n))
	  (format port "extern const long p~s[~s];~%" i 
		  (quotient (heap:length (vector-ref   pure i)) 4)))
	(do ((i 0 (+ i 1)))
	    ((= i n))
	  (format port "extern long i~s[~s];~%" i
		  (quotient (heap:length (vector-ref impure i)) 4))))
      (table-walk
       (lambda (address name)
	 (format port "const extern ~a();~%" name))
       externs)
      )))

(define (d-vector-for-each proc d-vector)
  (do ((i 0 (+ i 1)))
      ((>= i (d-vector-length d-vector)))
    (proc (d-vector-ref d-vector i))))

(define (write-c-image pure impure reloc externs prefix)
  (message "Writing   pure c files")
  (scsh-write-c-image   pure "p" "const " reloc externs prefix)
  (message "Writing impure c files")
  (scsh-write-c-image impure "i" ""       reloc externs prefix))

(define (scsh-write-c-image heap name const reloc externs prefix)
  (let ((n (nchunks)))
    (let chunk-loop ((c 0))
      (cond ((not (= c n))
	     (format #t "Writing ~a-~a~s.c~%" prefix name c)
	     (call-with-output-file 
		 (format #f "~a-~a~s.c" prefix name c)
	       (lambda (port)	     
		 (format port "#include \"~a.h\"~%" prefix)
		 (format port "~a long ~a~s[]={~%" const name c)
		 (let ((heap (vector-ref heap c)))
		   (let heap-loop ((l (heap:objects heap)))
		     (cond ((not (null? l))
			    (scsh-emit-initializer (car l) reloc externs port)
			    (heap-loop (cdr l))))))
		 (display "};" port)
		 (newline port)))
	     (chunk-loop (+ 1 c)))))))

(define (write-main-c-file start reloc prefix)
  (let ((n (nchunks)))
    (call-with-output-file (string-append prefix ".c")
      (lambda (port)
	(format port "#include \"~a.h\"~%" prefix)
	(format port "const long p_count = ~s;~%" n)
	(format port "const long i_count = ~s;~%" n)
	    
	(format port "const long * const p_areas[~s] = {" n)
	(do ((i 0 (+ i 1)))
	    ((= i n))
	  (format port "(const long *) &p~s, " i))
	(format port "};~%")

	(format port "long * const i_areas[~s] = {" n)
	(do ((i 0 (+ i 1)))
	    ((= i n))
	  (format port "(long *) &i~s, " i))
	(format port "};~%")

	(format port "const long p_sizes[~s] = {" n)
	(do ((i 0 (+ i 1)))
	    ((= i n))
	  (format port "sizeof(p~s), " i))
	(format port "};~%")

	(format port "const long i_sizes[~s] = {" n)
	(do ((i 0 (+ i 1)))
	    ((= i n))
	  (format port "sizeof(i~s), " i))
	(format port "};~%")

	(display "const long entry = " port)
	(scsh-emit-descriptor start reloc port)
	(write-char #\; port)
	(newline port)))))

(define (compile-c-files cc-command prefix)
  (let ((n (nchunks))
	(cc (line->list cc-command)))
    (message "Compiling main C file")
    (run (,@(append cc (list (format #f "~a.c" prefix)))))
    (do ((i 0 (+ i 1)))
	((= i n))
      (message "Compiling C file for   pure chunk " i)
      (run (,@(append cc 
		      (list (format #f "~a-p~s.c" prefix i)))))
      (message "Compiling C file for impure chunk " i)
      (run (,@(append cc 
		      (list (format #f "~a-i~s.c" prefix i))))))))

(define (archive-files ar-command outfile prefix)
  (let ((n (nchunks))
	(ar (line->list ar-command)))
    (message "Archiving object files")
    (run (,@(append 
	     ar
	     (cons 
	      outfile
	      (let loop ((i 0)
			 (l '()))
		(cond ((not (= i n))
		       (loop (+ i 1)
			     (cons 
			      (format #f "~a-i~s.o" prefix i)
			      (cons
			       (format #f "~a-p~s.o" prefix i)
			       l))))
		      (else 
		       (reverse 		
			(cons 
			 (string-append prefix ".o")
			 l)))))))))))

(define (scsh-emit-initializer x reloc externs port)
  (write-hex port (stob-header x))
  (cond ((d-vector? x)
	 (scsh-emit-d-vector-initializer x reloc port))
	((vm-string? x)
	 (scsh-emit-vm-string-initializer x port))
	(else
	 (scsh-emit-b-vector-initializer x reloc externs port)))
  (if *comments?*
      (begin (display " /* " port)
	     (writex x port)
	     (display " */" port)))
  (newline port))


(define (scsh-emit-d-vector-initializer x reloc port)
  (let ((len (d-vector-length x)))
    (do ((i 0 (+ i 1)))
	((= i len))
      (scsh-emit-descriptor (d-vector-ref x i) reloc port)
      (write-char #\, port))))

(define (scsh-emit-vm-string-initializer x port)
  (let* ((len (vm-string-length x))	; end is jawilson style hack
	 (end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
    (do ((i 0 (+ i 4)))
	((= i end) 
	 (case (- len end)
	   ((0)
	    (write-hex port 0))
	   ((1)
	    (write-hex
	     port
	     (net-to-host-32 (arithmetic-shift 
		     (char->ascii (vm-string-ref x i)) 24))))
	   ((2)
	    (write-hex 
	     port
	     (net-to-host-32 
	      (bitwise-ior
	       (arithmetic-shift
		(char->ascii (vm-string-ref x i))       24)
	       (arithmetic-shift
		(char->ascii (vm-string-ref x (+ i 1))) 16)))))
	   ((3)
	    (write-hex
	     port
	     (net-to-host-32
	      (bitwise-ior
	       (bitwise-ior
		(arithmetic-shift 
		 (char->ascii (vm-string-ref x i))       24)
		(arithmetic-shift 
		 (char->ascii (vm-string-ref x (+ i 1))) 16))
	       (arithmetic-shift  
		(char->ascii (vm-string-ref x (+ i 2)))  8)))))))
      (write-hex port
		 (net-to-host-32 (bitwise-ior
			 (bitwise-ior
			  (arithmetic-shift 
			   (char->ascii (vm-string-ref x i))       24)
			  (arithmetic-shift 
			   (char->ascii (vm-string-ref x (+ i 1))) 16))
			 (bitwise-ior
			  (arithmetic-shift 
			   (char->ascii (vm-string-ref x (+ i 2)))  8)
			  (char->ascii  (vm-string-ref x (+ i 3))))))
		 ))))

(define (scsh-emit-b-vector-initializer x reloc externs port)
  (cond ((and (code-vector? x)
	      (table-ref externs x)) =>
	      (lambda (name)
		(format port "(long) *~a," name)))
	(else 
	 (let* ((len (b-vector-length x)) ;end is jawilson style hack
		(end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
	   (do ((i 0 (+ i 4)))
	       ((= i end)
		(case (- len end)
		  ((1)
		   (write-hex
		    port
		    (net-to-host-32 (arithmetic-shift (b-vector-ref x i) 24))))
		  ((2)
		   (write-hex 
		    port
		    (net-to-host-32
		     (bitwise-ior
		      (arithmetic-shift (b-vector-ref x i)       24)
		      (arithmetic-shift (b-vector-ref x (+ i 1)) 16)))))
		  ((3)
		   (write-hex
		    port
		    (net-to-host-32
		     (bitwise-ior
		      (bitwise-ior
		       (arithmetic-shift (b-vector-ref x i)       24)
		       (arithmetic-shift (b-vector-ref x (+ i 1)) 16))
		      (arithmetic-shift  (b-vector-ref x (+ i 2))  8)))
		    ))))
	     (write-hex 
	      port
	      (net-to-host-32 (bitwise-ior
		      (bitwise-ior
		       (arithmetic-shift (b-vector-ref x i)       24)
		       (arithmetic-shift (b-vector-ref x (+ i 1)) 16))
		      (bitwise-ior
		       (arithmetic-shift (b-vector-ref x (+ i 2))  8)
		       (b-vector-ref x (+ i 3))))))))
	 )))

(define (scsh-emit-descriptor x reloc port)
  (if (stob? x)
      (let ((n (chunk-number x)))
	(display "(long)(&" port)
	(if (immutable? x)
	    (display "p" port)
	    (display "i" port))
	(display n port)
	(display "[" port)
	(display (quotient (table-ref (vector-ref reloc n) x) 4) port)
	(display "])+7" port))
      (format port 
	      (if (negative? x) "-0x~a" "0x~a")
	      (number->string (abs x) 16))))

(define (scsh-for-each-stored-object chunk-start proc chunk-end)
  (let ((limit (heap-pointer)))
    (let chunk-loop ((addr (newspace-begin))
		     (i 0)
		     (chunk (+ (newspace-begin) *chunk-size*)))
      (if (addr< addr limit)
	  (begin (chunk-start i)
		 (let loop ((addr addr))
		   (if (and (addr< addr limit)
			    (addr< addr chunk))
		       (let* ((d   (fetch addr))
			      (len (addr1+ (header-a-units d))))
			 (if (not (header? d))
			     (warn "heap is in an inconsistent state" d))
			 (proc i (address->stob-descriptor (addr1+ addr)) len)
			 (loop (addr+ addr len)))
		       (begin (chunk-end i)
			      (chunk-loop addr
					  (+ i 1)
					  (+ chunk *chunk-size*))))))))))

(define (write-hex port x) 
  (format port 
	  (if (negative? x) "-0x~a," "0x~a,")
	  (number->string (abs x) 16)))

;; takes a string and break it into a list at whitespace
;; rewrite using scsh stuff?
(define (line->list line)
  (let ((len (string-length line)))
    (let loop ((start 0)
	       (end 0)
	       (l '()))
      (cond ((>= end len)
	     (if (= start end)
		 l
		 (append l (list (substring line start end)))))
	    ((and (= start end)
		  (or (char=? (string-ref line start) (ascii->char 32))
		      (char=? (string-ref line start) (ascii->char 9))))
	     (loop (+ 1 start) 
		   (+ 1 end) 
		   l))
	    ((or (char=? (string-ref line end) (ascii->char 32))
		 (char=? (string-ref line end) (ascii->char 9)))
	     (loop (+ 1 end) 
		   (+ 1 end) 
		   (append l (list (substring line start end)))))
	    ((< end len)
	     (loop start 
		   (+ 1 end)
		   l))
	    (else (error "unexpected case in line->list"))))))

;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; Debugging
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

(define (bin n)
  (number->string n 2))

(define (oct n)
  (number->string n 8))

(define (dec n)
  (number->string n 10))

(define (hex n)
  (number->string n 16))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; For example:
;   (do-it 100000 "~/s48/debug/little.image" "little-heap.c")
;
; The first argument to do-it should be somewhat larger than the size,
; in bytes, of the image file to be converted (which you can obtain with
; "ls -l").
;
; If the image contains 0-length stored objects, then the .c file will
; have to be compiled by gcc, since 0-length arrays aren't allowed in
; ANSI C.  This wouldn't be difficult to work around.

(define *comments?* #f)

; 800,000 bytes => 200,000 words => at least 100,000 objects
;   50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk
(define *chunk-size* 10000)

(define (do-it bytes infile outfile)
  (let ((start (init bytes infile)))
    (call-with-output-file outfile
      (lambda (port)
	(format port "#define D(x) (long)(&x)+7~%")
	(format port "#define H unsigned long~%")
	(emit-area-declarations "p" immutable? "const " port)
	(emit-area-declarations "i" mutable? "" port)
	(emit-area-initializers "p" immutable? "const " port)
	(emit-area-initializers "i" mutable? "" port)
	(display "const long entry = " port)
	(emit-descriptor start port)
	(write-char #\; port)
	(newline port)))))

(define (init bytes infile)
  (create-memory (quotient bytes 2) quiescent) ;Output of ls -l
  (initialize-heap (memory-begin) (memory-size))
  (let ((start (read-image infile 0)))
    (message (nchunks)
	     " chunks")
    start))

(define (nchunks) (+ (chunk-number (heap-pointer)) 1))

; emit struct declarations for areas

(define (emit-area-declarations name in-area? const port)
  (for-each-stored-object
   (lambda (chunk)
     (message name chunk " declaration")
     (display "struct " port) (display name port) (display chunk port)
     (display " {" port) (newline port))
   (lambda (x)
     (if (in-area? x)
	 (emit-declaration x port)))
   (lambda (chunk)
     (display "};" port)
     (newline port)
     (display const port)
     (display "extern struct " port) (display name port) (display chunk port)
     (write-char #\space port) (display name port) (display chunk port)
     (write-char #\; port) (newline port)
     chunk)))

(define (emit-declaration x port)
  (display "  H x" port)
  (writex x port)
  (cond ((d-vector? x)
	 (display "; long d" port)
	 (writex x port)
	 (write-char #\[ port)
	 (write (d-vector-length x) port))
	((vm-string? x)
	 (display "; char d" port)
	 (writex x port)
	 (write-char #\[ port)
	 ;; Ensure alignment (thanks Ian)
	 (write (cells->bytes (bytes->cells (b-vector-length x)))
		port))
	(else
	 (display "; unsigned char d" port)
	 (writex x port)
	 (write-char #\[ port)
	 ;; Ensure alignment
	 (write (cells->bytes (bytes->cells (b-vector-length x)))
		port)))
  (display "];" port)
  (if *comments?*
      (begin (display " /* " port)
	     (display (enumerand->name (stob-type x) stob) port)
	     (display " */" port)))
  (newline port))

; Emit initializers for areas

(define (emit-area-initializers name in-area? const port)
  (for-each-stored-object
   (lambda (chunk)
     (message name chunk " initializer")

     (display const port)
     (display "struct " port) (display name port) (write chunk port)
     (write-char #\space port) (display name port) (write chunk port)
     (display " =" port) (newline port)

     (write-char #\{ port) (newline port))
   (lambda (x)
     (if (in-area? x)
	 (emit-initializer x port)))
   (lambda (chunk)
     (display "};" port) (newline port)))

  (let ((n (nchunks)))
    (format port "const long ~a_count = ~s;~%" name n)
    (format port "~a long * const ~a_areas[~s] = {" const name n)
    (do ((i 0 (+ i 1)))
	((= i n))
      (format port "(~a long *)&~a~s, " const name i))
    (format port "};~%const long ~a_sizes[~s] = {" name n)
    (do ((i 0 (+ i 1)))
	((= i n))
      (format port "sizeof(~a~s), " name i))
    (format port "};~%")))


(define (message . stuff)
  (for-each display stuff) (newline))

(define (emit-initializer x port)
  (display "  " port)
  (write (stob-header x) port)
  (write-char #\, port)
  (cond ((d-vector? x)
	 (emit-d-vector-initializer x port))
	((vm-string? x)
	 (write-char #\" port)
	 (let ((len (vm-string-length x)))
	   (do ((i 0 (+ i 1)))
	       ((= i len) (write-char #\" port))
	     (let ((c (vm-string-ref x i)))
	       (cond ((or (char=? c #\") (char=? c #\\))
		      (write-char #\\ port))
		     ((char=? c #\newline)
		      (display "\\n\\" port)))
	       (write-char c port)))))
	(else
	 (write-char #\{ port)
	 (let ((len (b-vector-length x)))
	   (do ((i 0 (+ i 1)))
	       ((= i len) (write-char #\} port))
	     (write (b-vector-ref x i) port)
	     (write-char #\, port)))))
  (write-char #\, port)
  (if *comments?*
      (begin (display " /* " port)
	     (writex x port)
	     (display " */" port)))
  (newline port))

(define (emit-d-vector-initializer x port)
  (write-char #\{ port)
  (let ((len (d-vector-length x)))
    (do ((i 0 (+ i 1)))
	((= i len) (write-char #\} port))
      (emit-descriptor (d-vector-ref x i) port)
      (write-char #\, port))))

(define (emit-descriptor x port)
  (if (stob? x)
      (begin (if (immutable? x)
		 (display "D(p" port)
		 (display "D(i" port))
	     (display (chunk-number x) port)
	     (display ".x" port)
	     (writex x port)
	     (write-char #\) port))
      (write x port)))


; Foo

(define (writex x port)
  (write (quotient (- (- x (memory-begin)) 7) 4) port))

(define (chunk-number x)
  (quotient (- (- x (memory-begin)) 7) *chunk-size*))


; Image traversal utility

(define (for-each-stored-object chunk-start proc chunk-end)
  (let ((limit (heap-pointer)))
    (let chunk-loop ((addr (newspace-begin))
		     (i 0)
		     (chunk (+ (newspace-begin) *chunk-size*)))
      (if (addr< addr limit)
	  (begin (chunk-start i)
		 (let loop ((addr addr))
		   (if (and (addr< addr limit)
			    (addr< addr chunk))
		       (let ((d (fetch addr)))
			 (if (not (header? d))
			     (warn "heap is in an inconsistent state" d))
			 (proc (address->stob-descriptor (addr1+ addr)))
			 (loop (addr1+ (addr+ addr (header-a-units d)))))
		       (begin (chunk-end i)
			      (chunk-loop addr
					  (+ i 1)
					  (+ chunk *chunk-size*))))))))))

(define (mutable? x) (not (immutable? x)))