;;; locations example demonstrating returning a  pointer by reference
;;; locations have a high penalty [same as a callback, I believe]


;;      (define modf
;;        (foreign-lambda double "modf" double (pointer double)) )

;;      (let-location ([i double])
;;        (let ([f (modf 1.99 (location i))])
;;          (print "i=" i ", f=" f) ) )


(define callback
  (foreign-lambda* int (((pointer "void *") buffer)) #<<EOF
    static char a[] = "hello";
    //printf("callback: ptr: %p\n", a);
    *buffer = a;
    return(1);
EOF
))

(define callback1-scheme-pointer
  (foreign-lambda* int ((scheme-pointer buffer)) #<<EOF
    static char a[] = "hello";
    void **b = (void **)buffer;
    *b = a;
    return(1);
EOF
))

(define callback1-c-pointer
  (foreign-lambda* int ((c-pointer buffer)) #<<EOF
    static char a[] = "hello";
    void **b = (void **)buffer;
    *b = a;
    return(1);
EOF
))

(define callback1-m
  (foreign-lambda* int (((pointer "void *") buffer)) #<<EOF
    char *a = C_malloc(3);
    a[0] = 'h'; a[1] = 'i'; a[2] = '\0';
    *buffer = a;
    return(1);
EOF
))


(define callback2
  (foreign-lambda* c-pointer ((scheme-object buf)) #<<EOF
    static char a[] = "hello2";
    return(a);
EOF
))

(define callback2-m
  (foreign-lambda* c-pointer ((scheme-object buf)) #<<EOF
    char *a = C_malloc(4);
    return(a);
EOF
))


;; Omit return type for multiple values.
;; Returning an extra pointer value is much faster than using a location.
(define callback4
  (foreign-primitive ((scheme-object buf)) #<<EOF
    static char a[] = "hello4";
    C_word pb[C_SIZEOF_POINTER], *ptr = pb, p;
    p = C_mpointer(&ptr, a);

       /*  C_values(N + 2, C_SCHEME_UNDEFINED, C_k, X1, ...) */
    C_values(4, C_SCHEME_UNDEFINED, C_k, C_fix(1), p);
EOF
))

(define callback5
  (foreign-primitive ((scheme-object buf)) #<<EOF
    char *a = C_malloc(3);
    C_word pb[C_SIZEOF_POINTER], *ptr = pb, p;
    a[0] = 'h'; a[1] = 'i'; a[2] = '\0';
    p = C_mpointer(&ptr, a);

       /*  C_values(N + 2, C_SCHEME_UNDEFINED, C_k, X1, ...) */
    C_values(4, C_SCHEME_UNDEFINED, C_k, C_fix(1), p);
EOF
))

(define callback7
  (foreign-lambda* int ((scheme-object ptr)) #<<EOF
    char *a = C_malloc(3);
    a[0] = 'h'; a[1] = 'i'; a[2] = '\0';
    // should check for pointer here -- C_blockp(x) && C_specialp(x) -- or C_pointerp(x)
    // there is no error-throwing check, though
    C_set_block_item(ptr, 0, (C_word)a);
    return(1);
EOF
))


(define print-str
  (foreign-lambda* void (((pointer "char *") ptr)) #<<EOF
    printf("ptr: %p\n", ptr);
    printf("str: %s\n", ptr);
EOF
))

(define b)

(define (execute)
  (let-location ([buf c-pointer])
    (let ((result (callback #$buf)))
;      (print "result: " result)
;      (print "buf: " buf)
;      (set! b buf)
      buf
      )))

;; Make a 4-byte string instead of using a let-location.
;; A bit slower than let-location.
(define (execute1-locative)
  (let ((p (make-string 4)))
    (let ((result (callback #$p)))
      ;(print-str p)
;      (free p)
      result)))

;; Make a 4-byte string instead of using a let-location.
;; callback1-scheme-pointer expects a scheme-pointer this time.
(define (execute1-scheme-pointer)
  (let ((p (make-string 4)))     ;; equal results from ##sys#make-string
    (let ((result (callback1-scheme-pointer p)))
      ;(print-str p)
;      (free p)
      p)))

;; same as execute1-scheme-pointer but dumping directly into
;; a #<pointer> rather than a string
(define (execute1-scheme-pointer-ptr)
  (let ((p (##sys#make-pointer)))
    (let ((result (callback1-scheme-pointer p)))
      ;(print-str p)
;      (free p)
      p)))

(define (execute1-scheme-pointer-bv)
  (let ((p (make-byte-vector 4)))
    (let ((result (callback1-scheme-pointer p)))
      ;(print-str p)
;      (free p)
      p)))


(define (execute2)
  (let ((s 3))
    (let ((result (callback2 s)))
      result)))

(define (execute2-m)
  (let ((s 3))
    (let ((result (callback2-m s)))
      (free result))))


(define (execute3)
  b)

(define (execute4)
  (let ((s 3))
    (let ((result (callback4 s)))
      result)))

(define (execute5)
  (let ((s 3))
    (receive (i p) (callback5 s)
;     (print-str p)
      (free p)
      )))

(define (execute6)
  (let ((s 3))
    (receive (i p) (values 1 2)
      p
;     (print-str p)
      ;(free p)
      )))

(define (execute7)
  (let ((p (##sys#make-pointer)))
    (let ((result (callback7 p)))
;      (print-str p)
      (free p)
      result)))

;; the parallel to execute7 (pointer storage) using a named location
;; (basically, does the pointer unpacking/packing for you)
(define (execute1-m)
  (let-location ([p c-pointer])
    (let ((result (callback1-m #$p)))
      ;(print-str p)
      (free p)
      result)))

(define (g n) (if (fx= n 0) 'done (begin (execute)  (g (fx- n 1)))))
(define (h n) (if (fx= n 0) 'done (begin (execute2) (h (fx- n 1)))))
(define (j n) (if (fx= n 0) 'done (begin (execute3) (j (fx- n 1)))))
(define (k n) (if (zero? n) 'done (begin (execute4) (k (- n 1)))))
(define (l n) (if (zero? n) 'done (begin (execute5) (l (- n 1)))))
(define (m n) (if (zero? n) 'done (begin (execute6) (m (- n 1)))))
(define (h-m n) (if (fx= n 0) 'done (begin (execute2-m) (h-m (fx- n 1)))))
(define (e7 n) (if (fx= n 0) 'done (begin (execute7) (e7 (fx- n 1)))))
(define (e1-m n) (if (fx= n 0) 'done (begin (execute1-m) (e1-m (fx- n 1)))))
(define (e1-l n) (if (fx= n 0) 'done (begin (execute1-locative) (e1-l (fx- n 1)))))
(define (e1-sp n) (if (fx= n 0) 'done (begin (execute1-scheme-pointer) (e1-sp (fx- n 1)))))
(define (e1-spp n) (if (fx= n 0) 'done (begin (execute1-scheme-pointer-ptr) (e1-spp (fx- n 1)))))
(define (e1-spbv n) (if (fx= n 0) 'done (begin (execute1-scheme-pointer-bv) (e1-spbv (fx- n 1)))))


(define (z n) (if (fx= n 0) 'done (z (fx- n 1))))

;; -O2

#|
#;7> ,t (g 100000)                    #;17> ,t (g 1000000)          
   0.235 seconds elapsed                 1.435 seconds elapsed      
       0 seconds in (major) GC          3.e-03 seconds in (major) GC
       3 mutations                           3 mutations            
    1009 minor GCs                        1983 minor GCs            
       0 major GCs                           3 major GCs            

#;8> ,t (h 100000)
   0.095 seconds elapsed
       0 seconds in (major) GC
       3 mutations
     324 minor GCs
       0 major GCs
done
#;2> ,t (h-m 100000)                  [using malloc/free; 0.109 without the free]
   0.172 seconds elapsed              [using fixnum]
       0 seconds in (major) GC
       2 mutations
     472 minor GCs
       0 major GCs
done
#;3> ,t (j 100000)                    [0.064 using fixnum]
   0.081 seconds elapsed
       0 seconds in (major) GC
       2 mutations
     251 minor GCs
       0 major GCs
done
#;9> ,t (k 100000)
   0.131 seconds elapsed
       0 seconds in (major) GC
       3 mutations
     472 minor GCs
       0 major GCs
done
#;5> ,t (l 100000)
   0.454 seconds elapsed               [even without malloc/free, still > 0.400 s]
 2.1e-02 seconds in (major) GC
       2 mutations
    1545 minor GCs
      12 major GCs

;; Long exec time is due to receive.  Using values (no callback) only:
#;5> ,t (m 100000)
   0.408 seconds elapsed          [ up to 0.500 s ]
 2.2e-02 seconds in (major) GC
       2 mutations
     343 minor GCs
      11 major GCs

;;; Return malloced pointer value and free it, storage is a (make-pointer).
;; ,t (e7 100000)                               #;11> ,t (e7 1000000)         
   0.203 seconds elapsed  [0.141 w/o free]         1.153 seconds elapsed      
       0 seconds in (major) GC                    2.e-03 seconds in (major) GC
       2 mutations                                     3 mutations            
     692 minor GCs                                  3859 minor GCs            
       0 major GCs                                     1 major GCs            
;;; Return malloced pointer and free it, storage is a let-location.                                                                              
;; ,t (e1-m 100000)                             #;10> ,t (e1-m 1000000)       
   0.268 seconds elapsed                           1.661 seconds elapsed      
       0 seconds in (major) GC                    6.e-03 seconds in (major) GC
       3 mutations                                     2 mutations            
    1171 minor GCs                                  1122 minor GCs            
       0 major GCs                                     4 major GCs            

;; g using a make-string instead of a locative
                                                #;18> ,t (e1-l 1000000)       
                                                   2.095 seconds elapsed      
                                                  7.e-03 seconds in (major) GC
                                                       3 mutations            
                                                    2871 minor GCs            
                                                       4 major GCs            


;; g using make-string and a scheme-pointer (no locative)
                                                ,t (e1-sp 1000000)
                                                2.618 seconds elapsed
                                                1.561 seconds in (major) GC
                                                    2 mutations
                                                    2 minor GCs
             note this odd result! --------->    1201 major GCs                  

;; g using make-pointer and a scheme-pointer [fast!]
                                                 ,t (e1-spp 1000000)
                                                 0.729 seconds elapsed
                                                     0 seconds in (major) GC
                                                     3 mutations
                                                  5309 minor GCs
                                                     0 major GCs                              




;; bare loop
#;3> ,t (z 100000)
   0.025 seconds elapsed           [ 0.014 with -lambda-lift -disable-interrupts -unsafe ]
       0 seconds in (major) GC
       2 mutations
      77 minor GCs
       0 major GCs
done


|#