From a0f4d9e3a9fb9719f6382f5b57c8c00586ec77ce Mon Sep 17 00:00:00 2001 From: Stephen Chang Date: Tue, 5 Apr 2016 00:14:43 -0400 Subject: [PATCH] eliminate dup expansion of some args in mlish #%app --- tapl/mlish.rkt | 42 ++++++++++++++++++------------ tapl/notes.txt | 2 ++ tapl/stx-utils.rkt | 3 +++ tapl/tests/mlish/queens.mlish | 4 +-- tapl/tests/run-all-mlish-tests.rkt | 7 +++++ tapl/tests/run-mlish-tests1.rkt | 2 +- tapl/tests/run-mlish-tests1b.rkt | 2 +- 7 files changed, 42 insertions(+), 20 deletions(-) diff --git a/tapl/mlish.rkt b/tapl/mlish.rkt index c87c6a4..8cdcb11 100644 --- a/tapl/mlish.rkt +++ b/tapl/mlish.rkt @@ -89,19 +89,22 @@ #'())) (syntax-parse stx [(_ e_fn . args) - (define maybe-solved-tys - (try-to-solve Xs - (for/fold ([cs initial-cs]) + (define-values (as- cs) + (for/fold ([as- null] [cs initial-cs]) ([a (in-list (syntax->list #'args))] [tyXin (in-list (syntax->list #'(τ_inX ...)))] #:break (try-to-solve Xs cs)) - (define/with-syntax [_ ty_a] (infer+erase a)) - (stx-append cs (compute-constraint (list tyXin #'ty_a)))))) - (or maybe-solved-tys - (type-error #:src stx - #:msg (mk-app-err-msg stx #:expected #'(τ_inX ...) #:given (infers+erase #'args) - #:note (format "Could not infer instantiation of polymorphic function ~a." - (syntax->datum #'e_fn)))))])])) + (define/with-syntax [a- ty_a] (infer+erase a)) + (values + (cons #'a- as-) + (stx-append cs (compute-constraint (list tyXin #'ty_a)))))) + (define maybe-solved-tys (try-to-solve Xs cs)) + (if maybe-solved-tys + (list (reverse as-) maybe-solved-tys) + (type-error #:src stx + #:msg (mk-app-err-msg stx #:expected #'(τ_inX ...) #:given (infers+erase #'args) + #:note (format "Could not infer instantiation of polymorphic function ~a." + (syntax->datum #'e_fn)))))])])) ;; instantiate polymorphic types (define (inst-type ty-solved Xs ty) @@ -704,27 +707,34 @@ #'(ext-stlc:#%app e_fn/ty (add-expected e_arg τ_inX) ...)])] [else ;; ) solve for type variables Xs - (define tys-solved (solve #'Xs #'tyX_args stx)) + (define/with-syntax ((e_arg1- ...) tys-solved) + (solve #'Xs #'tyX_args stx)) ;; ) instantiate polymorphic function type - (syntax-parse (inst-types tys-solved #'Xs #'tyX_args) + (syntax-parse (inst-types #'tys-solved #'Xs #'tyX_args) [(τ_in ... τ_out) ; concrete types ;; ) arity check #:fail-unless (stx-length=? #'(τ_in ...) #'e_args) (mk-app-err-msg stx #:expected #'(τ_in ...) #:note "Wrong number of arguments.") - ;; ) compute argument types; (possibly) double-expand args (for now) - #:with ([e_arg- τ_arg] ...) (infers+erase (stx-map add-expected-ty #'e_args #'(τ_in ...))) + ;; ) compute argument types; re-use args expanded during solve + #:with ([e_arg2- τ_arg2] ...) (let ([n (stx-length #'(e_arg1- ...))]) + (infers+erase + (stx-map add-expected-ty + (stx-drop #'e_args n) (stx-drop #'(τ_in ...) n)))) + #:with (τ_arg1 ...) (stx-map typeof #'(e_arg1- ...)) + #:with (τ_arg ...) #'(τ_arg1 ... τ_arg2 ...) + #:with (e_arg- ...) #'(e_arg1- ... e_arg2- ...) ;; ) typecheck args #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) (mk-app-err-msg stx - #:given #'(τ_arg ...) + #:given #'(τ_arg ...) #:expected (stx-map (lambda (tyin) (define old-orig (get-orig tyin)) (define new-orig (and old-orig - (substs (stx-map get-orig tys-solved) #'Xs old-orig + (substs (stx-map get-orig #'tys-solved) #'Xs old-orig (lambda (x y) (equal? (syntax->datum x) (syntax->datum y)))))) (syntax-property tyin 'orig (list new-orig))) #'(τ_in ...))) diff --git a/tapl/notes.txt b/tapl/notes.txt index 827aeb7..977bc5f 100644 --- a/tapl/notes.txt +++ b/tapl/notes.txt @@ -321,8 +321,10 @@ debugging notes ------------- ?: literal data is not allowed; no #%datum syntax transformer is bound in: #f + - happens when you try to syntax->datum or local-expand a #f value - likely indicates use of wrong version of some overloaded form - eg, using stlc:lambda instead of racket's lambda + - could also be trying to ty-eval a (#f) expected-type - vague "bad syntax" error - means a syntax-parse #:when or #:with matching failed diff --git a/tapl/stx-utils.rkt b/tapl/stx-utils.rkt index c9f2aa0..4b49f5f 100644 --- a/tapl/stx-utils.rkt +++ b/tapl/stx-utils.rkt @@ -65,6 +65,9 @@ (define (stx-appendmap f stx) (stx-flatten (stx-map f stx))) +(define (stx-drop stx n) + (drop (syntax->list stx) n)) + ;; based on make-variable-like-transformer from syntax/transformer, ;; but using (#%app id ...) instead of ((#%expression id) ...) (define (make-variable-like-transformer ref-stx) diff --git a/tapl/tests/mlish/queens.mlish b/tapl/tests/mlish/queens.mlish index aa345c7..a9a50b8 100644 --- a/tapl/tests/mlish/queens.mlish +++ b/tapl/tests/mlish/queens.mlish @@ -9,11 +9,11 @@ (typecheck-fail (match (Cons 1 Nil) with [Nil -> 1]) - #:with-msg "match: clauses not exhaustive; missing: Cons") + #:with-msg "clauses not exhaustive; missing\\: Cons") (typecheck-fail (match (Cons 1 Nil) with [Cons x xs -> 1]) - #:with-msg "match: clauses not exhaustive; missing: Nil") + #:with-msg "clauses not exhaustive; missing: Nil") ;; list fns ---------- diff --git a/tapl/tests/run-all-mlish-tests.rkt b/tapl/tests/run-all-mlish-tests.rkt index 64cbdb3..3d866b8 100644 --- a/tapl/tests/run-all-mlish-tests.rkt +++ b/tapl/tests/run-all-mlish-tests.rkt @@ -17,16 +17,23 @@ (displayln "----- General tests and queens: ---------------------------------") (write-string (port->string err1)) +(write-string (port->string i1)) (displayln "----- Shootout tests: -------------------------------------------") (write-string (port->string err1b)) +(write-string (port->string i1b)) (displayln "----- RW OCaml tests: -------------------------------------------") (write-string (port->string err2)) +(write-string (port->string i2)) (displayln "----- Ben's tests: ----------------------------------------------") (write-string (port->string err3)) +(write-string (port->string i3)) (write-string (port->string err3b)) +(write-string (port->string i3b)) (write-string (port->string err3c)) +(write-string (port->string i3c)) (displayln "----- Okasaki / polymorphic recursion tests: --------------------") (write-string (port->string err4)) +(write-string (port->string i4)) (close-input-port i1) (close-output-port o1) diff --git a/tapl/tests/run-mlish-tests1.rkt b/tapl/tests/run-mlish-tests1.rkt index c768ab2..6506f3a 100644 --- a/tapl/tests/run-mlish-tests1.rkt +++ b/tapl/tests/run-mlish-tests1.rkt @@ -1,6 +1,6 @@ #lang racket (require "mlish-tests.rkt") -(require "mlish/queens.mlish") +;(require "mlish/queens.mlish") (require "mlish/listpats.mlish") (require "mlish/match2.mlish") diff --git a/tapl/tests/run-mlish-tests1b.rkt b/tapl/tests/run-mlish-tests1b.rkt index 06ee001..2350d5b 100644 --- a/tapl/tests/run-mlish-tests1b.rkt +++ b/tapl/tests/run-mlish-tests1b.rkt @@ -1,6 +1,6 @@ #lang racket ;; (require "mlish-tests.rkt") -;; (require "mlish/queens.mlish") +(require "mlish/queens.mlish") (require "mlish/trees-tests.mlish") (require "mlish/chameneos.mlish") (require "mlish/ack.mlish")