Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-23 20:15:05 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

WIP

Browse source
This commit is contained in:
Justin Ethier 2017-04-18 19:14:52 +00:00
parent 021113ced4
commit bd9119c274
1 changed files with 45 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
scheme/cyclone/cgen.sld
View file

@ -324,7 +324,7 @@
; IR (2): ; IR (2):
((tagged-list? '%closure exp) ((tagged-list? '%closure exp)
(c-compile-closure exp append-preamble cont trace)) (c-compile-closure exp append-preamble cont trace cps?))
; Global definition ; Global definition
((define? exp) ((define? exp)
(c-compile-global exp append-preamble cont trace)) (c-compile-global exp append-preamble cont trace))
@ -334,7 +334,7 @@
((tagged-list? 'lambda exp) ((tagged-list? 'lambda exp)
(c-compile-exp (c-compile-exp
`(%closure ,exp) `(%closure ,exp)
append-preamble cont trace #t)) append-preamble cont trace cps?))
; Application: ; Application:
((app? exp) (c-compile-app exp append-preamble cont trace cps?)) ((app? exp) (c-compile-app exp append-preamble cont trace cps?))
@ -689,7 +689,7 @@
(fun (app->fun exp))) (fun (app->fun exp)))
(cond (cond
((lambda? fun) ((lambda? fun)
(let* ((lid (allocate-lambda (c-compile-lambda fun trace))) ;; TODO: pass in free vars? may be needed to track closures (let* ((lid (allocate-lambda (c-compile-lambda fun trace #t))) ;; TODO: pass in free vars? may be needed to track closures
;; properly, wait until this comes up in an example ;; properly, wait until this comes up in an example
(this-cont (string-append "__lambda_" (number->string lid))) (this-cont (string-append "__lambda_" (number->string lid)))
(cgen (cgen
@ -779,7 +779,7 @@
((tagged-list? '%closure fun) ((tagged-list? '%closure fun)
(let* ((cfun (c-compile-closure (let* ((cfun (c-compile-closure
fun append-preamble cont trace)) fun append-preamble cont trace cps?))
(this-cont (string-append "(closure)" (c:body cfun))) (this-cont (string-append "(closure)" (c:body cfun)))
(cargs (c-compile-args (cargs (c-compile-args
args append-preamble " " this-cont trace cps?)) args append-preamble " " this-cont trace cps?))
@ -856,18 +856,17 @@
; ,(define-c->inline-var exp) ; ,(define-c->inline-var exp)
; ,(prim:udf? (define-c->inline-var exp)) ; ,(prim:udf? (define-c->inline-var exp))
; )) ; ))
; (if (and (lambda? body) (if (and (lambda? body)
; (prim:udf? (define-c->inline-var exp))) (prim:udf? (define-c->inline-var exp)))
; (add-global (add-global
; (define-c->inline-var exp) (define-c->inline-var exp)
; #t ;; always a lambda #t ;; always a lambda
; (c-code/vars "TODO" (list "TODO")) ;; Temporary testing! (c-compile-exp
;; (c-compile-exp body append-preamble cont
;; body append-preamble cont (st:add-function! trace var)
;; (st:add-function! trace var) #f ;; inline, so disable CPS on this pass
;; #f ;; inline, so disable CPS on this pass )
;; ) ))
; ))
(c-code/vars "" (list "")))) (c-code/vars "" (list ""))))
@ -949,12 +948,15 @@
; lambdas : alist[lambda-id,string -> string] ; lambdas : alist[lambda-id,string -> string]
(define lambdas '()) (define lambdas '())
(define inline-lambdas '())
; allocate-lambda : (string -> string) -> lambda-id ; allocate-lambda : (string -> string) -> lambda-id
(define (allocate-lambda lam) (define (allocate-lambda lam . cps?)
(let ((id num-lambdas)) (let ((id num-lambdas))
(set! num-lambdas (+ 1 num-lambdas)) (set! num-lambdas (+ 1 num-lambdas))
(set! lambdas (cons (list id lam) lambdas)) (set! lambdas (cons (list id lam) lambdas))
(if (equal? cps? '(#f))
(set! inline-lambdas (cons id inline-lambdas)))
id)) id))
; get-lambda : lambda-id -> (symbol -> string) ; get-lambda : lambda-id -> (symbol -> string)
@ -1029,7 +1031,7 @@
;; the closure. The closure conversion phase tags each access ;; the closure. The closure conversion phase tags each access
;; to one with the corresponding index so `lambda` can use them. ;; to one with the corresponding index so `lambda` can use them.
;; ;;
(define (c-compile-closure exp append-preamble cont trace) (define (c-compile-closure exp append-preamble cont trace cps?)
(let* ((lam (closure->lam exp)) (let* ((lam (closure->lam exp))
(free-vars (free-vars
(map (map
@ -1042,7 +1044,7 @@
(mangle free-var))) (mangle free-var)))
(closure->fv exp))) ; Note these are not necessarily symbols, but in cc form (closure->fv exp))) ; Note these are not necessarily symbols, but in cc form
(cv-name (mangle (gensym 'c))) (cv-name (mangle (gensym 'c)))
(lid (allocate-lambda (c-compile-lambda lam trace))) (lid (allocate-lambda (c-compile-lambda lam trace cps?) cps?))
(macro? (assoc (st:->var trace) (get-macros))) (macro? (assoc (st:->var trace) (get-macros)))
(call/cc? (and (equal? (car trace) "scheme/base.sld") (call/cc? (and (equal? (car trace) "scheme/base.sld")
(equal? (st:->var trace) 'call/cc))) (equal? (st:->var trace) 'call/cc)))
@ -1120,18 +1122,28 @@
"")))))) ""))))))
; c-compile-lambda : lamda-exp (string -> void) -> (string -> string) ; c-compile-lambda : lamda-exp (string -> void) -> (string -> string)
(define (c-compile-lambda exp trace) (define (c-compile-lambda exp trace cps?)
(let* ((preamble "") (let* ((preamble "")
(append-preamble (lambda (s) (append-preamble (lambda (s)
(set! preamble (string-append preamble " " s "\n"))))) (set! preamble (string-append preamble " " s "\n")))))
(let* ((formals (c-compile-formals (let* ((formals (c-compile-formals
(lambda->formals exp) (if (not cps?)
;; Ignore continuation (k) arg for non-CPS funcs
(cdr (lambda->formals exp))
(lambda->formals exp))
(lambda-formals-type exp))) (lambda-formals-type exp)))
(tmp-ident (if (> (length (lambda-formals->list exp)) 0) (tmp-ident (if (> (length (lambda-formals->list exp)) 0)
(mangle (if (pair? (lambda->formals exp)) (mangle (if (pair? (lambda->formals exp))
(car (lambda->formals exp)) (car (lambda->formals exp))
(lambda->formals exp))) (lambda->formals exp)))
"")) ""))
(return-type
(if cps? "void" "object"))
(arg-argc (if cps? "int argc, " ""))
(arg-closure
(if cps?
"closure _"
"object ptr"))
(has-closure? (has-closure?
(and (and
(> (string-length tmp-ident) 3) (> (string-length tmp-ident) 3)
@ -1141,8 +1153,8 @@
(if has-closure? (if has-closure?
"" ""
(if (equal? "" formals) (if (equal? "" formals)
"closure _" ;; TODO: seems wrong, will GC be too aggressive arg-closure
"closure _,")) ;; due to missing refs, with ignored closure? (string-append arg-closure ",")))
formals)) formals))
(env-closure (lambda->env exp)) (env-closure (lambda->env exp))
(body (c-compile-exp (body (c-compile-exp
@ -1153,8 +1165,8 @@
#t))) #t)))
(cons (cons
(lambda (name) (lambda (name)
(string-append "static void " name (string-append "static " return-type " " name
"(void *data, int argc, " "(void *data, " arg-argc
formals* formals*
") {\n" ") {\n"
preamble preamble
@ -1330,6 +1342,12 @@
(number->string (car l)) (number->string (car l))
(cadadr l) (cadadr l)
" ;")) " ;"))
((member (car l) inline-lambdas)
(emit*
"static object __lambda_"
(number->string (car l)) "(void *data, "
(cdadr l)
") ;"))
(else (else
(emit* (emit*
"static void __lambda_" "static void __lambda_"
@ -1362,6 +1380,8 @@
(car (cddadr l)) (car (cddadr l))
" }" " }"
)) ))
((member (car l) inline-lambdas)
(emit ((caadr l) (string-append "__lambda_" (number->string (car l))))))
(else (else
(emit ((caadr l) (string-append "__lambda_" (number->string (car l)))))))) (emit ((caadr l) (string-append "__lambda_" (number->string (car l))))))))
lambdas) lambdas)