Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

a bunch of generics fixes

  • Loading branch information...
commit 4ddcf7c740e477b38f97768c1393768c3d8f38a2 1 parent 80a3f80
@digego authored
Showing with 49 additions and 39 deletions.
  1. +18 −23 examples/extempore_lang.scm
  2. +31 −16 runtime/llvmti.scm
View
41 examples/extempore_lang.scm
@@ -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)))
@@ -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)
@@ -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))))
@@ -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*>)
@@ -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)))
View
47 runtime/llvmti.scm
@@ -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
@@ -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?)
@@ -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)))
@@ -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)))))
@@ -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))
)
Please sign in to comment.
Something went wrong with that request. Please try again.