Skip to content

Commit

Permalink
a bunch of generics fixes
Browse files Browse the repository at this point in the history
  • Loading branch information
@digego
digego committed Mar 30, 2012
1 parent 80a3f80 commit 4ddcf7c
Show file tree
Hide file tree
Showing 2 changed files with 49 additions and 39 deletions.
41 changes: 18 additions & 23 deletions examples/extempore_lang.scm
View file
Expand Up @@ -940,7 +940,7 @@
(define procs
(map (lambda (n p)
(ipc:new n p)
(ipc:bind-func n 'work)
(ipc:definec n 'work)
n)
(list "proc-a" "proc-b" "proc-c" "proc-d" "proc-e")
(list 7097 7096 7095 7094 7093)))
Expand Down Expand Up @@ -1049,7 +1049,7 @@
(test44 "extempore's" "polymorphism" "rocks")


;; polys can also specialize
;; polys can Also specialize
;; on the return type
(bind-func my-func-4
(lambda (a:double)
Expand All @@ -1063,6 +1063,8 @@
(bind-poly sqrd my-func-5)

;; specialize on [i64,double]*
;;
;; THIS BROKEN AT THE MOMENT!
(bind-func test45
(lambda (a:double)
(+ 1.0 (sqrd a))))
Expand All @@ -1083,12 +1085,14 @@

(bind-typevar num i64 i32 i8 i1 float double)

;; compare this
(bind-func mul
(lambda (a:num b:num)
(* a b)))

;; to this
(bind-func sum
(lambda (a:num b:num)
(lambda (a:num b)
(+ a b)))

(bind-type i64list <i64,i64list*>)
Expand All @@ -1115,31 +1119,22 @@
(lambda (b:numlists)
(tref b 1)))

(bind-func ttt4
(lambda ()
(let ((n1 (bitcast null f64list*)))
(set! n1 (mcons 3.0 n1))
(mcar n1))))

(bind-func test48
(lambda ()
(let ((n1 (bitcast null f64list*)))
(set! n1 (mcons 3.0 n1))
;(printf "%f\n" (mcar n1))
(mcar n1))))
(lambda (a:i64list*)
(if (null? a)
(begin (printf "done\n") 1)
(begin (printf "%lld\n" (mcar a))
(test48 (mcdr a))))))

(bind-func test49
(lambda ()
(let ((n1 (alloc i64list))
(lst (mcons 1 (mcons 2 (mcons 3 n1)))))
(test48 lst))))

(bind-func test47
(lambda (x:numz y)
(* x y)))
(test49) ;; 1 > 2 > 3 > done

(bind-func test48
(lambda (a:numz)
(test47 a a)))

(bind-func test49
(lambda (a)
(test47 a 5)))



Expand Down
47 changes: 31 additions & 16 deletions runtime/llvmti.scm
View file
Expand Up @@ -1727,16 +1727,16 @@
;; first check return type of car ast (which will be a closure)
;; then check against it's arg types
(let ((type (impc:ti:type-check (car ast) vars kts request?)))
;(print 'closure-in-first-pos: ast 'type: type)
;(println 'closure-in-first-pos: ast 'type: type)
(if (not (impc:ir:type? type))
(set! type (car type)))
(if (<> (+ *impc:ir:closure* *impc:ir:pointer* *impc:ir:pointer*) (car type))
(begin (print-error 'Invalid 'Expression ast) (error ""))
(begin (map (lambda (a b)
(impc:ti:type-check b vars kts a))
(cddr type)
(cdr ast))
(cadr type))))))
(if (<> (+ *impc:ir:closure* *impc:ir:pointer* *impc:ir:pointer*) (car type))
(begin (print-error 'Invalid 'Expression ast) (error ""))
(begin (map (lambda (a b)
(impc:ti:type-check b vars kts a))
(cddr type)
(cdr ast))
(cadr type))))))

;; vars is statefull and will be modified in place
(define impc:ti:type-check
Expand Down Expand Up @@ -1794,9 +1794,10 @@
((and (list? ast) (member (car ast) '(set!))) (impc:ti:set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(ret->))) (impc:ti:ret-check ast vars kts request?))
((and (list? ast) (assoc (car ast) vars)) (impc:ti:closure-call-check ast vars kts request?))
((and (list? ast) (list? (car ast))) (impc:ti:closure-in-first-position ast vars kts request?))
((and (list? ast) (list? (car ast))) (impc:ti:closure-in-first-position ast vars kts request?))
((and (list? ast) ;; this is here to check against closures as global vars (i.e. not in local environment)
(llvm:get-globalvar (symbol->string (car ast)))
(symbol? (car ast))
(llvm:get-globalvar (symbol->string (car ast)))
(impc:ir:closure? (impc:ir:get-type-from-str (llvm:get-global-variable-type (symbol->string (car ast))))))
(impc:ti:closure-call-check ast vars kts request?))
(else (impc:ti:join (impc:ti:type-check (car ast) vars kts request?)
Expand Down Expand Up @@ -1931,8 +1932,10 @@
(assoc (cadr ast) types))))))
;; inject polymorphic functions
((impc:ir:poly-types (car ast))
(let* ((vars (cl:tree-copy types))
(let* ((vars (cl:tree-copy types))
;(llll (println 'vars: vars))
(kts (map (lambda (t) (car t)) types))
;(lllll (println 'kts: kts))
(polyargs (map (lambda (arg)
;(println 'arg: arg)
(let ((res (impc:ti:type-check arg vars kts #f)))
Expand All @@ -1942,20 +1945,32 @@
res
;(print-error 'Compiler 'Error: 'unable 'to 'resolve 'polymorphic 'function: ast)
(if (atom? res) res (car res)))))
(cdr ast)))
(cdr ast)))
;(lllllll (println 'polyartgs: polyargs))
(retargs (impc:ti:type-check ast vars kts #f))
(rets (if (null? prev) retargs (impc:ti:type-check (car prev) vars kts retargs))))
;(println 'polyargs: polyargs 'retargs: retargs 'rets: rets)
;(lllllllllll (println 'retargs: retargs 'prev: prev))
(rets retargs))
;; (rets (if (null? prev)
;; retargs
;; (impc:ti:type-check (car prev) vars kts retargs))))
;; (cl:remove-duplicates (append retargs
;; (if (and (list? (car prev))
;; (equal? (caar prev) 'clrun->))
;; '()
;; ;'()))))))
;; (impc:ti:type-check (car prev) vars kts retargs)))))))
;(println 'polyargs: polyargs 'retargs: retargs 'rets: rets 'prev: prev)
(let* ((polys (map (lambda (pret)
(let* ((polyf (cons (+ *impc:ir:closure*
*impc:ir:pointer*
*impc:ir:pointer*)
(cons pret polyargs)))
(polyfunc (impc:ir:check-poly (car ast) polyf)))
;(println 'polyf: polyf 'polyfunc: polyfunc)
polyfunc))
rets))
(validpolys (remove #f polys)))
;(println 'polys: validpolys symname (cdr ast))
;(println 'all: polys 'polys: validpolys symname (cdr ast))
(let ((rr (impc:ti:add-types-to-source symname (cdr ast) types envvars)))
;; take the first valid polymorphic dispatch
(cons (car validpolys) rr)))))
Expand Down Expand Up @@ -2284,7 +2299,7 @@
(t5 (impc:ti:coercion-run t3 forced-types)) ;; also there is doubling dipping here :(
;(ct9 (now))
(types (impc:ti:run-type-check vars forced-types t4))
;(ct10 (now))
;(ct10 (now))
(newast (impc:ti:add-types-to-source symname t5 (cl:tree-copy types) (list)))
;(ct11 (now))
)
Expand Down

0 comments on commit 4ddcf7c

Please sign in to comment.