Racket: bad optimization in CS ?

[bennn]

(Long story)

I made some changes to Typed Racket. Before the changes, the expanded code for a small program looked like this and did not raise an exception:

(define ctc 'FOUNDING)
....
(contract ctc x ....)

After the changes, the expanded code looks like this and errors on CS 7.8, but not BC 7.8:

(define ctc (lambda (x) (eq? x 'FOUNDING)))
....
(if (ctc x) 'ok (raise-user-error 'die))

If I change my contract to (lambda (x) (void) (eq? x 'FOUNDING)) then the CS error goes away.

So I guess there is a problem with a CS optimization.

---

Here's the code I started with:

#lang typed/racket/base

(module uuu racket/base
  (define FOUNDING 'FOUNDING)
  (provide FOUNDING))

(require/typed/provide 'uuu
  (FOUNDING 'FOUNDING))

And here is the full raco expand output. It's the same for CS 7.8 and BC 7.8 after adding my changes to Typed Racket.

I added newlines around the important parts, which are near the bottom.

(module aaa typed/racket/base
  (#%module-begin
   (module configure-runtime '#%kernel (#%module-begin (#%require racket/runtime-config) (#%app configure '#f)))
   (#%require (submod typed-racket/private/type-contract predicates))
   (#%require typed-racket/utils/utils)
   (#%require (for-meta 1 typed-racket/utils/utils))
   (#%require typed-racket/utils/any-wrap)
   (#%require typed-racket/utils/struct-type-c)
   (#%require typed-racket/utils/prefab-c)
   (#%require typed-racket/utils/opaque-object)
   (#%require typed-racket/utils/evt-contract)
   (#%require typed-racket/utils/hash-contract)
   (#%require typed-racket/utils/vector-contract)
   (#%require typed-racket/utils/sealing-contract)
   (#%require typed-racket/utils/promise-not-name-contract)
   (#%require typed-racket/utils/simple-result-arrow)
   (#%require racket/sequence)
   (#%require racket/contract/parametric)
   (begin-for-syntax
    (module*
     #%type-decl
     #f
     (#%plain-module-begin
      (#%declare #:empty-namespace)
      (#%require typed-racket/types/numeric-tower)
      (#%require typed-racket/env/type-name-env)
      (#%require typed-racket/env/global-env)
      (#%require typed-racket/env/type-alias-env)
      (#%require typed-racket/types/struct-table)
      (#%require typed-racket/types/abbrev)
      (#%require
       (just-meta 0 (rename racket/private/sort raw-sort sort))
       (just-meta 0 (rename racket/private/sort vector-sort! vector-sort!))
       (just-meta 0 (rename racket/private/sort vector-sort vector-sort))
       (only racket/private/sort))
      (#%app register-type (t-quote-syntax FOUNDING1) (#%app make-Value 'FOUNDING))
      (#%app register-type (t-quote-syntax lifted/1) -False))))
   (begin-for-syntax (#%app add-mod! (#%app variable-reference->module-path-index (#%variable-reference))))
   (define-values
    (blame2)
    (#%app module-name-fixup (#%app variable-reference->module-source/submod (#%variable-reference)) (#%app list)))
   (begin-for-syntax
    (#%require typed-racket/utils/redirect-contract)
    (module #%contract-defs-reference racket/base
      (#%module-begin
       (module configure-runtime '#%kernel (#%module-begin (#%require racket/runtime-config) (#%app configure '#f)))
       (#%require racket/runtime-path)
       (#%require (for-meta 1 racket/base))
       (define-values
        (contract-defs-submod)
        (let-values (((contract-defs-submod)
                      (let-values (((runtime?) '#t))
                        (#%app list 'module '(submod ".." #%contract-defs) (#%variable-reference)))))
          (let-values (((get-dir) void))
            (#%app
             apply
             values
             (#%app resolve-paths (#%variable-reference) get-dir (#%app list contract-defs-submod))))))
       (begin-for-syntax
        (#%app
         register-ext-files
         (#%variable-reference)
         (let-values (((contract-defs-submod)
                       (let-values (((runtime?) '#f))
                         (#%app list 'module '(submod ".." #%contract-defs) (#%variable-reference)))))
           (#%app list contract-defs-submod))))
       (#%provide contract-defs-submod)))
    (#%require (submod "." #%contract-defs-reference))
    (define-values (make-redirect3) (#%app make-make-redirect-to-contract contract-defs-submod)))
   (module*
    #%contract-defs
    #f
    (#%plain-module-begin
     (#%declare #:empty-namespace)
     (#%require (submod typed-racket/private/type-contract predicates))
     (#%require typed-racket/utils/utils)
     (#%require (for-meta 1 typed-racket/utils/utils))
     (#%require typed-racket/utils/any-wrap)
     (#%require typed-racket/utils/struct-type-c)
     (#%require typed-racket/utils/prefab-c)
     (#%require typed-racket/utils/opaque-object)
     (#%require typed-racket/utils/evt-contract)
     (#%require typed-racket/utils/hash-contract)
     (#%require typed-racket/utils/vector-contract)
     (#%require typed-racket/utils/sealing-contract)
     (#%require typed-racket/utils/promise-not-name-contract)
     (#%require typed-racket/utils/simple-result-arrow)
     (#%require racket/sequence)
     (#%require racket/contract/parametric)))
   (module uuu racket/base
     (#%module-begin
      (module configure-runtime '#%kernel (#%module-begin (#%require racket/runtime-config) (#%app configure '#f)))
      (define-values (FOUNDING) 'FOUNDING)
      (#%provide FOUNDING)))

   (define-values (g5) (lambda (x) (#%app eq? x 'FOUNDING)))
   (define-values (lifted/1) g5)

   (define-values () (begin (quote-syntax (require/typed-internal FOUNDING1 'FOUNDING) #:local) (#%plain-app values)))
   (#%require (just-meta 0 (rename 'uuu FOUNDING FOUNDING)) (only 'uuu))
   (define-syntaxes
    (FOUNDING)
    (#%app
     make-rename-transformer
     (#%app
      syntax-property
      (#%app syntax-property (quote-syntax FOUNDING1) 'not-free-identifier=? '#t)
      'not-provide-all-defined
      '#t)))

   (define-values (FOUNDING1) (if (#%plain-app lifted/1 FOUNDING) FOUNDING (#%plain-app raise-user-error 'die)))

   (#%provide FOUNDING)
   (#%provide)
   (#%app void)))

Lastly, here are my changes to Typed Racket

diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt
index a773a59a..4b452a17 100644
--- a/typed-racket-lib/typed-racket/private/type-contract.rkt
+++ b/typed-racket-lib/typed-racket/private/type-contract.rkt
@@ -400,6 +400,9 @@
        [(Listof: elem-ty) (listof/sc (t->sc elem-ty))]
        ;; This comes before Base-ctc to use the Value-style logic
        ;; for the singleton base types (e.g. -Null, 1, etc)
+       [(Val-able: v)
+        #:when (symbol? v)
+        (flat/sc #`(lambda (x) (eq? x '#,v)))]
        [(Val-able: v)
         (if (and (c:flat-contract? v)
                  ;; numbers used as contracts compare with =, but TR
diff --git a/typed-racket-lib/typed-racket/utils/require-contract.rkt b/typed-racket-lib/typed-racket/utils/require-contract.rkt
index 05219dbf..d3306ca2 100644
--- a/typed-racket-lib/typed-racket/utils/require-contract.rkt
+++ b/typed-racket-lib/typed-racket/utils/require-contract.rkt
@@ -56,12 +56,9 @@
               (rename-without-provide nm.nm hidden)

               (define-ignored hidden
-                (contract cnt
-                          #,(get-alternate #'nm.orig-nm-r)
-                          '(interface for #,(syntax->datum #'nm.nm))
-                          (current-contract-region)
-                          (quote nm.nm)
-                          (quote-srcloc nm.nm))))]))
+                     (if (#%plain-app cnt #,(get-alternate #'nm.orig-nm-r))
+                       #,(get-alternate #'nm.orig-nm-r)
+                       (#%plain-app raise-user-error 'die))))]))

(I will try again later to make an example without Typed Racket.)

[gus-massa]

Running this with set PLT_LINKLET_SHOW_CP0=1 I get this (after a lot of minimization and a few small lies).

The first part is just the definition of the variable FOUNDING:

;; linklet ---------------------
(linklet (...)
  (define-values (FOUNDING) 'FOUNDING))
;; schemified ---------------------
(lambda (...)
  (define FOUNDING 'FOUNDING)
  (variable-set!/define FOUNDING3 FOUNDING 'consistent))
;; cp0 ---------------------
(lambda (...))
  (variable-set!/define FOUNDING3 'FOUNDING 'consistent))

The second part is more interesting:

;; linklet ---------------------
(linklet (...)
  (define-values (lifted/1.1) (lambda (x_2) (eq? x_2 'FOUNDING)))    ; there are a few renames that I'm simplifying.
  (if (lifted/1.1 FOUNDING) FOUNDING (raise-user-error 'die))) 
;; schemified ---------------------
(lambda (...)
  (call-with-module-prompt
    (lambda ()
      (if (eq? 'FOUNDING ''FOUNDING)                                 ; <-- the second FOUNDING has a double quote!
          'FOUNDING
          (raise-user-error 'die)))
      ...))
;; cp0 ---------------------
(lambda (...)
  (call-with-module-prompt
    (lambda () ((#3%$top-level-value '1/raise-user-error) 'die))
    ...))

[mflatt]

Based on @gus-massa's report, here's a small program:

#lang racket/base

(module a racket/base
  (provide FOUNDING)
  (define-values (FOUNDING) 'FOUNDING))

(module b racket/base
  (require (submod ".." a))
  (define (f x_2) (eq? x_2 'FOUNDING))
  (if (f FOUNDING) FOUNDING (raise-user-error 'die)))

(require (submod "." b))

Seems likely to be a problem with cross-module inlining in schemify.

[mflatt]

The problem is a missing quote pattern in schemify's optimize*. Things go wrong in this example because the quoted namee FOUNDING gets replaced by the value of the FOUNDING variable.