mirror of
https://github.com/justinethier/cyclone.git
synced 2025-07-15 08:47:35 +02:00
Merge branch 'ast3-dev'
This commit is contained in:
commit
61cdf4ea5c
7 changed files with 177 additions and 101 deletions
12
CHANGELOG.md
12
CHANGELOG.md
|
@ -1,6 +1,16 @@
|
|||
# Changelog
|
||||
|
||||
## 0.9.3 - TBD
|
||||
## 0.9.3 - TBD
|
||||
|
||||
Features
|
||||
|
||||
- Allow pretty printing of bytevectors.
|
||||
- Internal change to the compiler - preserve lambda AST forms throughout compilation process. This should make it easier to implement certain optimizations in future releases.
|
||||
|
||||
Bug Fixes
|
||||
|
||||
- Fix `input-port?`, `output-port?`, `input-port-open?`, and `output-port-open?` to return `#f` instead of raising an error when a non-port object is passed.
|
||||
- Fix overflow detection when performing fixnum multiplication to avoid undefined behavior in the C runtime.
|
||||
|
||||
## 0.9.2 - August 26, 2018
|
||||
|
||||
|
|
12
cyclone.scm
12
cyclone.scm
|
@ -432,7 +432,7 @@
|
|||
(wrap-mutables expr globals))
|
||||
input-program))
|
||||
(trace:info "---------------- after wrap-mutables:")
|
||||
(trace:info input-program) ;pretty-print
|
||||
(trace:info (ast:ast->pp-sexp input-program))
|
||||
|
||||
(set! input-program
|
||||
(map
|
||||
|
@ -441,17 +441,15 @@
|
|||
((define? expr)
|
||||
;; Global
|
||||
`(define ,(define->var expr)
|
||||
,@(caddr (closure-convert (define->exp expr) globals *optimization-level*))))
|
||||
,@(car (ast:lambda-body (closure-convert (define->exp expr) globals *optimization-level*)))))
|
||||
((define-c? expr)
|
||||
expr)
|
||||
(else
|
||||
(caddr ;; Strip off superfluous lambda
|
||||
(closure-convert expr globals *optimization-level*)))))
|
||||
(car (ast:lambda-body ;; Strip off superfluous lambda
|
||||
(closure-convert expr globals *optimization-level*))))))
|
||||
input-program))
|
||||
; (caddr ;; Strip off superfluous lambda
|
||||
; (closure-convert input-program)))
|
||||
(trace:info "---------------- after closure-convert:")
|
||||
(trace:info input-program) ;pretty-print
|
||||
(trace:info (ast:ast->pp-sexp input-program))
|
||||
|
||||
(when (not *do-code-gen*)
|
||||
(trace:error "DEBUG, existing program")
|
||||
|
|
|
@ -1360,7 +1360,9 @@
|
|||
(define-c input-port?
|
||||
"(void *data, int argc, closure _, object k, object port)"
|
||||
" port_type *p = (port_type *)port;
|
||||
Cyc_check_port(data, port);
|
||||
if (boolean_f == Cyc_is_port(port)) {
|
||||
return_closcall1(data, k, boolean_f);
|
||||
}
|
||||
return_closcall1(
|
||||
data,
|
||||
k,
|
||||
|
@ -1368,7 +1370,9 @@
|
|||
(define-c output-port?
|
||||
"(void *data, int argc, closure _, object k, object port)"
|
||||
" port_type *p = (port_type *)port;
|
||||
Cyc_check_port(data, port);
|
||||
if (boolean_f == Cyc_is_port(port)) {
|
||||
return_closcall1(data, k, boolean_f);
|
||||
}
|
||||
return_closcall1(
|
||||
data,
|
||||
k,
|
||||
|
@ -1376,7 +1380,9 @@
|
|||
(define-c input-port-open?
|
||||
"(void *data, int argc, closure _, object k, object port)"
|
||||
" port_type *p = (port_type *)port;
|
||||
Cyc_check_port(data, port);
|
||||
if (boolean_f == Cyc_is_port(port)) {
|
||||
return_closcall1(data, k, boolean_f);
|
||||
}
|
||||
return_closcall1(
|
||||
data,
|
||||
k,
|
||||
|
@ -1384,7 +1390,9 @@
|
|||
(define-c output-port-open?
|
||||
"(void *data, int argc, closure _, object k, object port)"
|
||||
" port_type *p = (port_type *)port;
|
||||
Cyc_check_port(data, port);
|
||||
if (boolean_f == Cyc_is_port(port)) {
|
||||
return_closcall1(data, k, boolean_f);
|
||||
}
|
||||
return_closcall1(
|
||||
data,
|
||||
k,
|
||||
|
|
|
@ -312,6 +312,11 @@
|
|||
;; require CPS, so this flag is not applicable to them.
|
||||
(define (c-compile-exp exp append-preamble cont trace cps?)
|
||||
(cond
|
||||
; Special case - global function w/out a closure. Create an empty closure
|
||||
((ast:lambda? exp)
|
||||
(c-compile-exp
|
||||
`(%closure ,exp)
|
||||
append-preamble cont trace cps?))
|
||||
; Core forms:
|
||||
((const? exp) (c-compile-const exp))
|
||||
((prim? exp)
|
||||
|
@ -329,11 +334,6 @@
|
|||
(c-compile-global exp append-preamble cont trace))
|
||||
((define-c? exp)
|
||||
(c-compile-raw-global-lambda exp append-preamble cont trace))
|
||||
; Special case - global function w/out a closure. Create an empty closure
|
||||
((tagged-list? 'lambda exp)
|
||||
(c-compile-exp
|
||||
`(%closure ,exp)
|
||||
append-preamble cont trace cps?))
|
||||
|
||||
; Application:
|
||||
((app? exp) (c-compile-app exp append-preamble cont trace cps?))
|
||||
|
@ -717,6 +717,28 @@
|
|||
(let* ((args (app->args exp))
|
||||
(fun (app->fun exp)))
|
||||
(cond
|
||||
((ast:lambda? fun)
|
||||
(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
|
||||
(this-cont (string-append "__lambda_" (number->string lid)))
|
||||
(cgen
|
||||
(c-compile-args
|
||||
args
|
||||
append-preamble
|
||||
""
|
||||
this-cont
|
||||
trace
|
||||
cps?))
|
||||
(num-cargs (c:num-args cgen)))
|
||||
(set-c-call-arity! num-cargs)
|
||||
(c-code
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cgen))
|
||||
"return_direct" (number->string num-cargs)
|
||||
"(data," this-cont
|
||||
(if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " "
|
||||
(c:body cgen) ");"))))
|
||||
|
||||
;; Direct recursive call of top-level function
|
||||
((and (pair? trace)
|
||||
(not (null? (cdr trace)))
|
||||
|
@ -770,28 +792,6 @@
|
|||
"goto loop;")))
|
||||
)
|
||||
|
||||
((lambda? fun)
|
||||
(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
|
||||
(this-cont (string-append "__lambda_" (number->string lid)))
|
||||
(cgen
|
||||
(c-compile-args
|
||||
args
|
||||
append-preamble
|
||||
""
|
||||
this-cont
|
||||
trace
|
||||
cps?))
|
||||
(num-cargs (c:num-args cgen)))
|
||||
(set-c-call-arity! num-cargs)
|
||||
(c-code
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cgen))
|
||||
"return_direct" (number->string num-cargs)
|
||||
"(data," this-cont
|
||||
(if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " "
|
||||
(c:body cgen) ");"))))
|
||||
|
||||
((prim? fun)
|
||||
(let* ((c-fun
|
||||
(c-compile-prim fun cont))
|
||||
|
@ -967,7 +967,7 @@
|
|||
(car (define->exp exp)))))
|
||||
(add-global
|
||||
var
|
||||
(lambda? body)
|
||||
(ast:lambda? body)
|
||||
(c-compile-exp
|
||||
body append-preamble cont
|
||||
(st:add-function! trace var) #t))
|
||||
|
@ -978,7 +978,7 @@
|
|||
; ,(define-c->inline-var exp)
|
||||
; ,(prim:udf? (define-c->inline-var exp))
|
||||
; ))
|
||||
(when (and (lambda? body)
|
||||
(when (and (ast:lambda? body)
|
||||
(prim:udf? (define-c->inline-var exp)))
|
||||
(add-global-inline
|
||||
var
|
||||
|
@ -1075,6 +1075,10 @@
|
|||
(define lambdas '())
|
||||
(define inline-lambdas '())
|
||||
|
||||
;; TODO: may need to pass in AST lambda ID and store a mapping
|
||||
;; of cgen lambda ID to it, in order to use data from the
|
||||
;; analysis DB later on during code generation.
|
||||
;;
|
||||
; allocate-lambda : (string -> string) -> lambda-id
|
||||
(define (allocate-lambda lam . cps?)
|
||||
(let ((id num-lambdas))
|
||||
|
@ -1089,7 +1093,7 @@
|
|||
; (cdr (assv id lambdas)))
|
||||
|
||||
(define (lambda->env exp)
|
||||
(let ((formals (lambda-formals->list exp)))
|
||||
(let ((formals (ast:lambda-formals->list exp)))
|
||||
(if (pair? formals)
|
||||
(car formals)
|
||||
'unused)))
|
||||
|
@ -1108,15 +1112,27 @@
|
|||
;; Note this must be the count before additional closure/CPS arguments
|
||||
;; are added, so we need to detect those and not include them.
|
||||
(define (compute-num-args lam)
|
||||
(let ((count (lambda-num-args lam))) ;; Current arg count, may be too high
|
||||
(let ((count (ast:lambda-num-args lam))) ;; Current arg count, may be too high
|
||||
(cond
|
||||
((< count 0) -1) ;; Unlimited
|
||||
(else
|
||||
(let ((formals (lambda-formals->list lam)))
|
||||
(let ((formals (ast:lambda-formals->list lam)))
|
||||
(- count
|
||||
(if (fl/closure? formals) 1 0)
|
||||
(if (fl/cont? formals) 1 0)))))))
|
||||
|
||||
;; Minimum number of required arguments for a lambda
|
||||
(define (ast:lambda-num-args exp)
|
||||
(let ((type (ast:lambda-formals-type exp))
|
||||
(num (length (ast:lambda-formals->list exp))))
|
||||
(cond
|
||||
((equal? type 'args:varargs)
|
||||
-1) ;; Unlimited
|
||||
((equal? type 'args:fixed-with-varargs)
|
||||
(- num 1)) ;; Last arg is optional
|
||||
(else
|
||||
num))))
|
||||
|
||||
;; Formal list with a closure?
|
||||
(define (fl/closure? lis)
|
||||
(cond
|
||||
|
@ -1254,13 +1270,13 @@
|
|||
(let* ((formals (c-compile-formals
|
||||
(if (not cps?)
|
||||
;; Ignore continuation (k) arg for non-CPS funcs
|
||||
(cdr (lambda->formals exp))
|
||||
(lambda->formals exp))
|
||||
(lambda-formals-type exp)))
|
||||
(tmp-ident (if (> (length (lambda-formals->list exp)) 0)
|
||||
(mangle (if (pair? (lambda->formals exp))
|
||||
(car (lambda->formals exp))
|
||||
(lambda->formals exp)))
|
||||
(cdr (ast:lambda-args exp))
|
||||
(ast:lambda-args exp))
|
||||
(ast:lambda-formals-type exp)))
|
||||
(tmp-ident (if (> (length (ast:lambda-formals->list exp)) 0)
|
||||
(mangle (if (pair? (ast:lambda-args exp))
|
||||
(car (ast:lambda-args exp))
|
||||
(ast:lambda-args exp)))
|
||||
""))
|
||||
(return-type
|
||||
(if cps? "void" "object"))
|
||||
|
@ -1288,7 +1304,7 @@
|
|||
formals))
|
||||
(env-closure (lambda->env exp))
|
||||
(body (c-compile-exp
|
||||
(car (lambda->exp exp)) ;; car ==> assume single expr in lambda body after CPS
|
||||
(car (ast:lambda-body exp)) ;; car ==> assume single expr in lambda body after CPS
|
||||
append-preamble
|
||||
(mangle env-closure)
|
||||
trace
|
||||
|
@ -1300,18 +1316,18 @@
|
|||
formals*
|
||||
") {\n"
|
||||
preamble
|
||||
(if (lambda-varargs? exp)
|
||||
(if (ast:lambda-varargs? exp)
|
||||
;; Load varargs from C stack into Scheme list
|
||||
(string-append
|
||||
; DEBUGGING:
|
||||
;"printf(\"%d %d\\n\", argc, "
|
||||
; (number->string (length (lambda-formals->list exp))) ");"
|
||||
; (number->string (length (ast:lambda-formals->list exp))) ");"
|
||||
"load_varargs("
|
||||
(mangle (lambda-varargs-var exp))
|
||||
(mangle (ast:lambda-varargs-var exp))
|
||||
", "
|
||||
(mangle (lambda-varargs-var exp))
|
||||
(mangle (ast:lambda-varargs-var exp))
|
||||
"_raw, argc - " (number->string
|
||||
(- (length (lambda-formals->list exp))
|
||||
(- (length (ast:lambda-formals->list exp))
|
||||
1
|
||||
(if has-closure? 1 0)))
|
||||
");\n");
|
||||
|
@ -1337,6 +1353,18 @@
|
|||
|
||||
(define cgen:mangle-global #f)
|
||||
|
||||
(define (ast:lambda-varargs-var exp)
|
||||
(if (ast:lambda-varargs? exp)
|
||||
(if (equal? (ast:lambda-formals-type exp) 'args:varargs)
|
||||
(ast:lambda-args exp) ; take symbol directly
|
||||
(car (reverse (ast:lambda-formals->list exp)))) ; Last arg is varargs
|
||||
#f))
|
||||
|
||||
(define (ast:lambda-varargs? exp)
|
||||
(let ((type (ast:lambda-formals-type exp)))
|
||||
(or (equal? type 'args:varargs)
|
||||
(equal? type 'args:fixed-with-varargs))))
|
||||
|
||||
;; Convert a library name to string, so it can be
|
||||
;; appended to the identifiers it exports.
|
||||
(define (import->string import)
|
||||
|
|
|
@ -1573,7 +1573,26 @@
|
|||
(define (_closure-convert exp globals optimization-level)
|
||||
(define (convert exp self-var free-var-lst)
|
||||
(define (cc exp)
|
||||
;(trace:error `(cc ,exp))
|
||||
(cond
|
||||
((ast:lambda? exp)
|
||||
(let* ((new-self-var (gensym 'self))
|
||||
(body (ast:lambda-body exp))
|
||||
(new-free-vars
|
||||
(difference
|
||||
(difference (free-vars body) (ast:lambda-formals->list exp))
|
||||
globals)))
|
||||
`(%closure
|
||||
,(ast:%make-lambda
|
||||
(ast:lambda-id exp)
|
||||
(list->lambda-formals
|
||||
(cons new-self-var (ast:lambda-formals->list exp))
|
||||
(ast:lambda-formals-type exp))
|
||||
(list (convert (car body) new-self-var new-free-vars))
|
||||
(ast:lambda-has-cont exp))
|
||||
,@(map (lambda (v) ;; TODO: splice here?
|
||||
(cc v))
|
||||
new-free-vars))))
|
||||
((const? exp) exp)
|
||||
((quote? exp) exp)
|
||||
((ref? exp)
|
||||
|
@ -1591,22 +1610,7 @@
|
|||
,@(map cc (cdr exp)))) ;; TODO: need to splice?
|
||||
((set!? exp) `(set! ,(set!->var exp)
|
||||
,(cc (set!->exp exp))))
|
||||
((lambda? exp)
|
||||
(let* ((new-self-var (gensym 'self))
|
||||
(body (lambda->exp exp))
|
||||
(new-free-vars
|
||||
(difference
|
||||
(difference (free-vars body) (lambda-formals->list exp))
|
||||
globals)))
|
||||
`(%closure
|
||||
(lambda
|
||||
,(list->lambda-formals
|
||||
(cons new-self-var (lambda-formals->list exp))
|
||||
(lambda-formals-type exp))
|
||||
,(convert (car body) new-self-var new-free-vars)) ;; TODO: should this be a map??? was a list in 90-min-scc.
|
||||
,@(map (lambda (v) ;; TODO: splice here?
|
||||
(cc v))
|
||||
new-free-vars))))
|
||||
((lambda? exp) (error `(Unexpected lambda in closure-convert ,exp)))
|
||||
((if? exp) `(if ,@(map cc (cdr exp))))
|
||||
((cell? exp) `(cell ,(cc (cell->value exp))))
|
||||
((cell-get? exp) `(cell-get ,(cc (cell-get->cell exp))))
|
||||
|
@ -1616,16 +1620,16 @@
|
|||
(let ((fn (car exp))
|
||||
(args (map cc (cdr exp))))
|
||||
(cond
|
||||
((lambda? fn)
|
||||
((ast:lambda? fn)
|
||||
(cond
|
||||
;; If the lambda argument is not used, flag so the C code is
|
||||
;; all generated within the same function
|
||||
((and #f
|
||||
(> optimization-level 0)
|
||||
(eq? (lambda-formals-type fn) 'args:fixed)
|
||||
(pair? (lambda-formals->list fn))
|
||||
(eq? (ast:lambda-formals-type fn) 'args:fixed)
|
||||
(pair? (ast:lambda-formals->list fn))
|
||||
(with-var
|
||||
(car (lambda-formals->list fn))
|
||||
(car (ast:lambda-formals->list fn))
|
||||
(lambda (var)
|
||||
(zero? (adbv:ref-count var))))
|
||||
;; Non-CPS args
|
||||
|
@ -1638,30 +1642,40 @@
|
|||
args))
|
||||
`(Cyc-seq
|
||||
,@args
|
||||
,@(map cc (lambda->exp fn))))
|
||||
,@(map cc (ast:lambda-body fn))))
|
||||
(else
|
||||
(let* ((body (lambda->exp fn))
|
||||
(let* ((body (ast:lambda-body fn))
|
||||
(new-free-vars
|
||||
(difference
|
||||
(difference (free-vars body) (lambda-formals->list fn))
|
||||
(difference (free-vars body) (ast:lambda-formals->list fn))
|
||||
globals))
|
||||
(new-free-vars? (> (length new-free-vars) 0)))
|
||||
(if new-free-vars?
|
||||
; Free vars, create a closure for them
|
||||
(let* ((new-self-var (gensym 'self)))
|
||||
`((%closure
|
||||
(lambda
|
||||
,(list->lambda-formals
|
||||
(cons new-self-var (lambda-formals->list fn))
|
||||
(lambda-formals-type fn))
|
||||
,(convert (car body) new-self-var new-free-vars))
|
||||
,(ast:%make-lambda
|
||||
(ast:lambda-id fn)
|
||||
(list->lambda-formals
|
||||
(cons new-self-var (ast:lambda-formals->list fn))
|
||||
(ast:lambda-formals-type fn))
|
||||
(list (convert (car body) new-self-var new-free-vars))
|
||||
(ast:lambda-has-cont fn)
|
||||
)
|
||||
,@(map (lambda (v) (cc v))
|
||||
new-free-vars))
|
||||
,@args))
|
||||
; No free vars, just create simple lambda
|
||||
`((lambda ,(lambda->formals fn)
|
||||
,@(map cc body))
|
||||
,@args))))))
|
||||
`(,(ast:%make-lambda
|
||||
(ast:lambda-id fn)
|
||||
(ast:lambda-args fn)
|
||||
(map cc body)
|
||||
(ast:lambda-has-cont fn)
|
||||
)
|
||||
,@args)
|
||||
|
||||
)))))
|
||||
((lambda? fn) (error `(Unexpected lambda in closure-convert ,exp)))
|
||||
(else
|
||||
(let ((f (cc fn)))
|
||||
`((%closure-ref ,f 0)
|
||||
|
@ -1671,8 +1685,10 @@
|
|||
(error "unhandled exp: " exp))))
|
||||
(cc exp))
|
||||
|
||||
`(lambda ()
|
||||
,(convert exp #f '())))
|
||||
(ast:make-lambda
|
||||
(list)
|
||||
(list (convert exp #f '()))
|
||||
#f))
|
||||
|
||||
(define (analyze:find-named-lets exp)
|
||||
(define (scan exp lp)
|
||||
|
|
|
@ -84,6 +84,9 @@
|
|||
(cond ((pair? obj) (wr-expr obj col))
|
||||
((null? obj) (wr-lst obj col))
|
||||
((vector? obj) (wr-lst (vector->list obj) (out "#" col)))
|
||||
((bytevector? obj) (wr-lst
|
||||
(map char->integer (string->list (utf8->string obj)))
|
||||
(out "#u8" col)))
|
||||
((boolean? obj) (out (if obj "#t" "#f") col))
|
||||
((number? obj) (out (number->string obj) col))
|
||||
((symbol? obj) (out (symbol->string obj) col))
|
||||
|
|
|
@ -630,6 +630,9 @@
|
|||
(define (search exp)
|
||||
(cond
|
||||
; Core forms:
|
||||
((ast:lambda? exp)
|
||||
(difference (reduce union (map search (ast:lambda-body exp)) '())
|
||||
(ast:lambda-formals->list exp)))
|
||||
((const? exp) '())
|
||||
((prim? exp) '())
|
||||
((quote? exp) '())
|
||||
|
@ -726,22 +729,34 @@
|
|||
; wrap-mutables : exp -> exp
|
||||
(define (wrap-mutables exp globals)
|
||||
|
||||
(define (wrap-mutable-formals formals body-exp)
|
||||
(define (wrap-mutable-formals id formals body-exp has-cont)
|
||||
(if (not (pair? formals))
|
||||
body-exp
|
||||
;(list body-exp)
|
||||
(if (is-mutable? (car formals))
|
||||
`((lambda (,(car formals))
|
||||
,(wrap-mutable-formals (cdr formals) body-exp))
|
||||
(cell ,(car formals)))
|
||||
(wrap-mutable-formals (cdr formals) body-exp))))
|
||||
(list
|
||||
(list ;(ast:%make-lambda
|
||||
; id
|
||||
(ast:make-lambda
|
||||
(list (car formals))
|
||||
(wrap-mutable-formals id (cdr formals) body-exp has-cont)
|
||||
has-cont)
|
||||
`(cell ,(car formals))))
|
||||
(wrap-mutable-formals id (cdr formals) body-exp has-cont))))
|
||||
|
||||
(cond
|
||||
; Core forms:
|
||||
((ast:lambda? exp)
|
||||
`(lambda ,(ast:lambda-args exp)
|
||||
,(wrap-mutable-formals
|
||||
(ast:%make-lambda
|
||||
(ast:lambda-id exp)
|
||||
(ast:lambda-args exp)
|
||||
(wrap-mutable-formals
|
||||
(ast:lambda-id exp)
|
||||
(ast:lambda-formals->list exp)
|
||||
(wrap-mutables (car (ast:lambda-body exp)) globals)))) ;; Assume single expr in lambda body, since after CPS phase
|
||||
(list (wrap-mutables (car (ast:lambda-body exp)) globals))
|
||||
(ast:lambda-has-cont exp))
|
||||
(ast:lambda-has-cont exp)
|
||||
)) ;; Assume single expr in lambda body, since after CPS phase
|
||||
((const? exp) exp)
|
||||
((ref? exp) (if (and (not (member exp globals))
|
||||
(is-mutable? exp))
|
||||
|
@ -749,9 +764,7 @@
|
|||
exp))
|
||||
((prim? exp) exp)
|
||||
((quote? exp) exp)
|
||||
((lambda? exp) `(lambda ,(lambda->formals exp)
|
||||
,(wrap-mutable-formals (lambda-formals->list exp)
|
||||
(wrap-mutables (car (lambda->exp exp)) globals)))) ;; Assume single expr in lambda body, since after CPS phase
|
||||
((lambda? exp) (error `(Unexpected lambda in wrap-mutables ,exp)))
|
||||
((set!? exp) `(,(if (member (set!->var exp) globals)
|
||||
'set-global!
|
||||
'set-cell!)
|
||||
|
|
Loading…
Add table
Reference in a new issue