diff --git a/CHANGELOG.md b/CHANGELOG.md index dff97050..b96466aa 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/cyclone.scm b/cyclone.scm index a0e4011b..7d7e2e73 100644 --- a/cyclone.scm +++ b/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") diff --git a/scheme/base.sld b/scheme/base.sld index 441d9785..3a9155c7 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -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, diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 6d163417..8a408290 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -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) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index a05c2cc2..1cb20d9b 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -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) diff --git a/scheme/cyclone/pretty-print.sld b/scheme/cyclone/pretty-print.sld index 8e052d3b..a9fc91ba 100644 --- a/scheme/cyclone/pretty-print.sld +++ b/scheme/cyclone/pretty-print.sld @@ -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)) diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld index add78d10..36cf7c3c 100644 --- a/scheme/cyclone/transforms.sld +++ b/scheme/cyclone/transforms.sld @@ -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!)