;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; very dodgy
;; generic constraints
;;
;; simply forces supplied specialisations
;; add to polys and remove gpoly
;;
;; for example
;;
;; (bind-func test:[!a,!a]*
;; (lambda (x) (* x x)))
;;
;; (constrain-genericfunc test [i32,i32]* [float,float]*)
;;
(define impc:ti:constrain-genericfunc
(lambda (sym . types)
;; (println 'impc:ti:constrain-genericfunc 'sym: sym types)
(if (not (impc:ti:genericfunc-exists? (string->symbol sym)))
(impc:compiler:print-missing-identifier-error sym "generic function")
(let ((printspec *impc:ti:print-code-specialization-compiles*))
(set! *impc:ti:print-code-specialization-compiles* #t)
(for-each
(lambda (t)
(if (regex:match? t "_poly_")
(set! t (cname-decode (cadr (regex:type-split t "_poly_")))))
(let ((etype (cname-encode t)))
(if (not (impc:ti:closure-exists? (string-append sym "_poly_" etype)))
(let* ((arity (impc:ir:get-arity-from-pretty-closure t))
(code (caddr (cadr (impc:ti:genericfunc-types (string->symbol sym) arity t))))
(pfunc (string->symbol (string-append sym "_poly_" etype))))
;; (println 'arity: arity 'code: code 'pfunc: pfunc)
;; pre-populate the closure cache for the new specialised func
(if (not (impc:ti:closure-exists? (symbol->string pfunc)))
(impc:ti:register-new-closure (symbol->string pfunc)
'()
*impc:default-zone-size*
""
code))
(set! code `(let ((,pfunc ,code)) ,pfunc))
(impc:ti:run pfunc code *impc:default-zone-size* #f #f (cons pfunc (string->symbol t)))
(impc:ti:register-new-polyfunc sym
(symbol->string pfunc)
(impc:ir:get-type-from-pretty-str t)
"")
(impc:ti:initialize-closure-with-new-zone (symbol->string pfunc)
*impc:default-zone-size*)
pfunc))))
types)
(set! *impc:ti:print-code-specialization-compiles* printspec)
(set! *impc:ti:genericfunc-cache*
(cl:remove-if (lambda (x)
(if (string=? (symbol->string (car x)) sym)
#t #f))
*impc:ti:genericfunc-cache*))
#t))))