impc:ti:reify-generic-type   scheme

Defined in:


;; this will basically try to turn xlist*##664 into "%xlist--adoOmdroIRU*"
;; 1. try to reify the generic type (vs) using (vars)
;; 2. check against specifications of the polytype that may already exist
;; 3. if 2. exists then return the typename of the specification of the generic type
;; 4. if 2. does not exist then create specific type, add it to type polys and return it
;; 5. if type cannot be unified throw compiler error.
(define impc:ti:reify-generic-type
  (lambda (vs vars all-vs)
    ;; (println 'reify-generic-type: vs) ;; (symbol? vs)
    ;; (println 'vars: vars)
    ;; (println 'all-vs: all-vs)
    ;; (println 'gtype: vs 'vars: vars 'allvs: all-vs)
    ;; (println '-> (assoc-strcmp vs vars))
    (if (and (assoc-strcmp vs vars)
             (not (null? (cdr (assoc-strcmp vs vars))))
             (impc:ir:type? (cadr (assoc-strcmp vs vars))))
        (cadr (assoc-strcmp vs vars))
        (if (and (symbol? vs)
                 (string-contains? (symbol->string vs) "##")
                 (not (regex:match? (symbol->string vs) "^!")))
            (let* ((rsplit1a (regex:split (symbol->string vs) "##")) ;\\$\\$\\$"))
                   (rsplit1 (if (string-contains? (car rsplit1a) "{")
                                (cons (impc:ti:maximize-generic-type (car rsplit1a)) (cdr rsplit1a))
                   (gnum (if (> (length rsplit1) 1) (cadr rsplit1) #f))
                   (rsplit2 (impc:ti:split-namedtype (car rsplit1)))
                   (gpolyname (car rsplit2))
                   (gtype-explicit (if (null? (cdr rsplit2)) '()
                                       (impc:ir:get-base-type (cadr rsplit2))))
                   ;; (llllll (println 'gpolyname: gpolyname 'gtype: gtype-explicit))
                   (spec (if (> (length rsplit2) 1) (cadr rsplit2) #f))
                   (ptrdepth (impc:ir:get-ptr-depth (car rsplit1)))
                   (elements '())
                   (validelements? #f)
                   (t1 (symbol->string (impc:ti:get-generictype-candidate-types (string->symbol (impc:ir:get-base-type gpolyname)))))
                   (gtype t1))
              ;; (println 'reifyts gtype 'vs gtype-explicit)
              (if (and (not (null? gtype-explicit))
                       (impc:ti:bang-type? gtype-explicit))
                  (set! t1 gtype-explicit))
              ;; go through and check that there are NO non-explicit gpoly's at top level of type
              ;; (println '%%%%%%%%%%%%%%%%%%%%%%%% gnum)
              ;; (println '->A: t1 'gtype: gtype 'explict: gtype-explicit 'ptrdepth: ptrdepth 'gpoly: gpolyname 'gnum: gnum)
              ;; (println '->VARS: vars 'all-vs all-vs)
              ;; attempt to expand any <!head,xlist*> into <i64,xlist*>
              (set! t1 (impc:ti:reify-generic-type-expand t1 gnum spec vars))
              ;; (println '->B: t1 'ptrdepth: ptrdepth 'gpoly: gpolyname)
              (let* ((s1 (regex:replace t1 "\\<(.*)\\>?.*" "$1"))
                     (es2 (impc:ir:get-type-joiner
                           (cl:remove-if (lambda (x) (string=? x ""))
                                         ;;  (regex:match? x gpolyname)))
                                         (regex:match-all s1 impc:ir:regex-tc-or-a))))
                     (es (map (lambda (x) (if (string? (impc:ir:get-type-from-pretty-str x))
                                         (impc:ir:get-type-from-pretty-str x) x))
                     (tr (cl:remove-if (lambda (x)
                                         ;; (println 'x: x 'gpolyname: gpolyname)
                                         (if (and (not (regex:match? x "^(<|\\[)"))
                                                  (string-contains? x ":"))
                                             (let ((p (regex:type-split x ":")))
                                               (or (string=? (car p) gpolyname)
                                                   (impc:ir:type? (impc:ir:get-type-from-pretty-str (cadr p)))))
                                             (if (regex:match? x "^!")
                                                 (or (regex:match? x (string-append gpolyname "([{},:*#]|$)"))
                                                     (impc:ir:type? (impc:ir:get-type-from-pretty-str x))))))
                                       ;; (impc:ir:type? x)))))
                (if (null? tr) (set! validelements? #t))
                (set! elements es))
              ;; (println '->C: t1 (impc:ti:type-normalize t1))
              ;; (println 'elements: elements 'tr: validelements? 't1: t1 'vs: vs (regex:match? t1 "!"))
              (if (and validelements?
                       (not (string-contains? t1 "!")))
                  (let* ((base (impc:ir:get-base-type gpolyname)) ;(symbol->string vs)))
                         ;; (newname (string-append base "_poly_" (cname-encode t1)))
                         (newname (string-append base "_poly_" (impc:ti:generate-generic-type-cname t1 gtype)))
                         (max (impc:ti:maximize-generic-type (impc:ir:pretty-print-type (string-append "%" newname))))
                         (newtype1 t1) ;;(regex:replace t2 (string-append base "([^-][^-])") (string-append newname "$1")))
                         (newtype2 (cons 14 (map (lambda (x)
                                                   (if (string? (impc:ir:get-type-from-pretty-str x))
                                                       (impc:ir:get-type-from-pretty-str x)
                                                       (if (regex:match? x (string-append gpolyname "([{},:*#]|$)"))
                                                           (impc:ir:pointer++ (string-append "%" newname) (impc:ir:get-ptr-depth x))
                                                           (impc:ir:get-type-from-pretty-str x))))
                         (newtype3 (impc:ir:get-type-str newtype2)))
                    ;; (println 'base: base 't1: t1 'gt: gtype 'nt1 newtype1 'nt2 newtype2 'nt3 newtype3 'nn: newname)
                    ;; ok now we have a type we need to add it to llvm and
                    ;; polytype
                    ;; (println 'newtype! newname 'totype: newtype3)
                    (if (not (impc:ti:namedtype-exists? newname))
                        (begin ;; if this is a new reification of a generic type then ...
                          ;; (println 'compile-type! newname 'totype: newtype3 'type: t1 'gt: gtype )
                          (if (llvm:compile-ir (string-append "%" newname " = type " newtype3))
                                (impc:ti:register-new-polytype base
                                ;; we should probably also build dataconstructors for the new
                                ;; concrete type?? (at least for printing reasons)
                                ;; because impc:ti:compile-type-dataconstructors needs to be called from
                                ;; the top level, we should call use callback to add to queue
                                (callback (now) 'impc:ti:compile-type-dataconstructors (string->symbol newname) newtype1 #f #t #t #t)
                    (let ((rettype (impc:ir:pointer++ (string-append "%" newname) ptrdepth)))
                      ;; (println 'oldvs: vs)
                      ;; (set! vs (string->symbol
                      ;;           (string-append base ":" gtype
                      ;;                          (apply string-append (make-list ptrdepth "*"))
                      ;;                          "##" gnum)))
                      ;; (println 'updatevar: vs 'with rettype)
                      (impc:ti:update-var vs vars '() rettype)

Back to Index

Similar Entries