impc:ti:run   scheme

Defined in:


(define impc:ti:run
  (lambda (symname code zone-size poly static . args)
    ;; (println '-----------> 'impc:ti:run: symname 'poly: poly 'static: static)
    ;; (println 'code: code)
    ;; (println 'args: args)
    (set! *impc:ir:sym-name-stack* '())
    (set! *impc:ir:ls_var* '())
    (set! *impc:ti:bound-lambdas* '())
    (set! *impc:ti:generic-type-mappings* '())
    (set! *impc:ti:nativef-generics-recurse-test* 0)
    ;; adhoc
    (set! *impc:ti:adhoc-cnt* (+ *impc:ti:adhoc-cnt* 1))
    (define adhoc-poly-name symname)
    (define adhoc-poly-name-string (symbol->string symname))
    (if (and poly ;*impc:ti:implicit-adhoc-compiles*
             (not (regex:match? adhoc-poly-name-string "(_poly_|_adhoc_)")))
          (set! symname (string->symbol (string-append adhoc-poly-name-string
                                                       (number->string *impc:ti:adhoc-cnt*))))
          (if (not (null? args))
              (set! args (replace-all args (list (cons adhoc-poly-name symname)))))
          (set! code (replace-all code (list (cons adhoc-poly-name symname))))))
    ;; don't want type checking to find existing native versions!
    (if (and *impc:compile* (not static))
          (llvm:erase-function (string-append (symbol->string symname) "_setter"))
          (llvm:erase-function (string-append (symbol->string symname) "_maker"))))
    (let* ((symname-string (symbol->string symname))
           (oldsymname-string symname-string)
           ;(c code)
           (shadows (impc:ti:rename-all-shadow-vars symname code '()))
           (c1 (impc:ti:get-var-types shadows)) ;; this is a cons pairof (ast . types)
           (ta (impc:ti:first-transform (car c1) #t)) ;; car is ast
           ;; might be over kill doing shadow vars twice!
           (shadow-code (impc:ti:rename-all-shadow-vars symname ta '()))
           (c2 (impc:ti:get-var-types shadow-code)) ;; it is possible for macros in the first-transform to introduce new var-types
           (ccc (append (cdr c2) (cdr c1)))
           (cc (impc:ti:expand-generic-types ccc))
           (t1 (car c2))
           (t2 (impc:ti:mark-returns t1 symname #f #f #f))
           (t3 (impc:ti:closure:convert t2 (list symname)))
           (vars (map (lambda (x) (list x)) (impc:ti:find-all-vars t3 '())))
           ;; (llllllllll (begin (println 'vars: vars) (error)))
           (forced-types (apply impc:ti:handle-forced-types t1 (append cc args)))
           (t4 (impc:ti:coercion-run t2 forced-types)) ;; t4 and t5 are optional
           (typespre (impc:ti:run-type-check vars forced-types t4))
           (t5 (impc:ti:closure:convert t4 (list symname)))
           (types (impc:ti:type-normalize typespre))
           (newast '()))
      ;; (println 'forced: forced-types)
      ;; (println 'types-post: types)
      ;; (println 'run: (impc:ti:unity? types))
      ;; (println 'newast: newast)
      ;; (println 'forced: forced-types)
      ;; (println 'times: (- ct2 ct1) (- ct3 ct2) (- ct4 ct3) (- ct5 ct4) (- ct6 ct5) (- ct7 ct6) (- ct8 ct7) (- ct9 ct8) (- ct10 ct9) (- ct11 ct10))

Back to Index

Similar Entries