; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Structure reification.

; Here's what this does: The linker needs to dump a startup procedure
; to the image, which refers to a bunch of structures.  So these
; structures need to be dumped to image somehow, but in fact the
; transport code only knows how to dump a few builtin types, but not
; structures.
; 
; So we do the next best thing: We create code that, when evaluated,
; creates these structures ("reification"), and dump *that* - the
; transporter knows how to do it.  The code will then be run as the
; first thing off the startup procedure.

; This code only reifies the structures and the syntax and inline
; transformers - the transport code takes care of the locations
; holding the regular value bindings of the structures.

(define *least* #f)

; `update-macro-opens' is a procedure accepting and producing an alist phase |-> (list structure)

(define (reify-structures some update-macro-opens)
  (let* ((count 0)
	 (least 1000000)
	 (greatest -1000000)
	 (locs (make-table))
	 (loser (reify-structures-1 (sort-structure-alist some)
				    update-macro-opens
				    (lambda (loc)
				      (let ((id (location-id loc)))
					(if (not (table-ref locs id))
					    (begin 
					      (if (< id least)
						  (set! *least* loc))
					      (set! least (min least id))
					      (set! greatest (max greatest id))
					      (set! count (+ count 1))
					      (table-set! locs id loc)))
					id))))
	 (size (+ (- greatest least) 1)))
    (write `(least ,least size ,size count ,count)) (newline)
    (values loser
	    (let ((v (make-vector size #f)))
	      (table-walk (lambda (id loc)
			    (vector-set! v (- id least) loc))
			  locs)
	      v)
	    least)))

; sort structure alist topologically
(define (sort-structure-alist alist)
  (let ((rev-alist (map (lambda (p) (cons (cdr p) (car p))) alist))
	(seen '())
	(sorted '()))

    (define (visit struct)
      (let* ((p
	      (or (assq struct rev-alist)
		  (cons struct #f)))
	     (struct (car p)))
	(if (not (memq struct seen))
	    (let ((package (structure-package struct)))
	      (set! seen (cons struct seen))
	      (for-each visit (package-opens package))
	      ;; In principle, we should include opens at higher
	      ;; phases, but there's typically only the link-time
	      ;; bogus package there, which we can't reify anyway.
	      ;; For other `for-syntax' clauses, we fail in other
	      ;; ways, anyway.
	      (set! sorted (cons (flip p) sorted))))))

    (define (flip p)
      (cons (cdr p) (car p)))

    (for-each visit (map car rev-alist))

    (reverse sorted)))

; This is pretty gross.  We really want some kind of object dumper
; instead.

(define *objects* '())          ;List of (object . creation-form)
(define *object-count* 0)
(define *initializations* '())
(define *deal-with-location* (lambda (loc) loc))
(define *package-table* #f)     ;Entries are package-info structures


; REIFY-STRUCTURES returns a form that evaluates to a procedure that
; returns an alist of (name . structure).  deal-with-location is a
; procedure that maps locations to labels for them (e.g. integers).
; The procedure takes one argument, a procedure that will be applied
; to the labels at startup time to re-obtain the corresponding
; locations.

(define (reify-structures-1 alist update-macro-opens deal-with-location)
  (flush-state)
  (set! *deal-with-location* deal-with-location)

  (display "Reifying") (force-output (current-output-port))

  (let* ((result-form (reify-object alist))
	 (init-exprs (map (lambda (init) (init)) (reverse *initializations*)))
	 (shebang
	  `(lambda (get-location)
	     (let ((the-objects (make-vector ,*object-count* #f)))
	       ;; silly code to avoid oversize template
	       (begin ,@(map (lambda (exprs) `(let ((foo (lambda (x) ,@exprs))) (foo 'foo)))
			     (split-into-sublists init-exprs 100)))
	       ;; Typically, the macro opens will include `scheme',
	       ;; even for low-level packages that come early in the
	       ;; topological sort.  Consequently, we stick in the
	       ;; correct macro opens once all the package objects
	       ;; have been constructed.
	       ,@(apply append
			(map (lambda (package+phase)
			       (let ((package (car package+phase)))
				 (map (lambda (p)
					`(package-add-opens!
					  ,(reify-package package)
					  ,(car p)
					  (let ((structs (list ,@(map reify-object (cdr p)))))
					    (lambda () structs))))
				      (update-macro-opens (package-macro-opens->alist package)))))
			     (collect-packages (map cdr alist)
					       0
					       (lambda (package phase) #t)
					       (lambda (struct phase) #f))))
	       (let ((structs ,result-form))
		 (set! the-objects #f)	;SO IT CAN BE GC'D
		 (set! get-location #f)
		 structs)))))
    (newline)
    (if *reify-debug* (*reify-debug* shebang))

    (flush-state)
    (set! *deal-with-location* (lambda (loc) loc))

    shebang))

(define (list-split l n)
  (let loop ((n n)
	     (l l)
	     (rev-result '()))
    (if (or (zero? n) (null? l))
	(values (reverse rev-result) l)
	(loop (- n 1)
	      (cdr l)
	      (cons (car l) rev-result)))))

(define (split-into-sublists l n)
  (let loop ((l l)
	     (rev-result '()))
    (if (null? l)
	(reverse rev-result)
	(call-with-values
	    (lambda () (list-split l n))
	  (lambda (head rest)
	    (loop rest
		  (cons head rev-result)))))))

(define (flush-state)
  (set! *objects* '())
  (set! *object-count* 0)
  (set! *initializations* '())
  (set! *package-table* (make-table package-uid)))


; Return an expression that will evaluate to thing.

(define (reify-object thing)
  (cond ((structure? thing)
	 (let ((p-form (reify-package (structure-package thing))))
	   (process-one-object
	        thing
		(lambda ()
		  `(make-structure
		    ,p-form
		    ,(interface-expression thing)
		    ',(structure-name thing)))
		(lambda ()
		  (process-exports thing p-form)
		  (write-char #\. (current-output-port))
		  (force-output (current-output-port))))))
	((null? thing) ''())
	((pair? thing)
	 (if (list? thing)
	     `(list ,@(map reify-object thing))
	     `(cons ,(reify-object (car thing))
		    ,(reify-object (cdr thing)))))
	((symbol? thing)
	 `',thing)
	((boolean? thing) thing)
	((inline-transform? thing)
	 (process-inline-transform thing))
	((operator? thing)
	 `(operator ',(operator-name thing)
		    ',(operator-type->sexp (operator-type thing))))
	((primop? thing)
	 `(primop ',(primop-name thing)))
	;; ((interface? thing) ...)
	(else (assertion-violation 'reify-object "don't know how to reify this" thing))))

(define (operator-type->sexp t)
  (case t
   ((internal leaf #f) t)
   (else (type->sexp t #t))))

(define (reify-package thing)
  (process-one-object thing
		      (lambda ()
			(let ((bindings (package-info-bindings (package-info thing))))
			  `(package
			    ;; Each binding is a pair (name . loc)
			    ',(list->vector (map car bindings)) ;names
			    ',(list->vector (map cdr bindings)) ;location ids
			    (list ,@(map reify-object (package-opens thing)))
			    get-location
			    ,(package-uid thing)
			    ;; We put it in a list, otherwise it'll sit directly in a 
			    ;; template at top level, where the linker couldn't distinguish
			    ;; it from a regular sub-template.
			    ;; We assume the templates have been frozen by the linker.
			    ,(strange-quotation (list (package-invoke-template thing)))
			    ,(strange-quotation (list (package-visit-template thing)))
			    ',(package-usual-transforms thing)
			    ',(package-clauses thing))))
		      (lambda ()
			(table-set! *package-table*
				    thing
				    (make-package-info)))))

(define (package-usual-transforms package)
  (let loop ((clauses (package-clauses package))
	     (transforms '()))
    (cond
     ((null? clauses) (reverse transforms))
     ((eq? 'usual-transforms (caar clauses))
      (loop (cdr clauses)
	    (append (reverse (cdar clauses)) transforms)))
     (else (loop (cdr clauses) transforms)))))

; General utility for uniquifying objects.

(define (process-one-object obj make-creation-form when-new)
  (let ((probe (assq obj *objects*)))
    (if probe
	(cdr probe)
	(let* ((index *object-count*)
	       (form `(vector-ref the-objects ,index)))
	  (set! *object-count* (+ *object-count* 1))
	  (set! *objects*
		(cons (cons obj form) *objects*))
	  (add-initialization!
	    (lambda ()
	      `(vector-set! the-objects ,index ,(make-creation-form))))
	  (when-new)
	  form))))

(define (add-initialization! thunk)
  (set! *initializations*
	(cons thunk *initializations*)))


; Add initializers that will create a structure's exported bindings.

(define (process-exports struct p-form)
  (let* ((package (structure-package struct))
	 (info (package-info package)))
    (for-each-definition (lambda (name place)
			   (process-one-binding name package info p-form))
			 package)))

; Packages...

(define package-info-type
  (make-record-type 'reify-info
		    '(bindings  ;List of (name static-info location)
		      table)))  ;Caches (assq? name bindings)

(define (package-info package)
  (table-ref *package-table* package))

(define make-package-info
  (let ((make (record-constructor package-info-type
				  '(bindings table))))
    (lambda ()
      (make '()
	    (make-name-table)))))

(define package-info-bindings (record-accessor package-info-type 'bindings))
(define package-info-table    (record-accessor package-info-type 'table))

(define set-package-info-bindings!
  (record-modifier package-info-type 'bindings))


(define (process-one-binding name package info p-form)	; => #t iff bound
  (let ((table (package-info-table info)))
    (if (table-ref table name)
	#t
	(let ((binding (package-lookup package name)))
	  (table-set! (package-info-table info) name #t)
	  (if (binding? binding)
	      (begin (really-process-one-binding name info binding 
						 ;; Only include a package-define! if the binding
						 ;; is really sitting in this package.
						 (and (package-lookup-definition package name)
						      p-form))
		     #t)
	      #f)))))

(define (really-process-one-binding name info binding p-form)
  (let ((static (binding-static binding))
	(loc (*deal-with-location* (binding-place binding))))
    (set-package-info-bindings!
     info
     (cons (cons name loc)
	   (package-info-bindings info)))
    (if (and p-form static)
	(add-package-define! p-form name (reify-object static)))))

(define (add-package-define! p-form name s-form)
  (add-initialization!
   (lambda ()
     `(package-define-static! ,p-form
			      ',name
			      ,s-form))))

(define (process-inline-transform transform)
  (let ((env (inline-transform-env transform)))
    (if (not (package? env))
	(assertion-violation 'process-transform
			     "transform environment must be a package"))
    (let ((name (inline-transform-id transform))
	  (env-form (reify-package env)))
      (process-one-object
       transform
       (lambda ()
	 `(reflect-inline-transform ',(inline-transform-source transform)
				    ,env-form
				    ',(type->sexp (inline-transform-type transform) #t) ;type
				    ',name))
       values))))

(define (interface-expression struct)
  (let ((names '())
	(phases '())
	(types '()))
    (for-each-export (lambda (name phase type binding)
		       (set! names (cons name names))
		       (set! phases (cons phase phases))
		       (set! types (cons (if (eq? type undeclared-type)
					     ':undeclared
					     (type->sexp type #t))
					 types)))
		     struct)
    `(simple-interface ',(list->vector names) ',(list->vector phases) ',(list->vector types))))

(define *reify-debug*  ;#f
  (let ((fn "build/reify-debug.tmp"))
    (lambda (x) (call-with-output-file fn
		  (lambda (port)
		    (display "Writing linker debug file ")
		    (display fn) (force-output (current-output-port))
		    (write x port)
		    (newline))))))
