#lang scheme
(require (planet cce/scheme:4:1/planet)
         (for-syntax (planet cce/scheme:4:1/planet)))
(require (prefix-in scheme: scheme)
         (this-package-in private/command-line)
         (for-syntax (this-package-in private/command-line))
         (this-package-in private/collector-exports)
         (this-package-in private/gc-core)
         scheme/gui/dynamic
         (only-in (this-package-in test-harness) generic-test test halt-on-errors print-only-errors)
         (for-syntax scheme)
         (for-syntax (this-package-in private/gc-transformer))
         scheme/stxparam
         (for-syntax scheme/stxparam-exptime))

(provide else require provide
         test/location=? 
         test/value=?
         (rename-out
          [mutator-and and]
          [mutator-or or]
          [mutator-cond cond]
          [mutator-case case]
          [mutator-define define]
          [mutator-define-values define-values]
          (mutator-let let)
          [mutator-let* let*]
          [mutator-begin begin]
          
          [mutator-if if]
          [mutator-let-values let-values]
          [mutator-set! set!]
          [mutator-lambda lambda]
          [mutator-lambda λ]
          (mutator-app #%app)
          (mutator-datum #%datum)
          (collector:cons cons)
          (collector:first first)
          (collector:rest rest)
          (mutator-quote quote)
          (mutator-top-interaction #%top-interaction)
          (mutator-module-begin #%module-begin)))

(define-syntax-parameter mutator-tail-call? #t)
(define-syntax-parameter mutator-env-roots empty)

; Sugar Macros
(define-syntax-rule (->address e) e)
(define-syntax mutator-and
  (syntax-rules ()
    [(_) (mutator-quote #t)]
    [(_ fe e ...) (mutator-if fe (mutator-and e ...) (mutator-quote #f))]))
(define-syntax mutator-or
  (syntax-rules ()
    [(_) (mutator-quote #f)]
    [(_ fe e ...) (mutator-if fe (mutator-quote #t) (mutator-or e ...))]))
(define-syntax mutator-cond
  (syntax-rules (else)
    [(_) (mutator-begin)]
    [(_ [else e ...]) (mutator-begin e ...)]
    [(_ [q ans] e ...) (mutator-if q ans (cond e ...))]))
(define-syntax mutator-case
  (syntax-rules (else)
    [(_ value
        [(v ...) e ...]
        ...
        [else ee ...])
     (mutator-let ([tmp value])
                  (mutator-cond [(member? tmp (mutator-quote '(v ...))) e ...]
                                ...
                                [else ee ...]))]
    [(_ value
        [(v ...) e ...]
        ...)
     (mutator-let ([tmp value])
                  (mutator-cond [(member? tmp (mutator-quote '(v ...))) e ...]
                                ...))]))
(define-syntax mutator-define
  (syntax-rules ()
    [(_ (f a ...) e ...)
     (mutator-define-values (f) (mutator-lambda (a ...) e ...))]
    [(_ id e)
     (mutator-define-values (id) e)]))
(define-syntax-rule (mutator-let ([id e] ...) be ...)
  (mutator-let-values ([(id) e] ...) be ...))
(define-syntax mutator-let*
  (syntax-rules ()
    [(_ () be ...)
     (mutator-begin be ...)]
    [(_ ([fid fe] [rid re] ...) be ...)
     (mutator-let ([fid fe])
                  (mutator-let* ([rid re] ...)
                                be ...))]))
(define-syntax mutator-begin
  (syntax-rules ()
    [(_) (mutator-app void)]
    [(_ e) e]
    [(_ fe e ...)
     (mutator-let ([tmp fe]) (mutator-begin e ...))]))

; Real Macros
(define-syntax-rule (mutator-define-values (id ...) e)
  (begin (define-values (id ...) 
           (syntax-parameterize ([mutator-tail-call? #f])
                                (->address e)))
         (add-global-root! (make-env-root id))
         ...))
(define-syntax-rule (mutator-if test true false)
  (if (syntax-parameterize ([mutator-tail-call? #f])
                           (collector:deref (->address test)))
      (->address true)
      (->address false)))
(define-syntax-rule (mutator-set! id e)
  (begin
    (set! id (->address e))
    (mutator-app void)))
(define-syntax (mutator-let-values stx)
  (syntax-case stx ()
    [(_ ([(id ...) expr]
         ...)
        body-expr)
     (with-syntax ([((tmp ...) ...)
                    (map generate-temporaries (syntax->list #'((id ...) ...)))])
       (let ([binding-list (syntax->list #'((tmp ...) ...))])
         (with-syntax ([((previous-tmp ...) ...)
                        (build-list (length binding-list) 
                                    (λ (n) (append-map syntax->list (take binding-list n))))])
           (syntax/loc stx
             (let*-values ([(tmp ...) 
                            (syntax-parameterize ([mutator-env-roots 
                                                   (list* #'previous-tmp ...
                                                          (syntax-parameter-value #'mutator-env-roots))]
                                                  [mutator-tail-call? #f])
                                                 expr)]
                           ...)
               (let-values ([(id ...) (values tmp ...)]
                            ...)
                 (syntax-parameterize ([mutator-env-roots 
                                        (list* #'id ... ...
                                               (syntax-parameter-value #'mutator-env-roots))])
                                      (->address body-expr))))))))]
    [(_ ([(id ...) expr]
         ...)
        body-expr ...)
     (syntax/loc stx
       (mutator-let-values
        ([(id ...) expr]
         ...)
        (mutator-begin body-expr ...)))]))
(define-syntax (mutator-lambda stx)
  (syntax-case stx ()
    [(_ (id ...) body)
     (let ([env-roots (syntax-parameter-value #'mutator-env-roots)])
       (with-syntax ([(free-id ...) (find-referenced-locals env-roots stx)]
                     [(env-id ...) env-roots]
                     [closure (or (syntax-local-name)
                                  (let ([prop (syntax-property stx 'inferred-name)])
                                    (if (or (identifier? prop)
                                            (symbol? prop))
                                        prop
                                        #f))
                                  (string->symbol "#<proc>"))])
         (quasisyntax/loc stx
           (let ([closure (lambda (id ...) 
                            (syntax-parameterize ([mutator-env-roots 
                                                   (list* #'id ...
                                                          (syntax-parameter-value #'mutator-env-roots))]
                                                  [mutator-tail-call? #t])
                                                 (->address body)))])
             (add-closure-env! closure (list (make-env-root free-id) ...))
             #,(if (syntax-parameter-value #'mutator-tail-call?)
                   (syntax/loc stx
                     (#%app collector:alloc-flat closure))
                   (syntax/loc stx
                     (with-continuation-mark gc-roots-key 
                       (list (make-env-root env-id) ...)
                       (#%app collector:alloc-flat closure))))))))]
    [(_ (id ...) body ...)
     (syntax/loc stx
       (mutator-lambda (id ...) (mutator-begin body ...)))]))
(define-syntax (mutator-app stx)
  (syntax-case stx ()
    [(_ e ...)
     (local [(define (do-not-expand? exp)
               (and (identifier? exp)
                    (free-identifier=? exp #'empty)))
             (define exps
               (syntax->list #'(e ...)))
             (define tmps
               (generate-temporaries #'(e ...)))]
       (with-syntax ([(ne ...)
                      (map (lambda (exp tmp) (if (do-not-expand? exp) exp tmp))
                           exps tmps)])
         (for/fold ([acc (syntax/loc stx (mutator-anf-app ne ...))])
           ([exp (in-list (reverse exps))]
            [tmp (in-list (reverse tmps))])
           (if (do-not-expand? exp)
               acc
               (quasisyntax/loc stx
                 (mutator-let ([#,tmp #,exp])
                              #,acc))))))]))
(define-syntax (mutator-anf-app stx)
  (syntax-case stx ()
    [(_ fe ae ...)
     (with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)])
       (if (syntax-parameter-value #'mutator-tail-call?)
           ; If this call is in tail position, we will not need access to its environment when it returns.
           (syntax/loc stx ((deref fe) ae ...))
           ; If this call is not in tail position, we make the environment at the call site
           ; reachable.
           #`(with-continuation-mark gc-roots-key 
               (list (make-env-root env-id) ...)
               #,(syntax/loc stx ((deref fe) ae ...)))))]))
(define-syntax mutator-quote
  (syntax-rules ()
    [(_ (a . d))
     (mutator-anf-app collector:cons (mutator-quote a) (mutator-quote d))]
    [(_ s) 
     (mutator-anf-app collector:alloc-flat 's)]))
(define-syntax (mutator-datum stx)
  (syntax-case stx ()
    [(_ . e) 
     (quasisyntax/loc stx (mutator-anf-app collector:alloc-flat (#%datum . e)))]))

(define-syntax (mutator-top-interaction stx)
  (syntax-case stx (require provide mutator-define mutator-define-values test/value=? import-primitives)
    [(_ . (require . e))
     (syntax/loc stx
       (require . e))]
    [(_ . (provide . e))
     (syntax/loc stx
       (provide . e))]
    [(_ . (mutator-define . e))
     (syntax/loc stx
       (mutator-define . e))]
    [(_ . (mutator-define-values . e))
     (syntax/loc stx
       (mutator-define-values . e))]
    [(_ . (test/value=? . e))
     (syntax/loc stx
       (test/value=? . e))]
    [(_ . (import-primitives . e))
     (syntax/loc stx
       (import-primitives . e))]
    [(_ . expr)
     (syntax/loc stx
       (call-with-values
        (lambda ()
          (syntax-parameterize ([mutator-tail-call? #f])
                               (->address expr)))
        (case-lambda
          [() (void)]
          [(result-addr)
           (cond
             [(procedure? result-addr)
              (printf "Imported procedure~n")
              result-addr]
             [(location? result-addr)
              (printf "Value at location ~a:~n" result-addr)
              (gc->scheme result-addr)])])))]))

; Module Begin
(define-for-syntax required-allocator-stx false)

(define-for-syntax (allocator-setup-internal stx)
  (with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons 
                                 gc:first gc:rest 
                                 gc:flat? gc:cons?
                                 gc:set-first! gc:set-rest!)
                 (map (λ (s) (datum->syntax stx s))
                      '(init-allocator gc:deref gc:alloc-flat gc:cons 
                                       gc:first gc:rest 
                                       gc:flat? gc:cons?
                                       gc:set-first! gc:set-rest!))])
    (syntax-case stx ()
      [(collector-module heap-size)
       (begin
         (set! required-allocator-stx 
               (if (alternate-collector)
                   (datum->syntax stx (alternate-collector))
                   #'collector-module))
         #`(begin
             #,(if (alternate-collector)
                   #`(require #,(datum->syntax #'collector-module (alternate-collector)))
                   #`(require collector-module))
             
             (set-collector:deref! gc:deref)
             (set-collector:alloc-flat! gc:alloc-flat)
             (set-collector:cons! gc:cons)
             (set-collector:first! gc:first)
             (set-collector:rest! gc:rest)
             (set-collector:flat?! gc:flat?)
             (set-collector:cons?! gc:cons?)
             (set-collector:set-first!! gc:set-first!)
             (set-collector:set-rest!! gc:set-rest!)
             
             (init-heap! (#%datum . heap-size))
             (when (gui-available?) 
               (if (<= (#%datum . heap-size) 500)
                   (set-ui! (dynamic-require `(planet #,(this-package-version-symbol private/gc-gui)) 'heap-viz%))
                   (printf "Large heap; the heap visualizer will not be displayed.~n")))
             (init-allocator)))]
      [_ (raise-syntax-error 'mutator 
                             "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)"
                             stx)])))

(define-for-syntax allocator-setup-error-msg
  "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)")

(define-syntax (mutator-module-begin stx)
  (syntax-case stx (allocator-setup)
    [(_ (allocator-setup . setup) module-expr ...)
     (begin
       (syntax-case #'setup ()
         [(collector heap-size)
          (begin
            (unless (string? (syntax->datum #'collector))
              (raise-syntax-error 'allocator-setup "expected a literal string" #'collector))
            (unless (number? (syntax->datum #'heap-size))
              (raise-syntax-error 'allocator-setup "expected a literal number" #'heap-size)))]
         [_
          (raise-syntax-error 'mutator allocator-setup-error-msg (syntax/loc #'setup (allocator-setup . setup)))])
       #`(#%module-begin
          #,(allocator-setup-internal #'setup)
          (mutator-top-interaction . module-expr)
          ...))]
    [(_ first-expr module-expr ...)
     (raise-syntax-error 'mutator allocator-setup-error-msg #'first-expr)]
    [(_)
     (raise-syntax-error 'mutator allocator-setup-error-msg)]))

; User Macros
(provide import-primitives)
(define-syntax (import-primitives stx)
  (syntax-case stx ()
    [(_ id ...) 
     (andmap identifier? (syntax->list #'(id ...)))
     (with-syntax ([(renamed-id ...) (generate-temporaries #'(id ...))]
                   [source (syntax-local-get-shadower
                            (syntax-local-introduce #'scheme))])
       #`(begin
           (require (only-in source [id renamed-id] ...))
           (define id
             (lambda args
               (unless (andmap (lambda (v) (and (location? v) (collector:flat? v))) args)
                 (error 'id (string-append "all arguments must be <heap-value?>s, "
                                           "even if the imported procedure accepts structured "
                                           "data")))
               (let ([result (apply renamed-id (map collector:deref args))])
                 (cond
                   [(void? result) (void)]
                   [(heap-value? result) (collector:alloc-flat result)]
                   [else 
                    (error 'id (string-append "imported primitive must return <heap-value?>, "
                                              "received ~a" result))]))))
           ...))]
    [(_ maybe-id ...) 
     (ormap (λ (v) (and (not (identifier? v)) v)) (syntax->list #'(maybe-id ...)))
     (let ([offending-stx (findf (λ (v) (not (identifier? v))) (syntax->list #'(maybe-id ...)))])
       (raise-syntax-error 
        #f "expected identifier to import" offending-stx))]
    [(_ . __)
     (raise-syntax-error #f "expected list of identifiers to import" stx)]
    [_ (raise-syntax-error #f "expected open parenthesis before import-primitive")]))

; User Functions
(define (mutator-lift f) 
  (lambda args
    (let ([result (apply f (map collector:deref args))])
      (if (void? result)
          (void)
          (collector:alloc-flat result)))))
(define-syntax (provide/lift stx)
  (syntax-case stx ()
    [(_ id ...)
     (andmap identifier? (syntax->list #'(id ...)))
     (with-syntax ([(lifted-id ...) (generate-temporaries #'(id ...))])
       #'(begin
           (define lifted-id (mutator-lift id)) ...
           (provide (rename-out [lifted-id id] ...))))]))

(provide/lift 
 symbol? boolean? number?
 add1 sub1 zero? + - * / even? odd? = < > <= >=)

(provide (rename-out (mutator-set-first! set-first!)))
(define (mutator-set-first! x y)
  (collector:set-first! x y)
  (void))

(provide (rename-out (mutator-set-rest! set-rest!)))
(define (mutator-set-rest! x y)
  (collector:set-rest! x y)
  (void))

(provide (rename-out [mutator-empty empty]))
(define-syntax mutator-empty
  (syntax-id-rules (mutator-empty)
    [_ (mutator-quote ())]))

(provide (rename-out (mutator-empty? empty?)))
(define (mutator-empty? loc)
  (cond
    [(collector:flat? loc) 
     (collector:alloc-flat (empty? (collector:deref loc)))]
    [else 
     (collector:alloc-flat false)]))

(provide (rename-out [mutator-cons? cons?]))
(define (mutator-cons? loc)
  (collector:alloc-flat (collector:cons? loc)))

(provide (rename-out [mutator-eq? eq?]))
(define (mutator-eq? l1 l2)
  (collector:alloc-flat (= l1 l2)))

(provide (rename-out [mutator-printf printf]))
(define-syntax (mutator-printf stx)
  (syntax-case stx ()
    [(_ fmt arg ...)
     ; We must invoke mutator-app to A-normalize the arguments.
     (syntax/loc stx 
       (begin
         (mutator-app printf (#%datum . fmt)
                      (mutator-app gc->scheme arg) ...)
         (void)))]))

(provide (rename-out
          (mutator-halt-on-errors halt-on-errors)
          (mutator-print-only-errors print-only-errors)))
(define-syntax (mutator-halt-on-errors stx)
  (syntax-case stx ()
    [(_) #'(halt-on-errors)]
    [(_ arg) #'(#%app halt-on-errors (#%datum . arg))]))

(define-syntax (mutator-print-only-errors stx)
  (syntax-case stx ()
    [(_) #'(print-only-errors)]
    [(_ arg) #'(#%app print-only-errors (#%datum . arg))]))

; Implementation Functions
(define (deref proc/loc)
  (cond
    [(procedure? proc/loc) proc/loc]
    [(location? proc/loc) (collector:deref proc/loc)]
    [else (error 'deref "expected <location?> or <procedure?; received ~a" proc/loc)]))

(define (gc->scheme loc)
  (define-struct an-unset ())
  (define unset (make-an-unset))
  (define phs (make-hash))
  (define (unwrap loc)
    (if (hash-has-key? phs loc)
        (hash-ref phs loc)
        (begin
          (local [(define ph (make-placeholder unset))]
            (hash-set! phs loc ph)
            (cond
              [(collector:flat? loc)
               (placeholder-set! ph (collector:deref loc))]
              [(collector:cons? loc)
               (local [(define car-ph (make-placeholder unset))
                       (define cdr-ph (make-placeholder unset))]
                 (placeholder-set! ph (cons car-ph cdr-ph))
                 (placeholder-set! car-ph (unwrap (collector:first loc)))
                 (placeholder-set! cdr-ph (unwrap (collector:rest loc))))]
              [else 
               (error (format "gc:flat? and gc:cons? both returned false for ~a" loc))])
            (placeholder-get ph)))))
  (make-reader-graph (unwrap loc)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Testing support

(define-syntax (test/location=? stx)
  (syntax-case stx ()
    [(_ e1 e2)
     (quasisyntax/loc stx
       (mutator-let ([e1-addr e1]
                     [e2-addr e2])
                    (test e1 e2)))]))

(define-for-syntax (flat-heap-value? v)
  (or (number? v) (boolean? v)))

(define-syntax (expand-scheme stx)
  (syntax-case stx (mutator-quote mutator-datum)
    [(_ val) (flat-heap-value? (syntax->datum #'val)) #'(#%datum . val)]
    [(_ (mutator-datum . val))
     #'(#%datum . val)]
    [(_ (mutator-quote e))
     #'(quote e)]
    [_ 
     (raise-syntax-error 'test/value=? "must be a number, boolean or a quoted value" stx)]))

(define-syntax (test/value=? stx)
  (syntax-case stx (mutator-quote)
    [(_ mutator-expr scheme-datum)
     (quasisyntax/loc stx
       (mutator-let ([v1 mutator-expr])
                    (test (gc->scheme v1) (expand-scheme scheme-datum))))]))