;; Representation choosing phase of the the compiler
;; (c) 1996-7 Sebastian Good
;; (c) 1997-8 PLT, Rice University

; Chooses the representation of all bindings, and also
;  closures.

; Currently, all variables for Scheme values are represented
;  as Scheme_Object* values. But representations are also
;  chosen for closures and indirected Scheme variables, so
;  not everything is a Scheme_Object*.

;;; Annotatitons: ----------------------------------------------
;;    binding - `binding' structure UPDATED: rep field set
;;; ------------------------------------------------------------

(unit/sig
 compiler:rep^
 (import compiler:library^
	 compiler:cstructs^
	 (zodiac : zodiac:system^)
	 compiler:zlayer^
	 compiler:const^
	 compiler:vehicle^
	 compiler:driver^)

;;----------------------------------------------------------------------------
;; REPRESENTATION (TYPE) LANGUAGE
;;
;; future : add const?
;;

(define-struct rep:atomic (type))
; Where type is one of: 
;  'scheme-object 
;  'scheme-bucket
;  'scheme-per-load-static
;  'label
;  'prim
;  'prim-case
;  'unit
;  'begin0-saver
;  'wcm-saver
(define-struct rep:pointer (to))
(define-struct rep:struct (name orig-name fields))
(define-struct rep:struct-field (name orig-name rep))

(define (rep:same-shape? a b)
  (let ([al (rep:struct-fields a)]
	[bl (rep:struct-fields b)])
    (and (= (length al) (length bl))
	 (andmap (lambda (af bf)
		   (let ([ar (rep:struct-field-rep af)]
			 [br (rep:struct-field-rep bf)]) 
		     (or (and (rep:atomic? ar)
			      (rep:atomic? br)
			      (eq? (rep:atomic-type ar)
				   (rep:atomic-type br)))
			 (and (rep:struct? ar)
			      (rep:struct? br)
			      (eq? (rep:struct-name ar)
				   (rep:struct-name br))))))
		 al bl))))

(define compiler:struct-index 0)
(define compiler:structs null)
(define (compiler:init-structs!)
  (set! compiler:structs null))
(define compiler:add-struct!
  (lambda (struct)
    (let loop ([l compiler:structs])
      (cond
       [(null? l)
	(let ([name (string->symbol (format "mergedStructs~a" compiler:struct-index))])
	  (set! compiler:struct-index (add1 compiler:struct-index))
	  (set-rep:struct-name! struct name)
	  (let loop ([l (rep:struct-fields struct)][n 0])
	    (unless (null? l)
	      (unless (rep:struct-field-name (car l))
	          (set-rep:struct-field-name! (car l)
					      (string->symbol
					       (format "f~a" n))))
	      (loop (cdr l) (add1 n)))))
	(set! compiler:structs (cons struct compiler:structs))]
       [(rep:same-shape? struct (car l))
	(set-rep:struct-name! struct (rep:struct-name (car l)))
	(let loop ([nl (rep:struct-fields struct)]
		   [ol (rep:struct-fields (car l))])
	  (unless (null? nl)
             (set-rep:struct-field-name! (car nl)
					 (rep:struct-field-name (car ol)))
	     (loop (cdr nl) (cdr ol))))]
       [else (loop (cdr l))]))))

(define (rep:find-field struct orig-name)
  (let loop ([l (rep:struct-fields struct)])
    (if (null? l)
	(compiler:internal-error 
	 #f 
	 (format
	  "vm:find-field: ~a not found in ~a" orig-name
	  (rep:struct-fields struct)))
	(if (eq? (rep:struct-field-orig-name (car l)) orig-name)
	    (rep:struct-field-name (car l))
	    (loop (cdr l))))))

;;----------------------------------------------------------------------------
;; choose-binding-representations! implements the lion's share of work in 
;; chosing representations.  It takes 3 inputs:
;;   1) a <set> of variables occurring local to an expression
;;   2) a <set> of those variables which are globals
;;   3) a <set> of those variables which are used
;;   4) a <set> of those variables which are captured
;; and returns no values
;;
;; As a side effect, it sets the representation fields of all those
;; struct:bindings living in those compiler:bound guys.

(define choose-binding-representations!
  (lambda (local-vars global-vars used-vars captured-vars)
    (let ([set-rep!
	   (lambda (local-var)
	     (let ([binding (get-annotation local-var)])
	       (unless (binding-rep binding)
	         (set-binding-rep! binding
				   (if (or (binding-mutable? binding)
					   (binding-unit-i/e? binding)
					   (binding-letrec-set? binding)
					   (binding-ivar? binding))
				       (make-rep:pointer 
					(make-rep:atomic 'scheme-object))
				       (make-rep:atomic 'scheme-object))))))])
      (for-each set-rep! (set->list local-vars)))))

;;----------------------------------------------------------------------------
;; choose-closure-representation! chooses representations for a closure
;; it takes 1 input
;;   1) a code structure
;;
;; and returns no values
;;
;; As a side effect, it sets the closure-code-rep field of the code structure
;; based on its free variables.  It must be called _after_ binding
;; representations have been chosen
;;
(define choose-closure-representation!
  (lambda (code)
    (let* ([base (gensym)]
	   [struct (let ([fields
			  (append! (if (vehicle:only-code-in-vehicle? code)
				       null
				       (list
					(make-rep:struct-field 'label
							       'label
							       (make-rep:atomic 'label))))
				   (map (lambda (bound)
					  (make-rep:struct-field
					   ; field-name
					   #f
					   (zodiac:binding-var bound)
					   ; field-type
					   (binding-rep (get-annotation bound))))
					(set->list (code-free-vars code)))
				   (map (lambda (global)
					  (make-rep:struct-field
					   ; field-name
					   (if (const:per-load-statics-table? global)
					       'pls
					       #f)
					   global
					   ; field-type
					   (if (const:per-load-statics-table? global)
					       (make-rep:atomic 'scheme-per-load-static)
					       (make-rep:atomic 'scheme-bucket))))
					(set->list (code-global-vars code))))])
		     (if (null? fields)
			 #f ; empty structure - don't use anything
			 (make-rep:struct 
			  ; name
			  #f
			  (symbol-append 'struct base)
			  fields)))])
      (when struct
        (compiler:add-struct! struct))
      (let* ([fields (append (cond
				    [(procedure-code? code)
				     (list
				      (make-rep:struct-field 'prim
							     'prim
							     (if (= 1 (length (procedure-code-case-codes code)))
								 (make-rep:atomic 'prim)
								 (make-rep:atomic 'prim-case))))]
				    [(unit-code? code)
				     (list
				      (make-rep:struct-field 'unit
							     'unit
							     (make-rep:atomic 'unit)))]
				    [(class-code? code) null]
				    [else
				     (compiler:internal-error
				      #f
				      "unknown closure code type: ~s" code)])
				   (if struct
				       (list
					(make-rep:struct-field 'data
							       'data
							       struct))
				       null))]
	     [alloc-struct (if (null? fields)
			       #f
			       (make-rep:struct 
				; name
				#f
				(symbol-append 'allocstruct base)
				fields))])
	(when alloc-struct
	   (compiler:add-struct! alloc-struct))
	
	(set-closure-code-rep! code struct)
	(set-closure-code-alloc-rep! code alloc-struct)))))

)

#|
(define rep->sexp
  (lambda (rep)
    (cond
      [(rep:atomic? rep) (rep:atomic-type rep)]
      [(rep:pointer? rep) `(pointer ,(rep->sexp (rep:pointer-to rep)))]
      [(rep:struct? rep) `(struct)])))
|#
