From: Andy Wingo Date: Tue, 29 Oct 2013 21:57:29 +0000 (+0100) Subject: Add "pop" field to $prompt X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/96af4a18b89f52bb94eb0ef69898b7f6a059beaa Add "pop" field to $prompt * module/language/cps.scm ($prompt): Add a "pop" field, indicating the continuation at which this prompt is popped. The body of the prompt is dominated by the prompt, and post-dominated by the pop. Adapt all builders and users. * module/language/cps/closure-conversion.scm: * module/language/cps/compile-rtl.scm: * module/language/cps/slot-allocation.scm: * module/language/cps/verify.scm: * module/language/tree-il/compile-cps.scm: Adapt. * module/language/cps/dfg.scm (visit-fun): Add an arc from the pop to the handler, to keep handler variables alive through the prompt body. --- diff --git a/module/language/cps.scm b/module/language/cps.scm index ac5642ab6..d39124e70 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -85,7 +85,8 @@ ;;; - $prompt continues to the body of the prompt, having pushed on a ;;; prompt whose handler will continue at its "handler" ;;; continuation. The continuation of the prompt is responsible for -;;; popping the prompt. +;;; popping the prompt. A $prompt also records the continuation +;;; that pops the prompt, to make various static analyses easier. ;;; ;;; In summary: ;;; @@ -185,7 +186,7 @@ (define-cps-type $call proc args) (define-cps-type $primcall name args) (define-cps-type $values args) -(define-cps-type $prompt escape? tag handler) +(define-cps-type $prompt escape? tag handler pop) (define-syntax let-gensyms (syntax-rules () @@ -240,7 +241,8 @@ ((_ ($primcall name args)) (make-$primcall name args)) ((_ ($values (arg ...))) (make-$values (list arg ...))) ((_ ($values args)) (make-$values args)) - ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler)))) + ((_ ($prompt escape? tag handler pop)) + (make-$prompt escape? tag handler pop)))) (define-syntax build-cps-term (syntax-rules (unquote $letk $letk* $letconst $letrec $continue) @@ -340,8 +342,8 @@ (build-cps-exp ($primcall name arg))) (('values arg ...) (build-cps-exp ($values arg))) - (('prompt escape? tag handler) - (build-cps-exp ($prompt escape? tag handler))) + (('prompt escape? tag handler pop) + (build-cps-exp ($prompt escape? tag handler pop))) (_ (error "unexpected cps" exp)))) @@ -398,8 +400,8 @@ `(primcall ,name ,@args)) (($ $values args) `(values ,@args)) - (($ $prompt escape? tag handler) - `(prompt ,escape? ,tag ,handler)) + (($ $prompt escape? tag handler pop) + `(prompt ,escape? ,tag ,handler ,pop)) (_ (error "unexpected cps" exp)))) diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 9a9738b4a..05d9bdb40 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -217,12 +217,12 @@ convert functions to flat closures." ($continue k ($values args))) '())))) - (($ $continue k ($ $prompt escape? tag handler)) + (($ $continue k ($ $prompt escape? tag handler pop)) (convert-free-var tag self bound (lambda (tag) (values (build-cps-term - ($continue k ($prompt escape? tag handler))) + ($continue k ($prompt escape? tag handler pop))) '())))) (_ (error "what" exp)))) diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm index 26aa87b6d..6284eb089 100644 --- a/module/language/cps/compile-rtl.scm +++ b/module/language/cps/compile-rtl.scm @@ -272,7 +272,7 @@ (($ $primcall name args) (error "unhandled primcall in seq context" name)) (($ $values ()) #f) - (($ $prompt escape? tag handler) + (($ $prompt escape? tag handler pop) (match (lookup-cont handler cont-table) (($ $ktrunc ($ $arity req () rest () #f) khandler-body) (let ((receive-args (gensym "handler")) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm index 45c5dd617..69d5ae43a 100644 --- a/module/language/cps/dfg.scm +++ b/module/language/cps/dfg.scm @@ -655,9 +655,20 @@ (($ $values args) (for-each use! args)) - (($ $prompt escape? tag handler) + (($ $prompt escape? tag handler pop) (use! tag) - (use-k! handler)) + (use-k! handler) + ;; Any continuation in the prompt body could cause an abort to + ;; the handler, so in theory we could register the handler as + ;; a successor of any block in the prompt body. That would be + ;; inefficient, though, besides being a hack. Instead we take + ;; advantage of the fact that pop continuation post-dominates + ;; the prompt body, so we add a link from there to the + ;; handler. This creates a primcall node with multiple + ;; successors, which is not quite correct, but it does reflect + ;; control flow. It is necessary to ensure that the live + ;; variables in the handler are seen as live in the body. + (link-blocks! pop handler)) (($ $fun) (when global? diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 07f6e27d1..9d3dae871 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -402,7 +402,7 @@ are comparable with eqv?. A tmp slot may be used." live-slots live-slots* (compute-dst-slots)))) - (($ $prompt escape? tag handler) + (($ $prompt escape? tag handler pop) (match (lookup-cont handler (dfg-cont-table dfg)) (($ $ktrunc arity kargs) (let* ((live-slots (allocate-prompt-handler! label live-slots)) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index bb2e85751..76fad5109 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -132,10 +132,11 @@ (for-each (cut check-var <> v-env) arg)) (($ $values ((? symbol? arg) ...)) (for-each (cut check-var <> v-env) arg)) - (($ $prompt escape? tag handler) + (($ $prompt escape? tag handler pop) (unless (boolean? escape?) (error "escape? should be boolean" escape?)) (check-var tag v-env) - (check-var handler k-env)) + (check-var handler k-env) + (check-var pop k-env)) (_ (error "unexpected expression" exp)))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 7ea82b42c..1d686441f 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -387,7 +387,7 @@ ($letk ((kbody (tree-il-src body) ($kargs () () ,(convert body krest subst)))) - ($continue kbody ($prompt #t tag khargs)))) + ($continue kbody ($prompt #t tag khargs kpop)))) (convert-arg body (lambda (thunk) (build-cps-term @@ -397,7 +397,7 @@ ($primcall 'call-thunk/no-inline (thunk)))))) ($continue kbody - ($prompt #f tag khargs)))))))))))))) + ($prompt #f tag khargs kpop)))))))))))))) ;; Eta-convert prompts without inline handlers. (($ src escape-only? tag body handler)