From 3aa16f2c26dc05c278f268417c7beee6eea6eaa9 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 6 Sep 2011 04:28:11 -0600
Subject: [PATCH] syntax/parse: speed up "is literal bound?" check

Can't do check completely statically, because phase of comparison
is expression (and even default is slightly unpredictable).
So instead compute whether check would succeed for likely phase
offsets, and use list of ok offsets as run-time fast path (memv
instead of identifier-binding).
---
 collects/syntax/parse/private/rep.rkt     |  8 ++----
 collects/syntax/parse/private/runtime.rkt | 31 ++++++++++++++++++-----
 2 files changed, 27 insertions(+), 12 deletions(-)

diff --git a/collects/syntax/parse/private/rep.rkt b/collects/syntax/parse/private/rep.rkt
index 69f3417c50..c0af86edb1 100644
--- a/collects/syntax/parse/private/rep.rkt
+++ b/collects/syntax/parse/private/rep.rkt
@@ -2,8 +2,7 @@
 (require (for-template racket/base
                        racket/stxparam
                        "keywords.rkt"
-                       "runtime.rkt"
-                       (only-in unstable/syntax phase-of-enclosing-module))
+                       "runtime.rkt")
          racket/contract/base
          "minimatch.rkt"
          syntax/id-table
@@ -1301,10 +1300,7 @@ A syntax class is integrable if
 ;; check-literal-entry : stx stx -> (list id id ct-phase ct-phase)
 (define (check-literal-entry stx ctx)
   (define (go internal external phase)
-    (txlift #`(check-literal (quote-syntax #,external)
-                             #,phase
-                             (phase-of-enclosing-module)
-                             (quote-syntax #,ctx)))
+    (txlift #`(check-literal #,external #,phase #,ctx))
     (list internal external phase phase))
   (syntax-case stx ()
     [(internal external #:phase phase)
diff --git a/collects/syntax/parse/private/runtime.rkt b/collects/syntax/parse/private/runtime.rkt
index 07f8f02a9e..a71919d0e0 100644
--- a/collects/syntax/parse/private/runtime.rkt
+++ b/collects/syntax/parse/private/runtime.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/list
          racket/stxparam
+         unstable/syntax
          "runtime-progress.rkt"
          "runtime-failure.rkt"
          (for-syntax racket/base
@@ -257,15 +258,33 @@
 (provide check-literal
          free-identifier=?/phases)
 
-;; check-literal : id phase-level phase-level stx -> void
-;; FIXME: change to normal 'error', if src gets stripped away
-(define (check-literal id abs-phase mod-phase ctx)
-  (unless (identifier-binding id abs-phase)
+;; (check-literal id phase-level-expr ctx) -> void
+(define-syntax (check-literal stx)
+  (syntax-case stx ()
+    [(check-literal id used-phase-expr ctx)
+     (let* ([ok-phases/ct-rel
+             ;; id is bound at each of ok-phases/ct-rel
+             ;; (phase relative to the compilation of the module in which the
+             ;; 'syntax-parse' (or related) form occurs)
+             (filter (lambda (p) (identifier-binding #'id p)) '(0 1 -1 #f))])
+       ;; so we can avoid run-time call to identifier-binding if
+       ;;   (+ (phase-of-enclosing-module) ok-phase/ct-rel) = used-phase
+       (with-syntax ([ok-phases/ct-rel ok-phases/ct-rel])
+         #'(check-literal* (quote-syntax id)
+                           used-phase-expr
+                           (phase-of-enclosing-module)
+                           'ok-phases/ct-rel
+                           (quote-syntax ctx))))]))
+
+(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx)
+  (unless (or (memv (and used-phase (- used-phase mod-phase))
+                    ok-phases/ct-rel)
+              (identifier-binding id used-phase))
     (raise-syntax-error
      #f
      (format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)"
-             abs-phase
-             (and abs-phase (- abs-phase mod-phase)))
+             used-phase
+             (and used-phase (- used-phase mod-phase)))
      ctx id)))
 
 ;; free-identifier=?/phases : id phase-level id phase-level -> boolean