commit a0f4d9e3a9fb9719f6382f5b57c8c00586ec77ce
parent 33e17dd282cef032b9ad44ff8736fdb221b5f817
Author: Stephen Chang <stchang@ccs.neu.edu>
Date: Tue, 5 Apr 2016 00:14:43 -0400
eliminate dup expansion of some args in mlish #%app
Diffstat:
7 files changed, 42 insertions(+), 20 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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")
