Merge branch 'ast3-dev'

This commit is contained in:
Justin Ethier 2018-09-12 10:35:38 -04:00
commit 61cdf4ea5c
7 changed files with 177 additions and 101 deletions

View file

@ -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

View file

@ -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")

View file

@ -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,

View file

@ -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)

View file

@ -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)

View file

@ -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))

View file

@ -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!)