Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-14 08:17:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Enable well-known-function code

Browse source
This commit is contained in:
Justin Ethier 2018-09-26 13:18:52 -04:00
parent 31e99da295
commit e49a319ec6
1 changed files with 46 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

78
scheme/cyclone/cgen.sld
View file

@ -882,7 +882,8 @@
((tagged-list? '%closure-ref fun) ((tagged-list? '%closure-ref fun)
(let* ((cfun (c-compile-args (list (car args)) append-preamble " " cont ast-id trace cps?)) (let* ((cfun (c-compile-args (list (car args)) append-preamble " " cont ast-id trace cps?))
(this-cont (c:body cfun)) (this-cont (c:body cfun))
(cargs (c-compile-args (cdr args) append-preamble " " this-cont ast-id trace cps?))) (cargs (c-compile-args (cdr args) append-preamble " " this-cont ast-id trace cps?))
(num-cargs (c:num-args cargs)))
(cond (cond
((not cps?) ((not cps?)
(c-code (c-code
@ -893,33 +894,46 @@
(c:body cargs) (c:body cargs)
");"))) ");")))
(else (else
;;TODO: need to handle well-known functions: ;;TODO: Consolidate with corresponding %closure code??
; (let* ((wkf (well-known-lambda (car args)))
; (fnc (if wkf (adb:get/default (ast:lambda-id wkf) #f) #f))
; )
; (when (and wkf fnc
; (adbf:well-known fnc) ;; not really needed
; (equal? (adbf:closure-size fnc) 1))
; (trace:error `(JAE found well-known lambda in closure-ref call
; ,(car args)
; ,wkf
;;TODO: this is not going to work, we are going to need to use ast:lambda-id instead of
;;an allocation ID. make that change in allocate-lambda, disable all WKL code, and make
;;sure it is stable before proceeding...
; cgen id ,(ast:lambda-id wkf)
; )))
; )
(set-c-call-arity! (c:num-args cargs)) (set-c-call-arity! (c:num-args cargs))
(c-code (let* ((wkf (well-known-lambda (car args)))
(string-append (fnc (if wkf (adb:get/default (ast:lambda-id wkf) #f) #f))
(c:allocs->str (c:allocs cfun) "\n") )
(c:allocs->str (c:allocs cargs) "\n") (cond
"return_closcall" (number->string (c:num-args cargs)) ((and wkf fnc
"(data," (adbf:well-known fnc) ;; not really needed
this-cont (equal? (adbf:closure-size fnc) 1))
(if (> (c:num-args cargs) 0) "," "") (let* ((lid (ast:lambda-id wkf))
(c:body cargs) (c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))
");")))))) (c-lambda-fnc-gc-ret-str (string-append "__lambda_gc_ret_" (number->string lid)))
)
(c-code
(string-append
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_direct_with_clo" (number->string num-cargs)
"(data,"
this-cont
","
c-lambda-fnc-gc-ret-str
","
c-lambda-fnc-str
(if (> num-cargs 0) "," "")
(c:body cargs)
");"))
)
)
(else
(c-code
(string-append
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_closcall" (number->string (c:num-args cargs))
"(data,"
this-cont
(if (> (c:num-args cargs) 0) "," "")
(c:body cargs)
");")))))))))
((tagged-list? '%closure fun) ((tagged-list? '%closure fun)
(let* ((cfun (c-compile-closure (let* ((cfun (c-compile-closure
@ -943,10 +957,10 @@
;need to use (well-known-lambda) to check the ref to see if it is a WKL. ;need to use (well-known-lambda) to check the ref to see if it is a WKL.
;if so, lookup ast and use cgen-id to map back to emit the lambda_gc_ret there ;if so, lookup ast and use cgen-id to map back to emit the lambda_gc_ret there
(with-fnc (ast:lambda-id (closure->lam fun)) (lambda (fnc) (with-fnc (ast:lambda-id (closure->lam fun)) (lambda (fnc)
(if (and #f (if (and ;#f
(adbf:well-known fnc) (adbf:well-known fnc)
(equal? (adbf:closure-size fnc) 1)) (equal? (adbf:closure-size fnc) 1))
(let* ((lid (adbf:cgen-id fnc)) (let* ((lid (ast:lambda-id (closure->lam fun)))
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid))) (c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))
(c-lambda-fnc-gc-ret-str (string-append "__lambda_gc_ret_" (number->string lid))) (c-lambda-fnc-gc-ret-str (string-append "__lambda_gc_ret_" (number->string lid)))
) )
@ -1249,7 +1263,7 @@
(with-fnc ast-id (lambda (fnc) (with-fnc ast-id (lambda (fnc)
(trace:info `(c-compile-closure-element-ref ,ast-id ,var ,idx ,fnc)) (trace:info `(c-compile-closure-element-ref ,ast-id ,var ,idx ,fnc))
(cond (cond
((and #f ((and ;#f
(adbf:well-known fnc) (adbf:well-known fnc)
;(pair? (adbf:all-params fnc)) ;(pair? (adbf:all-params fnc))
(equal? (adbf:closure-size fnc) 1)) (equal? (adbf:closure-size fnc) 1))
@ -1291,7 +1305,7 @@
(lid (allocate-lambda lam (c-compile-lambda lam trace cps?) cps?)) (lid (allocate-lambda lam (c-compile-lambda lam trace cps?) cps?))
(use-obj-instead-of-closure? (use-obj-instead-of-closure?
(with-fnc (ast:lambda-id lam) (lambda (fnc) (with-fnc (ast:lambda-id lam) (lambda (fnc)
(and #f (and ;#f
(adbf:well-known fnc) ;; Only optimize well-known functions (adbf:well-known fnc) ;; Only optimize well-known functions
;(equal? (length free-vars) 1) ;; Sanity check ;(equal? (length free-vars) 1) ;; Sanity check
(equal? (adbf:closure-size fnc) 1) ;; From closure conv (equal? (adbf:closure-size fnc) 1) ;; From closure conv
@ -1657,7 +1671,7 @@
;; (equal? (adbf:closure-size fnc) 1)) ;; (equal? (adbf:closure-size fnc) 1))
;; (trace:error `(JAE ,(car l) ,l ,fnc))) ;; (trace:error `(JAE ,(car l) ,l ,fnc)))
(when (and #f (when (and ;#f
(adbf:well-known fnc) (adbf:well-known fnc)
(equal? (adbf:closure-size fnc) 1)) (equal? (adbf:closure-size fnc) 1))
;(trace:error `(JAE ,(car l) ,l ,fnc)) ;(trace:error `(JAE ,(car l) ,l ,fnc))