diff options
Diffstat (limited to 'module/language/tree-il/peval.scm')
-rw-r--r-- | module/language/tree-il/peval.scm | 492 |
1 files changed, 241 insertions, 251 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index bf96179e0..fe637f0a5 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -109,9 +109,8 @@ (($ <primitive-ref>) #t) (($ <module-ref>) #t) (($ <toplevel-ref>) #t) - (($ <application> _ - ($ <primitive-ref> _ (? singly-valued-primitive?))) #t) - (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t) + (($ <primcall> _ (? singly-valued-primitive?)) #t) + (($ <primcall> _ 'values (val)) #t) (($ <lambda>) #t) (else #f))) @@ -119,9 +118,7 @@ "Discard all but the first value of X." (if (singly-valued-expression? x) x - (make-application (tree-il-src x) - (make-primitive-ref #f 'values) - (list x)))) + (make-primcall (tree-il-src x) 'values (list x)))) ;; Peval will do a one-pass analysis on the source program to determine ;; the set of assigned lexicals, and to identify unreferenced and @@ -328,7 +325,7 @@ (%set-operand-residual-value! op (match val - (($ <application> src ($ <primitive-ref> _ 'values) (first)) + (($ <primcall> src 'values (first)) ;; The continuation of a residualized binding does not need the ;; introduced `values' node, so undo the effects of truncation. first) @@ -401,18 +398,15 @@ top-level bindings from ENV and return the resulting expression." (define local-toplevel-env ;; The top-level environment of the module being compiled. - (match exp - (($ <toplevel-define> _ name) - (vhash-consq name #t env)) - (($ <sequence> _ exps) - (fold (lambda (x r) - (match x - (($ <toplevel-define> _ name) - (vhash-consq name #t r)) - (_ r))) - env - exps)) - (_ env))) + (let () + (define (env-folder x env) + (match x + (($ <toplevel-define> _ name) + (vhash-consq name #t env)) + (($ <seq> _ head tail) + (env-folder tail (env-folder head env))) + (_ env))) + (env-folder exp vlist-null))) (define (local-toplevel? name) (vhash-assq name local-toplevel-env)) @@ -492,15 +486,13 @@ top-level bindings from ENV and return the resulting expression." (values #t results)))) (lambda _ (values #f '())))) - (define (make-values src values) (match values ((single) single) ; 1 value ((_ ...) ; 0, or 2 or more values - (make-application src (make-primitive-ref src 'values) - values)))) + (make-primcall src 'values values)))) (define (residualize-call) - (make-application src (make-primitive-ref #f name) args)) + (make-primcall src name args)) (cond ((every const? args) (let-values (((success? values) @@ -540,21 +532,21 @@ top-level bindings from ENV and return the resulting expression." ($ <toplevel-define>) ; the future ($ <module-set>) ; ($ <dynset>) ; - ($ <application> src - ($ <primitive-ref> _ (? singly-valued-primitive?)))) + ($ <primcall> src (? singly-valued-primitive?))) (and (<= nmin 1) (or (not nmax) (>= nmax 1)) - (make-application src (make-lambda #f '() consumer) (list exp)))) + (make-call src (make-lambda #f '() consumer) (list exp)))) ;; Statically-known number of values. - (($ <application> src ($ <primitive-ref> _ 'values) vals) + (($ <primcall> src 'values vals) (and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals))) - (make-application src (make-lambda #f '() consumer) vals))) + (make-call src (make-lambda #f '() consumer) vals))) ;; Not going to copy code into both branches. (($ <conditional>) #f) ;; Bail on other applications. - (($ <application>) #f) + (($ <call>) #f) + (($ <primcall>) #f) ;; Bail on prompt and abort. (($ <prompt>) #f) @@ -580,20 +572,17 @@ top-level bindings from ENV and return the resulting expression." (make-let-values src exp (make-lambda-case src2 req opt rest kw inits gensyms body #f))))) - (($ <dynwind> src winder body unwinder) + (($ <dynwind> src winder pre body post unwinder) (let ((body (loop body))) (and body - (make-dynwind src winder body unwinder)))) + (make-dynwind src winder pre body post unwinder)))) (($ <dynlet> src fluids vals body) (let ((body (loop body))) (and body (make-dynlet src fluids vals body)))) - (($ <sequence> src exps) - (match exps - ((head ... tail) - (let ((tail (loop tail))) - (and tail - (make-sequence src (append head (list tail))))))))))) + (($ <seq> src head tail) + (let ((tail (loop tail))) + (and tail (make-seq src head tail))))))) (define compute-effects (make-effects-analyzer assigned-lexical?)) @@ -640,7 +629,7 @@ top-level bindings from ENV and return the resulting expression." (if (null? effects) body (let ((effect-vals (map operand-residual-value effects))) - (make-sequence #f (reverse (cons body effect-vals))))))) + (list->seq #f (reverse (cons body effect-vals))))))) (if (null? values) body (let ((values (reverse values))) @@ -875,16 +864,15 @@ top-level bindings from ENV and return the resulting expression." (let ((exp (for-effect exp))) (if (void? exp) exp - (make-sequence src (list exp (make-void #f))))) + (make-seq src exp (make-void #f)))) (begin (record-operand-use op) (make-lexical-set src name (operand-sym op) (for-value exp)))))) (($ <let> src (names ... rest) (gensyms ... rest-sym) - (vals ... ($ <application> _ ($ <primitive-ref> _ 'list) rest-args)) - ($ <application> asrc - ($ <primitive-ref> _ (or 'apply '@apply)) + (vals ... ($ <primcall> _ 'list rest-args)) + ($ <primcall> asrc (or 'apply '@apply) (proc args ... ($ <lexical-ref> _ (? (cut eq? <> rest)) @@ -898,7 +886,7 @@ top-level bindings from ENV and return the resulting expression." (append names tmps) (append gensyms tmp-syms) (append vals rest-args) - (make-application + (make-call asrc proc (append args @@ -940,14 +928,14 @@ top-level bindings from ENV and return the resulting expression." (body (loop body env counter ctx))) (cond ((const? body) - (for-tail (make-sequence src (append vals (list body))))) + (for-tail (list->seq src (append vals (list body))))) ((and (lexical-ref? body) (memq (lexical-ref-gensym body) new)) (let ((sym (lexical-ref-gensym body)) (pairs (map cons new vals))) ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo) (for-tail - (make-sequence + (list->seq src (append (map cdr (alist-delete sym pairs eq?)) (list (assq-ref pairs sym))))))) @@ -1008,40 +996,10 @@ top-level bindings from ENV and return the resulting expression." (else #f)))) (_ #f)) (make-let-values lv-src producer (for-tail consumer))))) - (($ <dynwind> src winder body unwinder) - (let ((pre (for-value winder)) - (body (for-tail body)) - (post (for-value unwinder))) - (cond - ((not (constant-expression? pre)) - (cond - ((not (constant-expression? post)) - (let ((pre-sym (gensym "pre-")) (post-sym (gensym "post-"))) - (record-new-temporary! 'pre pre-sym 1) - (record-new-temporary! 'post post-sym 1) - (make-let src '(pre post) (list pre-sym post-sym) (list pre post) - (make-dynwind src - (make-lexical-ref #f 'pre pre-sym) - body - (make-lexical-ref #f 'post post-sym))))) - (else - (let ((pre-sym (gensym "pre-"))) - (record-new-temporary! 'pre pre-sym 1) - (make-let src '(pre) (list pre-sym) (list pre) - (make-dynwind src - (make-lexical-ref #f 'pre pre-sym) - body - post)))))) - ((not (constant-expression? post)) - (let ((post-sym (gensym "post-"))) - (record-new-temporary! 'post post-sym 1) - (make-let src '(post) (list post-sym) (list post) - (make-dynwind src - pre - body - (make-lexical-ref #f 'post post-sym))))) - (else - (make-dynwind src pre body post))))) + (($ <dynwind> src winder pre body post unwinder) + (make-dynwind src (for-value winder) (for-effect pre) + (for-tail body) + (for-effect post) (for-value unwinder))) (($ <dynlet> src fluids vals body) (make-dynlet src (map for-value fluids) (map for-value vals) (for-tail body))) @@ -1050,12 +1008,7 @@ top-level bindings from ENV and return the resulting expression." (($ <dynset> src fluid exp) (make-dynset src (for-value fluid) (for-value exp))) (($ <toplevel-ref> src (? effect-free-primitive? name)) - (if (local-toplevel? name) - exp - (let ((exp (resolve-primitives! exp cenv))) - (if (primitive-ref? exp) - (for-tail exp) - exp)))) + exp) (($ <toplevel-ref>) ;; todo: open private local bindings. exp) @@ -1084,7 +1037,8 @@ top-level bindings from ENV and return the resulting expression." (($ <conditional> src condition subsequent alternate) (define (call-with-failure-thunk exp proc) (match exp - (($ <application> _ _ ()) (proc exp)) + (($ <call> _ _ ()) (proc exp)) + (($ <primcall> _ _ ()) (proc exp)) (($ <const>) (proc exp)) (($ <void>) (proc exp)) (($ <lexical-ref>) (proc exp)) @@ -1097,13 +1051,12 @@ top-level bindings from ENV and return the resulting expression." (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() exp #f))) - (proc (make-application #f (make-lexical-ref #f 'failure t) - '()))))))) + (proc (make-call #f (make-lexical-ref #f 'failure t) + '()))))))) (define (simplify-conditional c) (match c ;; Swap the arms of (if (not FOO) A B), to simplify. - (($ <conditional> src - ($ <application> _ ($ <primitive-ref> _ 'not) (pred)) + (($ <conditional> src ($ <primcall> _ 'not (pred)) subsequent alternate) (simplify-conditional (make-conditional src pred alternate subsequent))) @@ -1155,17 +1108,59 @@ top-level bindings from ENV and return the resulting expression." (simplify-conditional (make-conditional src c (for-tail subsequent) (for-tail alternate)))))) - (($ <application> src - ($ <primitive-ref> _ '@call-with-values) + (($ <primcall> src '@call-with-values (producer ($ <lambda> _ _ (and consumer ;; No optional or kwargs. ($ <lambda-case> _ req #f rest #f () gensyms body #f))))) - (for-tail (make-let-values src (make-application src producer '()) + (for-tail (make-let-values src (make-call src producer '()) consumer))) - (($ <application> src ($ <primitive-ref> _ 'values) exps) + (($ <primcall> src 'dynamic-wind (w thunk u)) + (for-tail + (cond + ((not (constant-expression? w)) + (cond + ((not (constant-expression? u)) + (let ((w-sym (gensym "w ")) (u-sym (gensym "u "))) + (record-new-temporary! 'w w-sym 2) + (record-new-temporary! 'u u-sym 2) + (make-let src '(w u) (list w-sym u-sym) (list w u) + (make-dynwind + src + (make-lexical-ref #f 'w w-sym) + (make-call #f (make-lexical-ref #f 'w w-sym) '()) + (make-call #f thunk '()) + (make-call #f (make-lexical-ref #f 'u u-sym) '()) + (make-lexical-ref #f 'u u-sym))))) + (else + (let ((w-sym (gensym "w "))) + (record-new-temporary! 'w w-sym 2) + (make-let src '(w) (list w-sym) (list w) + (make-dynwind + src + (make-lexical-ref #f 'w w-sym) + (make-call #f (make-lexical-ref #f 'w w-sym) '()) + (make-call #f thunk '()) + (make-call #f u '()) + u)))))) + ((not (constant-expression? u)) + (let ((u-sym (gensym "u "))) + (record-new-temporary! 'u u-sym 2) + (make-let src '(u) (list u-sym) (list u) + (make-dynwind + src + w + (make-call #f w '()) + (make-call #f thunk '()) + (make-call #f (make-lexical-ref #f 'u u-sym) '()) + (make-lexical-ref #f 'u u-sym))))) + (else + (make-dynwind src w (make-call #f w '()) (make-call #f thunk '()) + (make-call #f u '()) u))))) + + (($ <primcall> src 'values exps) (cond ((null? exps) (if (eq? ctx 'effect) @@ -1177,10 +1172,10 @@ top-level bindings from ENV and return the resulting expression." ((value test effect) #t) (else (null? (cdr vals)))) (every singly-valued-expression? vals)) - (for-tail (make-sequence src (append (cdr vals) (list (car vals))))) - (make-application src (make-primitive-ref #f 'values) vals)))))) - (($ <application> src (and apply ($ <primitive-ref> _ (or 'apply '@apply))) - (proc args ... tail)) + (for-tail (list->seq src (append (cdr vals) (list (car vals))))) + (make-primcall src 'values vals)))))) + + (($ <primcall> src (or 'apply '@apply) (proc args ... tail)) (let lp ((tail* (find-definition tail 1)) (speculative? #t)) (define (copyable? x) ;; Inlining a result from find-definition effectively copies it, @@ -1190,126 +1185,133 @@ top-level bindings from ENV and return the resulting expression." (match tail* (($ <const> _ (args* ...)) (let ((args* (map (cut make-const #f <>) args*))) - (for-tail (make-application src proc (append args args*))))) - (($ <application> _ ($ <primitive-ref> _ 'cons) + (for-tail (make-call src proc (append args args*))))) + (($ <primcall> _ 'cons ((and head (? copyable?)) (and tail (? copyable?)))) - (for-tail (make-application src apply - (cons proc - (append args (list head tail)))))) - (($ <application> _ ($ <primitive-ref> _ 'list) + (for-tail (make-primcall src '@apply + (cons proc + (append args (list head tail)))))) + (($ <primcall> _ 'list (and args* ((? copyable?) ...))) - (for-tail (make-application src proc (append args args*)))) + (for-tail (make-call src proc (append args args*)))) (tail* (if speculative? (lp (for-value tail) #f) (let ((args (append (map for-value args) (list tail*)))) - (make-application src apply - (cons (for-value proc) args)))))))) - (($ <application> src orig-proc orig-args) + (make-primcall src '@apply + (cons (for-value proc) args)))))))) + + (($ <primcall> src (? constructor-primitive? name) args) + (cond + ((and (memq ctx '(effect test)) + (match (cons name args) + ((or ('cons _ _) + ('list . _) + ('vector . _) + ('make-prompt-tag) + ('make-prompt-tag ($ <const> _ (? string?)))) + #t) + (_ #f))) + ;; Some expressions can be folded without visiting the + ;; arguments for value. + (let ((res (if (eq? ctx 'effect) + (make-void #f) + (make-const #f #t)))) + (for-tail (list->seq src (append args (list res)))))) + (else + (match (cons name (map for-value args)) + (('cons x ($ <const> _ (? (cut eq? <> '())))) + (make-primcall src 'list (list x))) + (('cons x ($ <primcall> _ 'list elts)) + (make-primcall src 'list (cons x elts))) + ((name . args) + (make-primcall src name args)))))) + + (($ <primcall> src (? accessor-primitive? name) args) + (match (cons name (map for-value args)) + ;; FIXME: these for-tail recursions could take place outside + ;; an effort counter. + (('car ($ <primcall> src 'cons (head tail))) + (for-tail (make-seq src tail head))) + (('cdr ($ <primcall> src 'cons (head tail))) + (for-tail (make-seq src head tail))) + (('car ($ <primcall> src 'list (head . tail))) + (for-tail (list->seq src (append tail (list head))))) + (('cdr ($ <primcall> src 'list (head . tail))) + (for-tail (make-seq src head (make-primcall #f 'list tail)))) + + (('car ($ <const> src (head . tail))) + (for-tail (make-const src head))) + (('cdr ($ <const> src (head . tail))) + (for-tail (make-const src tail))) + (((or 'memq 'memv) k ($ <const> _ (elts ...))) + ;; FIXME: factor + (case ctx + ((effect) + (for-tail + (make-seq src k (make-void #f)))) + ((test) + (cond + ((const? k) + ;; A shortcut. The `else' case would handle it, but + ;; this way is faster. + (let ((member (case name ((memq) memq) ((memv) memv)))) + (make-const #f (and (member (const-exp k) elts) #t)))) + ((null? elts) + (for-tail + (make-seq src k (make-const #f #f)))) + (else + (let ((t (gensym "t ")) + (eq (if (eq? name 'memq) 'eq? 'eqv?))) + (record-new-temporary! 't t (length elts)) + (for-tail + (make-let + src (list 't) (list t) (list k) + (let lp ((elts elts)) + (define test + (make-primcall #f eq + (list (make-lexical-ref #f 't t) + (make-const #f (car elts))))) + (if (null? (cdr elts)) + test + (make-conditional src test + (make-const #f #t) + (lp (cdr elts))))))))))) + (else + (cond + ((const? k) + (let ((member (case name ((memq) memq) ((memv) memv)))) + (make-const #f (member (const-exp k) elts)))) + ((null? elts) + (for-tail (make-seq src k (make-const #f #f)))) + (else + (make-primcall src name (list k (make-const #f elts)))))))) + ((name . args) + (fold-constants src name args ctx)))) + + (($ <primcall> src (? equality-primitive? name) (a b)) + (let ((val-a (for-value a)) + (val-b (for-value b))) + (log 'equality-primitive name val-a val-b) + (cond ((and (lexical-ref? val-a) (lexical-ref? val-b) + (eq? (lexical-ref-gensym val-a) + (lexical-ref-gensym val-b))) + (for-tail (make-const #f #t))) + (else + (fold-constants src name (list val-a val-b) ctx))))) + + (($ <primcall> src (? effect-free-primitive? name) args) + (fold-constants src name (map for-value args) ctx)) + + (($ <primcall> src name args) + (make-primcall src name (map for-value args))) + + (($ <call> src orig-proc orig-args) ;; todo: augment the global env with specialized functions (let revisit-proc ((proc (visit orig-proc 'operator))) (match proc - (($ <primitive-ref> _ (? constructor-primitive? name)) - (cond - ((and (memq ctx '(effect test)) - (match (cons name orig-args) - ((or ('cons _ _) - ('list . _) - ('vector . _) - ('make-prompt-tag) - ('make-prompt-tag ($ <const> _ (? string?)))) - #t) - (_ #f))) - ;; Some expressions can be folded without visiting the - ;; arguments for value. - (let ((res (if (eq? ctx 'effect) - (make-void #f) - (make-const #f #t)))) - (for-tail (make-sequence src (append orig-args (list res)))))) - (else - (match (cons name (map for-value orig-args)) - (('cons head tail) - (match tail - (($ <const> src (? (cut eq? <> '()))) - (make-application src (make-primitive-ref #f 'list) - (list head))) - (($ <application> src ($ <primitive-ref> _ 'list) elts) - (make-application src (make-primitive-ref #f 'list) - (cons head elts))) - (_ (make-application src proc (list head tail))))) - ((_ . args) - (make-application src proc args)))))) - (($ <primitive-ref> _ (? accessor-primitive? name)) - (match (cons name (map for-value orig-args)) - ;; FIXME: these for-tail recursions could take place outside - ;; an effort counter. - (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) - (for-tail (make-sequence src (list tail head)))) - (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) - (for-tail (make-sequence src (list head tail)))) - (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) - (for-tail (make-sequence src (append tail (list head))))) - (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) - (for-tail (make-sequence - src - (list head - (make-application - src (make-primitive-ref #f 'list) tail))))) - - (('car ($ <const> src (head . tail))) - (for-tail (make-const src head))) - (('cdr ($ <const> src (head . tail))) - (for-tail (make-const src tail))) - (((or 'memq 'memv) k ($ <const> _ (elts ...))) - ;; FIXME: factor - (case ctx - ((effect) - (for-tail - (make-sequence src (list k (make-void #f))))) - ((test) - (cond - ((const? k) - ;; A shortcut. The `else' case would handle it, but - ;; this way is faster. - (let ((member (case name ((memq) memq) ((memv) memv)))) - (make-const #f (and (member (const-exp k) elts) #t)))) - ((null? elts) - (for-tail - (make-sequence src (list k (make-const #f #f))))) - (else - (let ((t (gensym "t-")) - (eq (if (eq? name 'memq) 'eq? 'eqv?))) - (record-new-temporary! 't t (length elts)) - (for-tail - (make-let - src (list 't) (list t) (list k) - (let lp ((elts elts)) - (define test - (make-application - #f (make-primitive-ref #f eq) - (list (make-lexical-ref #f 't t) - (make-const #f (car elts))))) - (if (null? (cdr elts)) - test - (make-conditional src test - (make-const #f #t) - (lp (cdr elts))))))))))) - (else - (cond - ((const? k) - (let ((member (case name ((memq) memq) ((memv) memv)))) - (make-const #f (member (const-exp k) elts)))) - ((null? elts) - (for-tail (make-sequence src (list k (make-const #f #f))))) - (else - (make-application src proc (list k (make-const #f elts)))))))) - ((_ . args) - (or (fold-constants src name args ctx) - (make-application src proc args))))) - (($ <primitive-ref> _ (? effect-free-primitive? name)) - (let ((args (map for-value orig-args))) - (or (fold-constants src name args ctx) - (make-application src proc args)))) + (($ <primitive-ref> _ name) + (for-tail (make-primcall src name orig-args))) (($ <lambda> _ _ ($ <lambda-case> _ req opt rest #f inits gensyms body #f)) ;; Simple case: no keyword arguments. @@ -1318,7 +1320,7 @@ top-level bindings from ENV and return the resulting expression." (nreq (length req)) (nopt (if opt (length opt) 0)) (key (source-expression proc))) - (define (inlined-application) + (define (inlined-call) (make-let src (append req (or opt '()) @@ -1327,9 +1329,8 @@ top-level bindings from ENV and return the resulting expression." (if (> nargs (+ nreq nopt)) (append (list-head orig-args (+ nreq nopt)) (list - (make-application - #f - (make-primitive-ref #f 'list) + (make-primcall + #f 'list (drop orig-args (+ nreq nopt))))) (append orig-args (drop inits (- nargs nreq)) @@ -1341,8 +1342,7 @@ top-level bindings from ENV and return the resulting expression." (cond ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt)))) ;; An error, or effecting arguments. - (make-application src (for-call orig-proc) - (map for-value orig-args))) + (make-call src (for-call orig-proc) (map for-value orig-args))) ((or (and=> (find-counter key counter) counter-recursive?) (lambda? orig-proc)) ;; A recursive call, or a lambda in the operator @@ -1364,7 +1364,7 @@ top-level bindings from ENV and return the resulting expression." (lp (counter-prev counter))))))) (log 'inline-recurse key) - (loop (inlined-application) env counter ctx)) + (loop (inlined-call) env counter ctx)) (else ;; An integration at the top-level, the first ;; recursion of a recursive procedure, or a nested @@ -1374,8 +1374,8 @@ top-level bindings from ENV and return the resulting expression." (let/ec k (define (abort) (log 'inline-abort exp) - (k (make-application src (for-call orig-proc) - (map for-value orig-args)))) + (k (make-call src (for-call orig-proc) + (map for-value orig-args)))) (define new-counter (cond ;; These first two cases will transfer effort @@ -1395,7 +1395,7 @@ top-level bindings from ENV and return the resulting expression." (make-top-counter effort-limit operand-size-limit abort key)))) (define result - (loop (inlined-application) env new-counter ctx)) + (loop (inlined-call) env new-counter ctx)) (if counter ;; The nested inlining attempt succeeded. @@ -1420,7 +1420,7 @@ top-level bindings from ENV and return the resulting expression." (log 'inline-let orig-proc) (for-tail (make-let lsrc names syms vals - (make-application src body orig-args)))) + (make-call src body orig-args)))) ;; It's possible for a `let' to go away after the ;; visit due to the fact that visiting a procedure in ;; value context will prune unused bindings, whereas @@ -1428,11 +1428,10 @@ top-level bindings from ENV and return the resulting expression." ;; traverse through lambdas. In that case re-visit ;; the procedure. (proc (revisit-proc proc))) - (make-application src (for-call orig-proc) - (map for-value orig-args)))) + (make-call src (for-call orig-proc) + (map for-value orig-args)))) (_ - (make-application src (for-call orig-proc) - (map for-value orig-args)))))) + (make-call src (for-call orig-proc) (map for-value orig-args)))))) (($ <lambda> src meta body) (case ctx ((effect) (make-void #f)) @@ -1445,8 +1444,7 @@ top-level bindings from ENV and return the resulting expression." (define (lift-applied-lambda body gensyms) (and (not opt) rest (not kw) (match body - (($ <application> _ - ($ <primitive-ref> _ '@apply) + (($ <primcall> _ '@apply (($ <lambda> _ _ (and lcase ($ <lambda-case>))) ($ <lexical-ref> _ _ sym) ...)) @@ -1473,29 +1471,21 @@ top-level bindings from ENV and return the resulting expression." new body (and alt (for-tail alt)))))) - (($ <sequence> src exps) - (let lp ((exps exps) (effects '())) - (match exps - ((last) - (if (null? effects) - (for-tail last) - (make-sequence - src - (reverse (cons (for-tail last) effects))))) - ((head . rest) - (let ((head (for-effect head))) - (cond - ((sequence? head) - (lp (append (sequence-exps head) rest) effects)) - ((void? head) - (lp rest effects)) - (else - (lp rest (cons head effects))))))))) + (($ <seq> src head tail) + (let ((head (for-effect head)) + (tail (for-tail tail))) + (if (void? head) + tail + (make-seq src + (if (and (seq? head) + (void? (seq-tail head))) + (seq-head head) + head) + tail)))) (($ <prompt> src tag body handler) (define (make-prompt-tag? x) (match x - (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) - (or () ((? constant-expression?)))) + (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?)))) #t) (_ #f))) @@ -1527,11 +1517,11 @@ top-level bindings from ENV and return the resulting expression." (for-tail (make-let-values src - (make-application #f (make-primitive-ref #f 'apply) - `(,(make-primitive-ref #f 'values) - ,(make-primitive-ref #f 'values) - ,@(abort-args body) - ,(abort-tail body))) + (make-primcall #f 'apply + `(,(make-primitive-ref #f 'values) + ,(make-primitive-ref #f 'values) + ,@(abort-args body) + ,(abort-tail body))) (for-value handler))))) (else (make-prompt src tag body (for-value handler)))))) |