impc:ir:compiler:callback   scheme

;;
;; Compiler callback wraps a functions arguments into a struct
;; which is heap allocated (i.e. malloc).  Additionally a special
;; _callback function (created for every closure on bind-func)
;; is also added to the struct.  The struct is then sent to
;; the standard scheme scheduler which then passes the
;; struct to the embedded _callback function at the correct time.
;;
(define impc:ir:compiler:callback
  (lambda (ast types)
    (let* ((os (make-string 0))
           (timestr (impc:ir:compiler (cadr ast) types))
           (time (impc:ir:gname))
           (fname (symbol->string (caddr ast)))
           (ftypes (if (assoc-strcmp (caddr ast) types)
                       (map (lambda (a) (impc:ir:get-type-str a)) (cddr (assoc-strcmp (caddr ast) types)))
                       (impc:ti:get-closure-arg-types fname)))
           (callback_func_name_str (impc:ir:compiler (string-append fname "_callback") types))
           (callback_func_name (impc:ir:gname))
           (closure_db_call (llvm:get-function (string-append fname "_callback")))
           (cbzonestr (impc:ir:compiler (cadddr ast) types))
           (cbzone (impc:ir:gname))
           (astargs (cddddr ast))
           (args (map (lambda (a hint)
                        (cons (impc:ir:compiler a types (impc:ir:get-type-from-str hint)) (impc:ir:gname)))
                      astargs
                      (cdr ftypes)))
           (struct_type1 (string-append "{ void(i8*, %mzone*)*, i8*, %mzone*}*"))
           (struct_type2 (if (null? args)
                             ""
                             (string-append "{ " (cadr (cdr (car args)))
                                            (apply string-append  ;; void ptr first to hold "_callback" function
                                                   (map (lambda (a) (string-append ", " (cadr (cdr a)))) (cdr args)))
                                            "}*")))
           (total_size1 (* (/ (sys:pointer-size) 8) 3))
           ;; this is the last usage of impc:ir:get-type-size in llvmir.xtm - need to get rid of it as well
           (total_size2 (apply + (map (lambda (a) (impc:ir:get-type-size (cadr (cdr a)))) args))))
      (if (not (impc:ir:fixed-point? (cadr time)))
          (impc:compiler:print-compiler-error "arg 1 of callback must be an i64 time value"))
      (if (<> (length args) (length (cdr ftypes)))
          (impc:compiler:print-bad-arity-error ast))