(module flsim-ir

	*
	
	(import scheme chicken)
	
	(require-extension data-structures srfi-1 datatype)


(define-record-type ident
  (make-ident name stamp)
  ident?
  (name   ident-name) 
  (stamp  ident-stamp)
  )


(define ident-create   (let ((currstamp (make-parameter 0)))
			 (lambda (s) 
			   (currstamp (+ 1 (currstamp)))
			   (make-ident s (currstamp)))))
(define  ident-equal? (lambda (id1 id2) (= (ident-stamp id1) 
					   (ident-stamp id2))))
(define ident-empty '())
(define ident-add  (lambda (id data tbl) 
		    (cons (cons id data) tbl)))
(define ident-find  (let ((compare (lambda (x y) (equal? (ident-name x) (ident-name y)))))
		      (lambda (id1 tbl)
			(alist-ref id1 tbl compare))))


(define fv-empty '())
(define (fv-empty? a)          (equal? a '()))
(define (fv-singleton x)       (list x))
(define (fv-remove x a)        (let recur ((a a) (a1 '()))
				 (if (null? a) a1
				     (if (equal? x (car a))
					 (recur (cdr a) a1)
					 (recur (cdr a) (cons x a1))))))
(define (fv-add x a)           (lset-adjoin equal? a x))
(define (fv-union a b)         (lset-union equal? b a))
(define (fv-difference a b)    (lset-difference equal? b a))



(define-datatype cvalue cvalue?
  (CV:C       (v (lambda (x) (or (symbol? x) (number? x) ))))
  (CV:Var     (name ident?))
  (CV:Rec     (flds (lambda (x) (and (pair? x) (every (lambda (x) (and (symbol? (car x)) (value? (cadr x)))) flds)))))
  (CV:Sel     (field (lambda (x) (or (symbol? x) (integer? x)))) (v value?))
  (CV:Vec     (vals (lambda (x) (every value? x))))
  (CV:Sub     (index (lambda (x) (and (integer? x) (or (zero? x) (positive? x))))) (v value?))
  (CV:Ldv     (v value?))
  (CV:Stv     (v value?))
  (CV:Prim    (name ident?)  (args (lambda (x) (every value? x))))
  (CV:Ifv     (test value?)  (ift value?) (iff value?))
  )


(define-datatype cexpr cexpr?
  (CE:Val     (name symbol?)  (v value?))
  (CE:Ife     (test value?)   (ift expr?) (iff expr?))
  (CE:Let     (bnds pair?)    (body expr?))
  (CE:Set     (loc value?)    (v value?))
  (CE:Ret     (v value?))
  (CE:Seq     (exprs pair?))
  (CE:Noop)
  )


(define-record-type block
  (make-block label type arguments expr)
  block?
  (label      block-label )
  (type       block-type )
  (arguments  block-arguments )
  (expr       block-expr )
  )


(define (cvalue-fv v)
  (cases cvalue v
	 (CV:C (c)         fv-empty)
	 (CV:Var (n)       (fv-singleton (ident-name n)))
	 (CV:Rec (flds)    (fold (compose fv-union cvalue-fv) fv-empty (map cadr flds)))
	 (CV:Sel (field v) (cvalue-fv v))
	 (CV:Vec (vals)    (fold (compose fv-union cvalue-fv) fv-empty vals))
	 (CV:Sub (index v) (cvalue-fv v))
	 (CV:Ldv (v)       (cvalue-fv v))
	 (CV:Stv (v)       (cvalue-fv v))
	 (CV:Prim (n args) (fv-union (fv-singleton (ident-name n)) 
				     (fold (compose fv-union cvalue-fv) fv-empty args)))
	 (CV:Ifv  (v1 v2 v3) (fv-union (cvalue-fv v1) (fv-union (cvalue-fv v2) (cvalue-fv v3) )))
	 ))
	 


(define (cexpr-fv x)  
  (cases cexpr x
	 (CE:Val (n v)       (cvalue-fv v))
	 (CE:Ife (v1 e2 e3)  (fv-union (cvalue-fv v1) (fv-union (cexpr-fv e2) (cexpr-fv e3))))
	 (CE:Let (bnds body) (fv-union 
			      (cexpr-fv body)
			      (fold fv-remove
				    (fold (compose fv-union cvalue-fv) fv-empty (map cadr bnds))
				    (map car bnds))))
	 (CE:Set (loc v)     (fv-union (cvalue-fv loc) (cvalue-fv v)))
	 (CE:Ret (v)         (cvalue-fv v))
	 (CE:Seq (es)        (fold (compose fv-union cexpr-fv) fv-empty es))
	 (CE:Noop ()         fv-empty)))



(define (cvalue-type v tenv)
  (cases cvalue v
	 (CV:C (v)  
	      (cond ((symbol? v) (alist-ref v tenv))
		    ((number? v) '(number))))
	 (CV:Var (x) 
		(ident-find x tenv))
	 (CV:Rec (vflds) 
		 `(record . ,(map (lambda (x) (list (car x) (cvalue-type (cadr x) tenv))) vflds)))
	 (CV:Sel (fld v) 
		 (let ((vtype (cvalue-type v tenv)))
		   (case (car vtype)
		     ((record) (alist-ref fld (cdr vtype)))
		     (else (error 'cvalue-type "invalid argument type for V:Sel" vtype)))))
	 (CV:Vec (v) 
		 (let ((ts (delete-duplicates (map (lambda (v) (cvalue-type v tenv)) v))))
		   (if (> (length ts) 1) (error 'cvalue-type "invalid argument type for V:Vec" t)
		       `(vector . ,t))))
	 (CV:Sub (index v) 
		(let ((vtype (cvalue-type v tenv)))
		  (case (car vtype)
		    ((vector) (cadr vtype))
		    (else (error 'cvalue-type "invalid argument type for V:Sub" vtype)))))
	 (CV:Ldv (v)
		(let ((vtype (cvalue-type v tenv)))
		  (case (car vtype)
		    ((pointer) (cadr vtype))
		    (else (error 'cvalue-type "invalid argument type for V:Ldv" vtype)))))
	 (CV:Stv (v)
		(let ((vtype (cvalue-type v tenv)))
		  `(pointer ,vtype)))
	 (CV:Prim (x args)
		  (let ((ftype (ident-find x tenv)))
		    (let ((argts (map (lambda (v) (cvalue-type v tenv)) args)))
		      (let recur ((argts argts)  (ftype ftype))
			(if (null? argts) ftype
			    (case (car ftype)
			      ((arrow)  (if (equal? (cadr ftype) (car argts))
					    (recur (cdr argts) (cadr ftype))))
			      (else (error 'cvalue-type "invalid argument type for V:Prim" ftype)))))
		      )))
	 (CV:Ifv     (test ift iff)
		     (let ((ttest  (cvalue-type test tenv))
			   (tift   (cvalue-type ift tenv))
			   (tiff   (cvalue-type iff tenv)))
		       (if (equal? tift tiff)
			   tift (error 'cvalue-type "true and false clauses do not have the same type in V:Ifv" tift tiff))))
	 ))
  


(define (cexpr-type e tenv)
  (cases cexpr e
	 (CE:Let     (bnds body)    
		     (let ((ltenv (fold (lambda (bnd env) (ident-add (ident-create (car bnd)) (cadr bnd) env)) tenv bnds)))
		       (cexpr-type body ltenv)))

	 (CE:Set     (loc v)  
		     (let ((tloc (cvalue-type loc tenv))
			   (tv (cvalue-type v tenv)))
		       (case (car tloc)
			 ((pointer) (if (equal? tv (cadr tloc)) `(void) 
					(error 'cexpr-type "incompatible pointer value" tloc tv)))
			 (else (error 'cexpr-type "first argument to CE:Set must be a pointer" loc)))))

	 (CE:Seq     (es)     
		     (let ((ts (map (lambda (e) (cexpr-type e tenv)) es)))
		       (last ts)))

	 (CE:Ife     (test ift iff) 
		     (let ((ttest (cvalue-type test tenv))
			   (tift  (cexpr-type ift tenv))
			   (tiff  (cexpr-type iff tenv)))
		       (if (equal? tift tiff) tift
			   (error 'cexpr-type "true and false clauses do not have the same type in E:Ifv" tift tiff))
		       ))

	 (CE:Val     (name v) 
		     (error 'cexpr-type "internal declarations are not allowed" e))

	 (CE:Ret     (v)  (cvalue-type v tenv) )

	 (CE:Noop    ()   `(void) )
	 ))



(define (ctransform xs env tenv)
  (if (null? xs) env
      
      (cases (car xs) expr
	 
	 (E:Val (name val)
		(let-values
		    (((env1 tenv1)
		      (cases value val

			     (V:Fn (args body) 
				   (let-values (((name env1 tenv1) 
						 (ctransform-fn (ident-create name) args body env tenv)))
				     (values env1 tenv1)))
				     
			     (else
			      (let-values (((val1 env1 tenv1)  (ctransform-val val env tenv)))
				(let ((t1 (cvalue-type val1 tenv1)))
				  (values
				   (ident-add name (make-block name t1 '() (CE:Ret val1)) env1)
				   (ident-add name t1 tenv1))
				  )))
			     )))
		  (ctransform (cdr x) env1 tenv1)))

	 (else (error 'ctransform "invalid declaration: " (car xs))))
      ))


					      
(define (ctransform-val v env tenv)
  (cases value v
	 (V:C       (k)  (values (VC:C k) env tenv))

	 (V:Var     (n)  (values (VC:Var n) env tenv))

	 (V:Rec     (flds) (let recur ((flds flds) (flds1 '()) (env env) (tenv tenv))
			     (if (null? flds) (values (CV:Rec (reverse flds1)) env tenv)
				 (let ((fld (car flds)))
				   (let ((n (car fld)) (v (cadr fld)))
				     (let-values (((v1 env1 tenv1) (ctransform-val v env tenv)))
				       (recur (cdr flds) (cons (list n v1) flds1)
					      env1 tenv1))
				     ))
				 )))

	 (V:Sel     (fld v) (let-values (((v1 env1 tenv1) (ctransform-val v env tenv)))
			      (values (CV:Sel fld v1) env1 tenv1)))

	 (V:Vec     (vals)  (let recur ((vals vals) (vals1 '()) (env env) (tenv tenv))
				     (if (null? vals) (values (CV:Vec (reverse vals1)) env tenv)
					   (let ((v (car vals)))
					     (let-values (((v1 env1 tenv1) (ctransform-val v env tenv)))
					       (recur (cdr vals) (cons v1 vals1) env1 tenv1)))
					     )))

	 (V:Sub     (index v) (let-values (((v1 env1 tenv1) (ctransform-val v env tenv)))
				(values (CV:Sub index v1) env1 tenv1)))
		    
	 (V:Ldv     (v)       (let-values (((v1 env1 tenv1) (ctransform-val v env tenv)))
				(values (CV:Ldv v1) env1 tenv1)))

	 (V:Stv     (v)       (let-values (((v1 env1 tenv1) (ctransform-val v env tenv)))
				(values (CV:Stv v1) env1 tenv1)))

	 (V:Fn      (args body) (let ((n (ident-create (gensym 'fn))))
				  (ctransform-fn n args body env tenv)))

	 (V:Prim    (name vs)  (let recur ((vals vs) (vals1 '()) (env env) (tenv tenv))
				 (if (null? vals) 
				     (values (CV:Prim (ident-create name) (reverse vals1)) env tenv)
				     (let ((v (car vals)))
				       (let-values (((v1 env1 tenv1) (ctransform-val v env tenv)))
					 (recur (cdr vals) (cons v1 vals1) env1 tenv1)))
				     )))

	 (V:Ifv     (test ift iff) (let recur ((vals (list test ift iff)) (vals1 '()) (env env) (tenv tenv))
				     (if (null? vals) (values (CV:Ifv (reverse vals1)) env tenv)
					   (let ((v (car vals)))
					     (let-values (((v1 env1 tenv1) (ctransform-val v env tenv)))
					       (recur (cdr vals) (cons v1 vals1) env1 tenv1)))
					     )))

	 ))

					    

(define (ctransform-fn name args body env tenv)

  (let* ((iargs (map ident-create args))
	 (ltenv (fold (lambda (x env) (ident-add x `(tvar) env)) tenv iargs)))

    (let-values (((body1 env1 ltenv1)) (ctransform-expr body env ltenv))
      (let* ((fvs (map ident-create (fold fv-remove (cexpr-fv body1) (map car ltenv1))))
	     (body2 (CE:Let (map (lambda () fvs)) body1)))
	
	(let ((t1 (cexpr-type body1 env1 ltenv1)))
	  ;; TODO: construct arrow type
	  (values
	   (CV:Var name)
	   (ident-add name (make-block name t1 iargs body2) env1)
	   (fold ident-remove ltenv1 iargs))))
	)))



)