├── .gitignore ├── .travis.yml ├── LICENSE.txt ├── README.md ├── info.rkt ├── main.rkt ├── private ├── compiler.rkt ├── components.rkt ├── generator.rkt ├── languages.rkt ├── optimizer.rkt ├── parser.rkt ├── passes.rkt ├── tests.rkt └── utils.rkt └── scribblings └── compiler2.scrbl /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | \#* 3 | .\#* 4 | .DS_Store 5 | compiled 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | # Based from: https://github.com/greghendershott/travis-racket 4 | 5 | # Optional: To use Travis CI's newer container infrastucture, 6 | # un-comment the following line. (Also be sure RACKET_DIR is set to 7 | # somewhere like ~/racket that doesn't require sudo.) 8 | # 9 | sudo: false 10 | 11 | env: 12 | global: 13 | # Supply a global RACKET_DIR environment variable. This is where 14 | # Racket will be installed. A good idea is to use ~/racket because 15 | # that doesn't require sudo to install and is therefore compatible 16 | # with Travis CI's newer container infrastructure. 17 | - RACKET_DIR=~/racket 18 | matrix: 19 | # Supply at least one RACKET_VERSION environment variable. This is 20 | # used by the install-racket.sh script (run at before_install, 21 | # below) to select the version of Racket to download and install. 22 | # 23 | # Supply more than one RACKET_VERSION (as in the example below) to 24 | # create a Travis-CI build matrix to test against multiple Racket 25 | # versions. 26 | # - RACKET_VERSION=5.3.4 27 | # - RACKET_VERSION=5.3.5 28 | # - RACKET_VERSION=5.92 29 | # - RACKET_VERSION=6.0 30 | # - RACKET_VERSION=6.1 31 | # - RACKET_VERSION=6.1.1 32 | # - RACKET_VERSION=6.2 33 | # - RACKET_VERSION=6.3 34 | # - RACKET_VERSION=6.4 35 | # - RACKET_VERSION=6.5 36 | - RACKET_VERSION=HEAD 37 | 38 | matrix: 39 | allow_failures: 40 | env: RACKET_VERSION=HEAD 41 | fast_finish: true 42 | 43 | before_install: 44 | - git clone https://github.com/greghendershott/travis-racket.git 45 | - cat travis-racket/install-racket.sh | bash # pipe to bash not sh! 46 | - export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us 47 | 48 | install: 49 | 50 | before_script: 51 | 52 | # Here supply steps such as raco make, raco test, etc. Note that you 53 | # need to supply /usr/racket/bin/ -- it's not in PATH. You can run 54 | # `raco pkg install --deps search-auto racket-compiler2` to install any required 55 | # packages without it getting stuck on a confirmation prompt. 56 | script: 57 | - raco pkg install --deps search-auto 58 | - raco test -x private/tests.rkt 59 | - raco pkg install --deps search-auto doc-coverage 60 | # - raco doc-coverage main.rkt 61 | 62 | after_success: 63 | - raco setup --check-deps zordoz 64 | - raco pkg install --deps search-auto cover 65 | - raco pkg install --deps search-auto cover-coveralls 66 | - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage . 67 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | compiler2 2 | Copyright (c) 2014 leif 3 | 4 | This package is distributed under the GNU Lesser General Public 5 | License (LGPL). This means that you can link compiler2 into proprietary 6 | applications, provided you follow the rules stated in the LGPL. You 7 | can also modify this package; if you distribute a modified version, 8 | you must distribute it under the terms of the LGPL, which in 9 | particular means that you must release the source code for the 10 | modified software. See http://www.gnu.org/copyleft/lesser.html 11 | for more information. 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | compiler2 2 | ========= 3 | Current status of a new racket compiler that uses [Nanopass][1] 4 | 5 | [![Build Status](https://travis-ci.org/LeifAndersen/racket-compiler2.svg?branch=master)](https://travis-ci.org/LeifAndersen/racket-compiler2) 6 | [![Coverage Status](https://coveralls.io/repos/LeifAndersen/racket-compiler2/badge.svg?branch=master&service=github)](https://coveralls.io/github/LeifAndersen/racket-compiler2?branch=master) 7 | 8 | # Features of Racket currently supported 9 | * Racket Expression Language 10 | * Primitive Functions 11 | * Top Level Definitions 12 | * Modules 13 | 14 | # Known missing (or partially complete) features 15 | * Syntax Objects 16 | * Syntax/Macro definitions 17 | * Require/Provide Specifications 18 | * Lots of optimizations 19 | 20 | # Files 21 | 22 | LICENSE.txt -- The license file for this repo 23 | README.md -- This Readme File. 24 | info.rkt -- Package dependencies for this compiler 25 | main.rkt -- The compiler itself, including tests 26 | scribblings/compiler2.scrbl -- The (currently missing) documentation 27 | 28 | [1]: http://nanopass.org 29 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "compiler2") 3 | (define deps '("base" 4 | "rackunit-lib" 5 | "nanopass" 6 | "zo-lib" 7 | "compiler-lib")) 8 | (define build-deps '("scribble-lib" "racket-doc")) 9 | (define scribblings '(("scribblings/compiler2.scrbl" ()))) 10 | (define pkg-desc "Description Here") 11 | (define version "0.0") 12 | (define pkg-authors '(leif)) 13 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide compile) 4 | 5 | (require "private/languages.rkt" 6 | "private/utils.rkt" 7 | "private/components.rkt" 8 | "private/compiler.rkt") 9 | 10 | (define orig (current-compile)) 11 | 12 | (define in-compile? (make-parameter #f)) 13 | 14 | (current-compile 15 | (λ (prog use) 16 | (define freeze-in-compile? (in-compile?)) 17 | (parameterize ([in-compile? #t]) 18 | (if freeze-in-compile? 19 | (orig prog use) 20 | (compile prog))))) 21 | -------------------------------------------------------------------------------- /private/compiler.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out) 4 | compile) 5 | 6 | (require racket/port 7 | compiler/zo-marshal 8 | syntax/toplevel 9 | "languages.rkt" 10 | "parser.rkt" 11 | "passes.rkt" 12 | "optimizer.rkt" 13 | "generator.rkt" 14 | "utils.rkt" 15 | "components.rkt") 16 | 17 | ;; Expand syntax fully, even at the top level 18 | (define (expand-syntax* stx) 19 | (parameterize ([current-namespace (make-base-namespace)]) 20 | (namespace-require 'racket/undefined) 21 | (namespace-require 'racket) 22 | (expand-syntax-top-level-with-compile-time-evals 23 | (namespace-syntax-introduce stx)))) 24 | 25 | (define (bytes->compiled-expression zo) 26 | (parameterize ([read-accept-compiled #t]) 27 | (with-input-from-bytes zo 28 | (lambda () (read))))) 29 | 30 | (define closure-conversion (make-compiler-component)) 31 | (define optimizer (make-compiler-component)) 32 | (define mutable-variable-elimination (make-compiler-component)) 33 | (define debruijn (make-compiler-component)) 34 | (define parse (make-compiler-component)) 35 | (define generate-bytecode (make-compiler-component)) 36 | (define modules (make-compiler-component)) 37 | 38 | (define-compiler compile 39 | expand-syntax* 40 | disarm* 41 | (parse-and-rename parse) 42 | (lift-submodules modules) 43 | (lift-require-provide modules) 44 | (lift-syntax-sequences modules) 45 | (identify-module-variables modules) 46 | (scrub-require-provide modules) 47 | (add-indirect-provide modules) 48 | (make-begin-explicit parse) 49 | (identify-assigned-variables mutable-variable-elimination) 50 | purify-letrec 51 | (inline-expressions optimizer) 52 | (convert-assignments mutable-variable-elimination) 53 | (uncover-free closure-conversion) 54 | raise-toplevel-variables 55 | closurify-letrec 56 | void-lets 57 | scrub-syntax 58 | reintroduce-syntax 59 | (debruijn-indices debruijn) 60 | (find-let-depth debruijn) 61 | build-module-registry 62 | (generate-zo-structs generate-bytecode) 63 | (zo-marshal generate-bytecode) 64 | bytes->compiled-expression) 65 | 66 | (current-variable-printer debug-variable-printer) 67 | (current-module-binding-printer module-binding-printer) 68 | (current-module-registry-printer debug-module-registry-printer) 69 | (require nanopass/base) 70 | 71 | (define code #'(begin 72 | (module foo racket 73 | (#%plain-module-begin 74 | (provide x) 75 | (define x 481))) 76 | (require 'foo) 77 | x)) 78 | 79 | #;(define code #'(module foo racket 80 | (#%plain-module-begin 81 | dict-set))) 82 | 83 | ;(define code #'dict-set) 84 | 85 | ;(compile/8 code) 86 | ;(compile/22 code) 87 | ;(compile/23 code) 88 | ;(compile code) 89 | ;(eval (compile/24 code)) 90 | -------------------------------------------------------------------------------- /private/components.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (except-in nanopass/base 4 | define-language 5 | define-pass) 6 | (rename-in nanopass/base 7 | [define-language nanopass:define-language] 8 | [define-pass nanopass:define-pass]) 9 | racket/splicing 10 | rackunit 11 | (rename-in racket/base 12 | [compile base:compile] 13 | [current-compile base:current-compile]) 14 | (for-syntax racket/base 15 | syntax/parse 16 | racket/syntax) 17 | "utils.rkt") 18 | 19 | (provide make-compiler-component 20 | add-pass-to-component! 21 | define-compiler 22 | (struct-out compiler-component) 23 | add-pass-to-component! 24 | variable-add-property! 25 | variable-update-property! 26 | variable-get-property) 27 | 28 | ; Representation of a compiler component 29 | ; passes : (Listof Procedure) 30 | ; insertion-procs : (HashTable Symbol (Setof (-> Any Any)) 31 | (struct compiler-component (passes 32 | insertion-procs) 33 | #:mutable) 34 | (define (make-compiler-component [passes '()] 35 | [insertion-procs (make-hash 36 | (list 37 | (list 'pre (mutable-set)) 38 | (list 'post (mutable-set))))]) 39 | (compiler-component passes insertion-procs)) 40 | 41 | ; Add a compiler pass to a component 42 | ; (to be used by define-compiler) 43 | ; (Adds back to front) 44 | (define (add-pass-to-component! component pass) 45 | (set-compiler-component-passes! component (cons pass (compiler-component-passes component)))) 46 | 47 | (begin-for-syntax 48 | (define-syntax-class pass 49 | (pattern name:id 50 | #:attr [components 1] '()) 51 | (pattern (name:id components:id ...)))) 52 | 53 | ; Key object to be used in variable properties table 54 | (struct key ()) 55 | 56 | ; Adds a property to a variable. Returns a key that must be used 57 | ; to get property out again. 58 | ; Variable Any -> Key 59 | (define (variable-add-property! variable property) 60 | (define k (key)) 61 | (dict-set! (variable-properties variable) k property) 62 | k) 63 | 64 | ; Updates the property attached to a specific variable and key. 65 | ; Returns the old property that was there. 66 | ; Errors if variable does not have a property for the key. 67 | ; Variable Key (-> Any Any) -> Any 68 | (define (variable-update-property! variable key property-thunk) 69 | (dict-update! 70 | (dict-update! (variable-properties variable) key 71 | (lambda () 72 | (raise (exn:fail:contract (format "Variable ~a does not contain key ~a" 73 | variable key) 74 | (current-continuation-marks))))))) 75 | 76 | ; Retrieves a property from a variable given a key. 77 | ; Errors if variable does not have a property for the key 78 | ; Variable Key -> Any 79 | (define (variable-get-property variable key) 80 | (dict-ref (variable-properties variable) key 81 | (lambda () 82 | (raise (exn:fail:contract (format "Variable ~a does not contain key: ~a" variable key) 83 | (current-continuation-marks)))))) 84 | 85 | ; Adds a procedure to a component 86 | ; The location field is currently either 'pre or 'post 87 | ; As we learn more about what valid locations should be, that will change. 88 | ; Possibly even make it possible for a component to state what valid locations are. 89 | ; Component Symbol (-> Any Any) -> Void 90 | (define (component-add-proc! component location proc) 91 | (define insertion-procs (compiler-component-insertion-procs component)) 92 | (unless (hash-has-key? location) 93 | (raise (exn:fail:contract (format "Compiler Component ~a does not contain location: ~a" 94 | component location) 95 | (current-continuation-marks))))) 96 | 97 | ; Returns a setof of all valid locations in the compiler component 98 | ; Component -> (Setof Symbol) 99 | (define (compiler-component-insert-locations component) 100 | (dict-keys (compiler-component-insertion-procs component))) 101 | 102 | (define-syntax (define-compiler stx) 103 | (syntax-parse stx 104 | [(_ name:id passes:pass ...+) 105 | #:with compilers (format-id stx "compilers") 106 | (define pass-names (reverse (syntax->list #'(passes.name ...)))) 107 | (define pass-components (reverse (syntax->list #'((passes.components ...) ...)))) 108 | ;; Bind the compiler name to the compiler. 109 | #`(begin (define name (compose #,@pass-names)) 110 | 111 | ;; Add each of the pass to there respective components 112 | #,@(for/list ([pn (in-list pass-names)] 113 | (pc (in-list pass-components))) 114 | #`(begin 115 | #,@(for/list ([pc* (in-list (syntax->list pc))]) 116 | #`(add-pass-to-component! #,pc* #,pn)))) 117 | 118 | ;; Create intermediate compilers for use in test casses 119 | (define compilers null) 120 | #,@(let build-partial-compiler ([passes pass-names] 121 | [pass-count (length pass-names)]) 122 | (if (= pass-count 0) 123 | '() 124 | (with-syntax ([name* (format-id stx "~a/~a" #'name (- pass-count 1))]) 125 | (list* #`(define name* (compose #,@passes)) 126 | #`(set! compilers (cons name* compilers)) 127 | (if (identifier? (car passes)) 128 | (with-syntax ([name** (format-id stx 129 | "~a/~a" 130 | #'name 131 | (car passes))]) 132 | (cons #`(define name** name*) 133 | (build-partial-compiler (cdr passes) (- pass-count 1)))) 134 | (build-partial-compiler (cdr passes) (- pass-count 1))))))))])) 135 | -------------------------------------------------------------------------------- /private/generator.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require nanopass/base 6 | syntax/parse 7 | racket/match 8 | racket/set 9 | racket/dict 10 | racket/hash 11 | racket/port 12 | racket/list 13 | racket/function 14 | racket/bool 15 | racket/stxparam 16 | racket/stxparam-exptime 17 | racket/block 18 | racket/splicing 19 | syntax/modresolve 20 | compiler/zo-marshal 21 | syntax/toplevel 22 | syntax/strip-context 23 | rackunit 24 | (prefix-in zo: compiler/zo-structs) 25 | (rename-in racket/base 26 | [compile base:compile] 27 | [current-compile base:current-compile]) 28 | (for-syntax racket/base 29 | syntax/parse 30 | racket/syntax 31 | racket/stxparam 32 | racket/stxparam-exptime) 33 | "languages.rkt" 34 | "utils.rkt") 35 | 36 | (define current-module-registry (make-parameter #f)) 37 | 38 | ;; Converts a variable structure into the type of variable zo bytecode 39 | ;; expects. 40 | ;; Variable -> (U Symbol Module-Variable Global-Bucket) 41 | (define (variable->zo-variable v) 42 | (define binding (variable-binding v)) 43 | (cond [(module-binding? binding) 44 | (zo:module-variable (module-binding-source-mod binding) 45 | (module-binding-source-id binding) 46 | (module-binding->offset (module-binding-source-mod binding) 47 | (module-binding-source-id binding) 48 | (module-binding-source-phase binding)) 49 | (module-binding-source-phase binding) 50 | #f)] 51 | [else 52 | (variable-name v)])) 53 | 54 | ;; Module-Path Symbol Exact-Nonneagtive-Integer -> Exact-Nonnegative-Integer 55 | (define (module-binding->offset mod v phase) 56 | (define-values (mod* internal-mod?) 57 | (let* ([m (resolve-module-path-index mod (string->path "."))] 58 | [m* (convert-module-path (current-module-registry) m)]) 59 | (cond 60 | [(and m* 61 | (module-in-registry? (current-module-registry) m*)) 62 | (values m* #t)] 63 | [(symbol? m) (values mod #f)] 64 | [else (values m #f)]))) 65 | (cond 66 | [internal-mod? 67 | (define index (module->variable-index (current-module-registry) mod* v phase)) 68 | (or index -1)] 69 | [else 70 | (dynamic-require mod* (void)) 71 | (define-values (exports transformers) 72 | (module->exports mod*)) 73 | (define indirect-exports (module->indirect-exports mod*)) 74 | (define exports* (dict-ref exports phase #f)) 75 | (define transformers* (dict-ref exports phase #f)) 76 | (define indirect-exports* (dict-ref indirect-exports phase #f)) 77 | (cond 78 | [(not exports*) -1] 79 | [(dict-has-key? exports* v) 80 | (define e (dict-keys exports*)) 81 | (- (length e) (length (memq v e)))] 82 | [(set-member? indirect-exports* v) 83 | (define e indirect-exports*) 84 | (+ (length (dict-keys exports*)) 85 | (- (length e) (length (memq v e))))] 86 | [else -1])])) 87 | 88 | (define zo-void 89 | (zo:primval 35)) 90 | 91 | (define-pass generate-zo-structs : Lbuildmoduleregistry (e) -> * () 92 | (CompilationTop : compilation-top (e) -> * () 93 | [(program ,prefix-form ,module-registry ,top-level-form) 94 | (parameterize ([current-module-registry module-registry]) 95 | (define-values (prefix max-let-depth) (PrefixForm prefix-form)) 96 | (zo:compilation-top 97 | max-let-depth 98 | (hash) 99 | prefix 100 | (TopLevelForm top-level-form)))]) 101 | (PrefixForm : prefix-form (e) -> * (0) 102 | [(prefix (,binding ...) (,stx ...) ,eni) 103 | (values 104 | (zo:prefix 105 | 0 106 | ;; TODO, only need #f if there are modules 107 | (append (map (lambda (x) (and x (variable->zo-variable x))) binding) 108 | (if (null? stx) '(#f) '())) 109 | stx 110 | 'missing) 111 | eni)]) 112 | (TopLevelForm : top-level-form (e) -> * () 113 | [(#%expression ,expr) 114 | (Expr expr)] 115 | [(begin* ,top-level-form ...) 116 | (zo:splice (map TopLevelForm top-level-form))] 117 | [(#%require ,raw-require-spec ...) 118 | (void)] 119 | [(begin-for-syntax* ,prefix-form ,top-level-form ...) 120 | (void)] 121 | [(define-syntaxes* (,v ...) ,prefix-form ,expr) 122 | (void)]) 123 | (ModuleLevelForm : module-level-form (e) -> * () 124 | [(#%declare ,declaration-keyword ...) 125 | (void)]) 126 | (SubmoduleForm : submodule-form (e) -> * () 127 | [(module ,id ,module-path ,prefix-form 128 | (,raw-provide-spec ...) 129 | (,raw-require-spec ...) 130 | (,raw-provide-spec* ...) 131 | (,module-level-form ...) 132 | (,syntax-level-form ...) 133 | (,submodule-form ...) 134 | (,submodule-form* ...)) 135 | (parameterize ([(module-registry->current-module-path (current-module-registry)) 136 | (append ((module-registry->current-module-path 137 | (current-module-registry))) 138 | (list id))]) 139 | (define-values (prefix max-let-depth) (PrefixForm prefix-form)) 140 | (zo:mod id 141 | id 142 | (module-path-index-join #f #f) 143 | prefix 144 | (map RawProvideSpec raw-provide-spec) 145 | (map RawRequireSpec 146 | (cons (with-output-language (Lbuildmoduleregistry raw-require-spec) 147 | `(for-meta 0 ,module-path)) 148 | raw-require-spec)) 149 | (map ModuleLevelForm module-level-form) 150 | '() 151 | '() 152 | max-let-depth 153 | (zo:toplevel 0 0 #f #f) 154 | #f 155 | #t 156 | (hash) 157 | '() 158 | (map SubmoduleForm submodule-form) 159 | (map SubmoduleForm submodule-form*)))]) 160 | (GeneralTopLevelForm : general-top-level-form (e) -> * () 161 | [(define-values (,eni ...) ,expr) 162 | (zo:def-values (for/list ([i (in-list eni)]) 163 | (zo:toplevel 0 i #f #f)) 164 | (Expr expr))]) 165 | (Bidnding : binding (e) -> * () 166 | [,false false] 167 | [,v v] 168 | [,eni eni] 169 | [(primitive ,eni) 170 | (zo:primval eni)]) 171 | (Expr : expr (e) -> * () 172 | [,eni (zo:localref #f eni #f #f #f)] 173 | [(closure ,v ,lambda) (zo:closure (Lambda lambda) (variable-name v))] 174 | [(primitive ,eni) 175 | (zo:primval eni)] 176 | [(quote-syntax ,eni1 ,eni2) (zo:topsyntax eni1 eni2 0)] 177 | [(#%top ,eni1 ,eni2) (zo:toplevel eni1 eni2 #f #f)] 178 | [(#%unbox ,eni) 179 | (zo:localref #t eni #f #f #f)] 180 | [(#%box ,eni) 181 | (zo:boxenv eni zo-void)] 182 | [(begin 183 | (set!-values ,eni1 ,eni2 (#%box ,eni3)) 184 | ,expr) 185 | (guard (and (= eni2 eni3) (= eni1 1))) 186 | (zo:boxenv eni2 (Expr expr))] 187 | [(begin 188 | (set!-boxes ,eni1 ,eni2 ,expr) 189 | ,expr*) 190 | (zo:install-value eni1 eni2 #t (Expr expr) (Expr expr*))] 191 | [(set!-values ,eni1 ,eni2 ,expr) 192 | (zo:install-value eni1 eni2 #f (Expr expr) zo-void)] 193 | [(set!-boxes ,eni1 ,eni2 ,expr) 194 | (zo:install-value eni1 eni2 #t (Expr expr) zo-void)] 195 | [(set!-global ,eni1 ,eni2 ,expr) 196 | (zo:assign (zo:toplevel eni1 eni2 #f #f) (Expr expr) #f)] 197 | [(letrec (,lambda ...) ,expr) 198 | (zo:let-rec (map Lambda lambda) (Expr expr))] 199 | [(let-one ,expr1 ,expr) 200 | (zo:let-one (Expr expr1) (Expr expr) #f #f)] 201 | [(let-void ,eni ,expr) 202 | (zo:let-void eni #f (Expr expr))] 203 | [(case-lambda ,lambda ...) 204 | (zo:case-lam #() (map Lambda lambda))] 205 | [(if ,expr1 ,expr2 ,expr3) 206 | (zo:branch (Expr expr1) (Expr expr2) (Expr expr3))] 207 | [(begin ,expr* ... ,expr) 208 | (zo:seq (append (map Expr expr*) 209 | (list (Expr expr))))] 210 | [(begin0 ,expr ,expr* ...) 211 | (zo:beg0 (cons (Expr expr) (map Expr expr*)))] 212 | [(quote ,datum) datum] 213 | [(with-continuation-mark ,expr1 ,expr2 ,expr3) 214 | (zo:with-cont-mark (Expr expr1) (Expr expr2) (Expr expr3))] 215 | [(#%plain-app ,expr ,expr* ...) 216 | (zo:application (Expr expr) (map Expr expr*))] 217 | [(#%variable-reference-top ,eni) 218 | (zo:varref (zo:toplevel 0 0 #f #f) (zo:toplevel 0 0 #f #f))] 219 | [(#%variable-reference ,eni) 220 | (zo:varref (zo:toplevel 0 0 #f #f) (zo:toplevel 0 0 #f #f))] 221 | [(#%variable-reference-none ,eni1 ,eni2) 222 | (zo:varref (zo:toplevel eni1 eni2 #f #f) (zo:toplevel eni1 eni2 #f #f))]) 223 | (Lambda : lambda (e) -> * () 224 | [(#%plain-lambda ,eni ,boolean (,binding2 ...) (,binding3 ...) ,eni4 ,expr) 225 | (zo:lam (gensym) 226 | null 227 | (if boolean (- eni 1) eni) 228 | (for/list ([i (in-range (if boolean (- eni 1) eni))]) 229 | 'val) 230 | boolean 231 | (list->vector binding2) 232 | (map (lambda (x) 'val/ref) binding2) 233 | (if (null? binding3) #f (list->set binding3)) 234 | eni4 235 | (Expr expr))]) 236 | (RawProvideSpec : raw-provide-spec (e) -> * () 237 | [(for-meta* ,phase-level 238 | (,phaseless-prov-spec ...) 239 | (,phaseless-prov-spec* ...)) 240 | (list phase-level 241 | (map PhaselessProvSpec phaseless-prov-spec) 242 | (map PhaselessProvSpec phaseless-prov-spec*))]) 243 | (PhaselessProvSpec : phaseless-prov-spec (e) -> * () 244 | [,v 245 | (define binding (variable-binding v)) 246 | (zo:provided (module-binding-source-id binding) 247 | (module-binding-source-mod binding) 248 | (module-binding-nominal-source-id binding) 249 | (module-binding-nominal-source-mod binding) 250 | (module-binding-source-phase binding) 251 | #f)] 252 | [(rename* ,v1 ,v2) 253 | (void)] 254 | [(protect ,v) 255 | (void)] 256 | [(protect-rename* ,v1 ,v2) 257 | (void)]) 258 | (RawRequireSpec : raw-require-spec (e) -> * () 259 | [(for-meta ,phase-level ,phaseless-req-spec ...) 260 | (cons phase-level (map PhaselessReqSpec phaseless-req-spec))]) 261 | (PhaselessReqSpec : phaseless-req-spec (e) -> * () 262 | [(rename ,raw-module-path ,v1 ,v2) 263 | (void)]) 264 | (RawModulePath : raw-module-path (e) -> * () 265 | [(submod ,raw-root-module-path ,id ...) 266 | (void)]) 267 | (RawRootModulePath : raw-root-module-path (e) -> * () 268 | [,id (module-path-index-join id #f)] 269 | [,string (void)] 270 | [(quote* ,id) (void)] 271 | [(lib ,string ...) (void)] 272 | [(file ,string) (void)] 273 | [(planet ,string1 274 | (,string2 ,string3 ,string* ...)) 275 | (void)] 276 | [,path (void)])) 277 | -------------------------------------------------------------------------------- /private/languages.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | (require nanopass/base 5 | racket/bool 6 | "utils.rkt") 7 | 8 | (define-language Lsrc 9 | (terminals 10 | (maybe-module-path (maybe-module-path module-path)) 11 | (declaration-keyword (declaration-keyword)) 12 | (datum (datum)) 13 | (symbol (id)) 14 | (vector (vector)) 15 | (variable (v var variable)) 16 | (string (string)) 17 | (path (path)) 18 | (phase-level (phase-level)) 19 | (false (false)) 20 | (exact-nonnegative-integer (exact-nonnegative-integer eni)) 21 | (boolean (boolean)) 22 | (number (number)) 23 | (bytes (bytes)) 24 | (name (name import-key)) 25 | (procedure (procedure))) 26 | (linklet-form (linklet-form) 27 | (linklet (((linklet-reqprov-element import-key) ...) ...) ; require field 28 | (linklet-reqprov-element* ...) ; provide field 29 | name 30 | get-import 31 | general-top-level-form ...)) 32 | (linklet-reqprov-element (linklet-reqprov-element) 33 | id 34 | (id id*)) 35 | (get-import (get-import) 36 | procedure 37 | false) 38 | (binding (binding local-binding global-binding) 39 | v 40 | false) 41 | (general-top-level-form (general-top-level-form) 42 | expr 43 | (define-values (v ...) expr)) 44 | (expr (expr) 45 | v 46 | number 47 | boolean 48 | string 49 | bytes 50 | lambda 51 | (primitive id) 52 | (case-lambda lambda ...) 53 | (if expr1 expr2 expr3) 54 | (begin expr* ... expr) 55 | (begin0 expr expr* ...) 56 | (let-values ([(v ...) expr1] ...) 57 | expr) 58 | (letrec-values ([(v ...) expr1] ...) 59 | expr) 60 | (set! v expr) 61 | (quote datum) 62 | (with-continuation-mark expr1 expr2 expr3) 63 | (#%plain-app expr expr* ...) 64 | (#%variable-reference v) 65 | (#%variable-reference)) 66 | (lambda (lambda) 67 | (#%plain-lambda formals expr)) 68 | (formals (formals) 69 | v 70 | (v ...) 71 | (v v* ... . v2))) 72 | 73 | (define-language Lidentifyassigned 74 | (extends Lsrc) 75 | (lambda (lambda) 76 | (- (#%plain-lambda formals expr)) 77 | (+ (#%plain-lambda formals abody))) 78 | (expr (expr) 79 | (- (let-values ([(v ...) expr1] ...) 80 | expr) 81 | (letrec-values ([(v ...) expr1] ...) 82 | expr)) 83 | (+ (let-values ([(v ...) expr1] ...) 84 | abody) 85 | (letrec-values ([(v ...) expr1] ...) 86 | abody))) 87 | (assigned-body (abody) 88 | (+ (assigned (v ...) expr)))) 89 | 90 | (define-language Lpurifyletrec 91 | (extends Lidentifyassigned) 92 | (expr (expr) 93 | (- (let-values ([(v ...) expr1] ...) 94 | abody) 95 | (letrec-values ([(v ...) expr1] ...) 96 | abody) 97 | (set! v expr) 98 | (quote datum)) 99 | (+ set-expr 100 | (undefined) 101 | (let ([v expr1] ...) 102 | set-abody) 103 | (letrec ([v lambda] ...) 104 | expr))) 105 | (lambda (lambda) 106 | (+ (quote datum))) 107 | (set-expr (set-expr) 108 | (+ (set!-values (v ...) expr))) 109 | (set-abody (set-abody) 110 | (+ (begin-set! set-expr ... abody)))) 111 | 112 | (define-language Lconvertassignments 113 | (extends Lpurifyletrec) 114 | (expr (expr) 115 | (- set-expr 116 | (let ([v expr1] ...) 117 | set-abody)) 118 | (+ (quote datum) 119 | (let ([v expr1] ...) 120 | expr) 121 | (#%unbox v) 122 | (#%box v) 123 | (set!-values (v ...) expr) 124 | (set!-boxes (v ...) expr))) 125 | (lambda (lambda) 126 | (- (#%plain-lambda formals abody) 127 | (quote datum)) 128 | (+ (#%plain-lambda formals expr))) 129 | (set-abody (set-abody) 130 | (- (begin-set! set-expr ... abody))) 131 | (set-expr (set-expr) 132 | (- (set!-values (v ...) expr))) 133 | (assigned-body (abody) 134 | (- (assigned (v ...) expr)))) 135 | 136 | (define-language Luncoverfree 137 | (extends Lconvertassignments) 138 | (lambda (lambda) 139 | (- (#%plain-lambda formals expr)) 140 | (+ (#%plain-lambda formals fbody))) 141 | (free-body (fbody) 142 | (+ (free (v ...) (binding* ...) expr)))) 143 | 144 | (define-language Lclosurify 145 | (extends Luncoverfree) 146 | (expr (expr) 147 | (+ (closure v lambda)))) 148 | 149 | (define-language Lvoidlets 150 | (extends Lclosurify) 151 | (expr (expr) 152 | (- (let ([v expr1] ...) expr) 153 | (undefined)) 154 | (+ (let ([v expr1]) expr) 155 | (let-void (v ...) expr)))) 156 | 157 | (define-language Ldebruijn 158 | (extends Lvoidlets) 159 | (terminals 160 | (- (exact-nonnegative-integer (exact-nonnegative-integer eni))) 161 | (+ (exact-nonnegative-integer (exact-nonnegative-integer 162 | eni 163 | arg-count 164 | max-let-depth)))) 165 | (expr (expr) 166 | (- v 167 | (primitive id) 168 | (let-void (v ...) expr) 169 | (let ([v expr1]) expr) 170 | (letrec ([v lambda] ...) 171 | expr) 172 | (set!-boxes (v ...) expr) 173 | (set!-values (v ...) expr) 174 | (#%box v) 175 | (#%unbox v) 176 | (#%variable-reference) 177 | (#%variable-reference v)) 178 | (+ binding 179 | (primitive eni) 180 | (let-void eni expr) 181 | (let-one expr1 expr) 182 | (letrec (lambda ...) 183 | expr) 184 | (set!-boxes eni1 eni2 expr) 185 | (set!-values eni1 eni2 expr) 186 | (#%box eni) 187 | (#%unbox eni) 188 | (#%variable-reference eni))) 189 | (general-top-level-form (general-top-level-form) 190 | (- (define-values (v ...) expr)) 191 | (+ (define-values (eni ...) expr))) 192 | (lambda (lambda) 193 | (- (#%plain-lambda formals fbody)) 194 | (+ (#%plain-lambda arg-count boolean (local-binding ...) (global-binding ...) expr))) 195 | (binding (binding) 196 | (+ eni 197 | (primitive eni))) 198 | (formals (formals) 199 | (- v 200 | (v ...) 201 | (v v* ... . v2))) 202 | (free-body (fbody) 203 | (- (free (v ...) (binding* ...) expr)))) 204 | 205 | (define-language Lcleanreqprov 206 | (extends Ldebruijn) 207 | (terminals 208 | (- (symbol (id))) 209 | (+ (symbol (id req-id prov-id intern-id lift-id)))) 210 | (linklet-form (linklet-form) 211 | (- (linklet (((linklet-reqprov-element import-key) ...) ...) 212 | (linklet-reqprov-element* ...) 213 | name 214 | get-import 215 | general-top-level-form ...)) 216 | (+ (linklet (((req-id import-key) ...) ...) ; Require field 217 | (prov-id ...) ; Provide field 218 | (intern-id ...) ; Internal field 219 | (lift-id ...) ; lifted field 220 | name 221 | get-import 222 | general-top-level-form ...)))) 223 | 224 | (define-language Lfindletdepth 225 | (extends Lcleanreqprov) 226 | (entry compilation-top) 227 | (linklet-form (linklet-form) 228 | (- (linklet (((req-id import-key) ...) ...) 229 | (prov-id ...) 230 | (intern-id ...) 231 | (lift-id ...) 232 | name 233 | get-import 234 | general-top-level-form ...)) 235 | (+ (linklet (((req-id import-key) ...) ...) 236 | (prov-id ...) 237 | (intern-id ...) 238 | (lift-id ...) 239 | name 240 | get-import 241 | eni 242 | general-top-level-form ...))) 243 | (lambda (lambda) 244 | (- (#%plain-lambda arg-count boolean (local-binding ...) (global-binding ...) expr)) 245 | (+ (#%plain-lambda arg-count boolean (local-binding ...) (global-binding ...) max-let-depth 246 | expr)))) 247 | -------------------------------------------------------------------------------- /private/optimizer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (rename-out [~inline-expressions inline-expressions])) 4 | 5 | (require nanopass/base 6 | racket/match 7 | racket/set 8 | racket/dict 9 | racket/hash 10 | racket/port 11 | racket/list 12 | racket/function 13 | syntax/strip-context 14 | (for-syntax racket/base 15 | syntax/parse 16 | racket/syntax 17 | racket/stxparam 18 | racket/stxparam-exptime) 19 | "languages.rkt" 20 | "utils.rkt" 21 | "components.rkt") 22 | 23 | ;(current-variable-printer debug-variable-printer) 24 | 25 | ;; App context, for storing valid functions 26 | ;; Valid contexts are 'test 'value 'effect, and other 27 | ;; app contexts 28 | (struct app (operands 29 | context 30 | [inlined? #:auto]) 31 | #:mutable 32 | #:auto-value #f) 33 | 34 | (struct counter (value 35 | context 36 | k) 37 | #:mutable) 38 | (define (make-counter value 39 | #:context [context #f] 40 | #:k [k (lambda (x) (error "No outer Continuation"))]) 41 | (counter value context k)) 42 | 43 | (define current-inline-size-limit (make-parameter 1000)) 44 | (define current-inline-effort-limit (make-parameter 1000)) 45 | (define current-passive-counter-default-value (make-parameter (+ 10000 46 | (current-inline-size-limit) 47 | (current-inline-effort-limit)))) 48 | (current-outer-pending-default-fuel 10) 49 | 50 | ; Determine if this primitive is one that is effect free 51 | ; eg, cons, list, cdr, etc. 52 | ; Symbol -> Boolean 53 | (define (effect-free? primitive) 54 | (define effect-free-set 55 | (set 'void)) 56 | (cond 57 | [(set-member? effect-free-set primitive) #t] 58 | [(foldable? primitive) #t] 59 | [else #f])) 60 | 61 | ; Determins if this primitive is one that will always return true 62 | ; eg. list, cons 63 | ; Symbol -> Boolean 64 | (define (return-true? primitive) 65 | (define return-true-set 66 | (set 'cons 'list 'random)) 67 | (cond [(set-member? return-true-set primitive) #t] 68 | [else #f])) 69 | 70 | ; Determine if this primitive is foldable 71 | ; eg +, -, etc. 72 | ; Symbol -> Boolean 73 | (define (foldable? primitive) 74 | (define foldable-set 75 | (set '+ '- '* '/ '= '< '> '<= '>= 'exp 'expt 'sqrt 'symbol->string 'string->symbol 76 | 'string-append 'append 'cons 'car 'cdr 'list-ref 'length 'eq? 'apply 'list)) 77 | (cond 78 | [(set-member? foldable-set primitive) #t] 79 | [else #f])) 80 | 81 | ; Converts formals to use the new environment 82 | ; Environment Formals-Expr -> Formals-Expr 83 | (define (convert-formals env fmls) 84 | (with-output-language (Lpurifyletrec formals) 85 | (nanopass-case (Lpurifyletrec formals) fmls 86 | [,v ((env-lookup env) v)] 87 | [(,v ...) `(,(map (env-lookup env) v) ...)] 88 | [(,v ,v* ... . ,v2)`(,((env-lookup env) v) 89 | ,(map (env-lookup env) v*) ... 90 | . ,((env-lookup env) v2))]))) 91 | 92 | ;; Environments map source program variables to residual program 93 | ;; variables. Bindings not in the environment map directly 94 | ;; to themselves 95 | (define empty-env (hash)) 96 | (define ((env-lookup env) x) 97 | (define x* (dict-ref env x x)) 98 | ;(printf "env-lookup:~n env: ~a~n x: ~a~n x*: ~a~n (equal? x x*): ~a~n~n" env x x* (equal? x x*)) 99 | x*) 100 | 101 | (define (extend-env env x opnd) 102 | (define x* 103 | (make-variable (variable-name x) 104 | #:operand opnd 105 | ; TODO Should this be copied? 106 | ;#:assigned? (variable-assigned? x) 107 | ;#:referenced? (variable-referenced? x) 108 | )) 109 | (dict-set env x x*)) 110 | (define (extend-env* env x* opnd*) 111 | (for/fold ([env env]) 112 | ([x (in-list x*)] 113 | [opnd (in-list opnd*)]) 114 | (extend-env env x opnd))) 115 | 116 | ;; Active counters have a continuation and context 117 | (define (active-counter? counter) 118 | (and (counter? counter) (counter-context counter))) 119 | 120 | ;; Passive counters are counters with #f as a context, and error as a continuation 121 | (define fixed-passive-counter-default-value (current-passive-counter-default-value)) 122 | (define (make-passive-counter) 123 | (make-counter fixed-passive-counter-default-value 124 | #:context #f 125 | #:k (lambda x 126 | (error 'inline-expressions 127 | "Tried to call continuation on a passive counter")))) 128 | (define (passive-counter-value counter) 129 | (- fixed-passive-counter-default-value (counter-value counter))) 130 | 131 | ;; Determins if the amount of operands passed into a function 132 | ;; matches the amount accepted by the formals 133 | ;; Formals Opearnds -> Boolean 134 | (define (operands-match? formals operands) 135 | (define formals* (formals->identifiers Lpurifyletrec formals)) 136 | (define rest? (formals-rest? Lpurifyletrec formals)) 137 | (if rest? 138 | ((length formals*) . <= . (- (length operands) 1)) 139 | (= (length formals*) (length operands)))) 140 | 141 | ;; Determins if a syntactic form is simple and can thus be 142 | ;; ignored in a begin statement 143 | ;; Expr -> Boolean 144 | (define (simple? e) 145 | (nanopass-case (Lpurifyletrec expr) e 146 | [(quote ,datum) #t] 147 | [,v #t] 148 | [,lambda #t] 149 | [(primitive ,id) #t] 150 | [(#%plain-app (primitive ,id) (quote ,datum) ...) 151 | (guard (effect-free? id)) 152 | #t] 153 | [else #f])) 154 | 155 | ; Constructs begin expressions, flattening them if possible 156 | ; (Listof Expr) Expr -> Expr 157 | (define (make-begin e1 e2) 158 | (define e1* (filter (negate simple?) e1)) 159 | (cond [(null? e1*) e2] 160 | [else 161 | (with-output-language (Lpurifyletrec expr) 162 | (nanopass-case (Lpurifyletrec expr) e2 163 | [(begin ,expr3 ... ,expr4) 164 | `(begin ,(append e1* expr3) ,expr4)] 165 | [else `(begin ,e1* ... ,e2)]))])) 166 | 167 | ;; Constructs a let binding (to be used by inline) 168 | ;; Empty lets are removed, assigned but not referenced 169 | ;; variables are kept only for effect. 170 | ;; (Listof Var-Exprs) (Listof Operands) Expr -> Expr 171 | (define (make-let vars operands free-vars body size-counter) 172 | (define (set-effect! result) 173 | (for-each (curryr set-operand-residualized-for-effect?! #t) operands) 174 | result) 175 | (define var-map (map cons vars operands)) 176 | ;(printf "make-let:~n var-map: ~a~n body: ~a~n~n" var-map body) 177 | (with-output-language (Lpurifyletrec expr) 178 | (nanopass-case (Lpurifyletrec expr) body 179 | [(quote ,datum) (set-effect! body)] 180 | [(primitive ,id) (set-effect! body)] 181 | [,v 182 | (for ([(key val) (in-dict var-map)]) 183 | (unless (eq? val v) 184 | (set-operand-residualized-for-effect?! val #t))) 185 | (cond 186 | [(set-member? vars v) 187 | (score-value-visit-operand! (dict-ref var-map v) size-counter)] 188 | [else body])] 189 | [else 190 | (for ([var (in-list vars)]) 191 | (when (and (binding-assigned? (variable-binding var)) 192 | (not (binding-referenced? (variable-binding var)))) 193 | (set-operand-residualized-for-effect?! var #t))) 194 | (define visited-vars 195 | (for/list ([(i j) (in-dict var-map)] 196 | #:when (and (or (binding-referenced? (variable-binding i)) 197 | (binding-assigned? (variable-binding i))))) 198 | (if (binding-referenced? (variable-binding i)) 199 | (cons i (score-value-visit-operand! j size-counter)) 200 | (cons i `(primitive void))))) 201 | ;(printf "make-let2:~n visited-vars: ~a~n~n" visited-vars) 202 | (if (dict-empty? visited-vars) 203 | body 204 | `(let ([,(dict-keys visited-vars) ,(dict-values visited-vars)] ...) 205 | (begin-set! 206 | (assigned (,free-vars ...) 207 | ,body))))]))) 208 | 209 | ;; Returns the resulting expression of a sequence of operations. 210 | ;; (e.g. the last expression of a begin form) 211 | ;; Expr -> Expr 212 | (define (result-expr e) 213 | (nanopass-case (Lpurifyletrec expr) e 214 | [(begin ,expr* ... ,expr) expr] 215 | [(begin0 ,expr ,expr* ...) expr] 216 | [else e])) 217 | 218 | ;; Contextually aware equality checks for expressions. 219 | ;; (For example, all datusm are equal in an effect context) 220 | ;; Expr Expr Context -> Boolean 221 | (define (contextual-equal? e1 e2 context) 222 | (nanopass-case (Lpurifyletrec expr) e1 223 | [(quote ,datum1) 224 | (nanopass-case (Lpurifyletrec expr) e2 225 | [(quote ,datum2) 226 | [match context 227 | ['effect #t] 228 | ['test (if datum1 datum2 (not datum2))] 229 | [else (eq? datum1 datum2)]]] 230 | [else #f])] 231 | [else #f])) 232 | 233 | ;; Performs variable inlining 234 | ;; Variable Context Env Counter Counter -> Expr 235 | (define (inline-ref v context env effort-counter size-counter) 236 | (with-output-language (Lpurifyletrec expr) 237 | (match context 238 | ['effect `(primitive void)] 239 | [_ 240 | (define v* ((env-lookup env) v)) 241 | (define opnd (variable-operand v*)) 242 | ;(printf (string-append "inline-ref:~n v: ~a~n v*: ~a~n ctxt: ~a~n env: ~a~n " 243 | ; "opnd: ~a~n opnd-exp: ~a~n opnd-inner-pend: ~a~n~n") 244 | ; v v* context env opnd (and opnd (operand-exp opnd)) 245 | ; (and opnd (operand-inner-pending? opnd))) 246 | (cond 247 | [(and opnd (not (operand-inner-pending? opnd))) 248 | (dynamic-wind 249 | (lambda () (set-operand-inner-pending?! opnd #t)) 250 | (lambda () (value-visit-operand! opnd)) 251 | (lambda () (set-operand-inner-pending?! opnd #f))) 252 | (cond 253 | [(binding-assigned? (variable-binding v)) (residualize-ref v* size-counter)] 254 | [else 255 | (define rhs (result-expr (operand-value opnd))) 256 | ;(printf "inline-ref2:~n v*: ~a~n ctx: ~a~n rhs: ~a~n~n" v* context rhs) 257 | (nanopass-case (Lpurifyletrec expr) rhs 258 | [(quote ,datum) rhs] 259 | [,v** 260 | (cond 261 | [(binding-assigned? (variable-binding v**)) (residualize-ref v* size-counter)] 262 | [else 263 | (define v-opnd (variable-operand v)) 264 | (if (and v-opnd (operand-value v-opnd)) 265 | (copy v** v-opnd context effort-counter size-counter) 266 | (residualize-ref v** size-counter))])] 267 | [else (copy v* opnd context effort-counter size-counter)])])] 268 | [else (residualize-ref v* size-counter)])]))) 269 | 270 | ;; Helper for inline-ref, tries to inline references to variables 271 | ;; Variable Operand Context Counter Counter -> Variable 272 | (define (copy v opnd context effort-counter size-counter) 273 | (with-output-language (Lsrc expr) 274 | (define rhs (result-expr (operand-value opnd))) 275 | ;(printf "copy:~n v: ~a~n opnd: ~a~n ctx: ~a~n rhs: ~a~n opnd-outer-pending: ~a~n~n" 276 | ; v opnd context rhs (operand-outer-pending opnd)) 277 | (nanopass-case (Lpurifyletrec expr) rhs 278 | [(#%plain-lambda ,formals ,abody) 279 | (match context 280 | ['value (residualize-ref v size-counter)] 281 | ['test `'#t] 282 | [(struct* app ()) 283 | (or (and ((operand-outer-pending opnd) . > . 0) 284 | (dynamic-wind 285 | (lambda () (set-operand-outer-pending! 286 | opnd (- (operand-outer-pending opnd) 1))) 287 | (lambda () 288 | (let/cc abort 289 | (define limit (if (active-counter? size-counter) 290 | (counter-value size-counter) 291 | (current-inline-size-limit))) 292 | (inline rhs context empty-env 293 | (if (active-counter? effort-counter) 294 | effort-counter 295 | (make-counter (current-inline-effort-limit) 296 | #:context context 297 | #:k abort)) 298 | (make-counter limit #:context context #:k abort)))) 299 | (lambda () (set-operand-outer-pending! 300 | opnd (+ (operand-outer-pending opnd) 1))))) 301 | (residualize-ref v size-counter))])] 302 | [(primitive ,id) 303 | (match context 304 | ['value rhs] 305 | ['test `'#t] 306 | [(struct* app ()) (fold-prim id context size-counter)])] 307 | [else (residualize-ref v size-counter)]))) 308 | 309 | ;; If an application has been inlined, keep around 310 | ;; the expresssions for side effects (in a begin form) 311 | ;; otherwise just return the call 312 | ;; Expr (Listof Operands) Context Env Counter Counter -> Expr 313 | (define (inline-call e operands context env effort-counter size-counter) 314 | ;(printf "inline-call:~n e: ~a~n ctx: ~a~n opnds: ~a~n~n" e context operands) 315 | (define context* (app operands context)) 316 | (define e* (inline-expressions e context* env effort-counter size-counter)) 317 | ;(printf "inline-call2:~n e: ~a~n e*: ~a~n inlined: ~a~n~n" e e* (app-inlined? context*)) 318 | (if (app-inlined? context*) 319 | (residualize-operands operands e* size-counter) 320 | (with-output-language (Lpurifyletrec expr) 321 | `(#%plain-app ,e* 322 | ,(map (curryr score-value-visit-operand! size-counter) 323 | operands) ...)))) 324 | 325 | ;; Try to inline an expression to a value. Memoizes the result, 326 | ;; returns the resulting expression. 327 | ;; Operand -> Expr 328 | (define (value-visit-operand! opnd) 329 | ;(printf "value-visit-operand!:~n opnd: ~a~n operand-value: ~a~n~n" opnd (operand-value opnd)) 330 | (or (operand-value opnd) 331 | (let () 332 | (define size-counter (make-passive-counter)) 333 | (define e (inline-expressions (operand-exp opnd) 334 | 'value 335 | (operand-env opnd) 336 | (operand-effort-counter opnd) 337 | size-counter)) 338 | (set-operand-value! opnd e) 339 | (set-operand-size! opnd (passive-counter-value size-counter)) 340 | ;(printf "value-visit-operand2:~n opnd: ~a~n operand-value: ~a~n~n" opnd (operand-value opnd)) 341 | e))) 342 | 343 | ;; A varient of value-visit-operand! that also affects the value 344 | ;; of the size-counter given to it. 345 | ;; Opernad Counter -> Expr 346 | (define (score-value-visit-operand! opnd size-counter) 347 | (define val (value-visit-operand! opnd)) 348 | (decrement! size-counter (operand-size opnd)) 349 | val) 350 | 351 | ;; Sets a variable as being referenced 352 | ;; Ref -> Ref 353 | (define (residualize-ref v size-counter) 354 | (decrement! size-counter 1) 355 | (set-binding-referenced?! (variable-binding v) #t) 356 | v) 357 | 358 | ;; Inlines a call, keeping around operands only when needed 359 | ;; for effect 360 | ;; (Listof Operands) Expr Counter -> Expr 361 | (define (residualize-operands operands e size-counter) 362 | (define operands* (filter operand-residualized-for-effect? operands)) 363 | (cond [(null? operands*) e] 364 | [else 365 | (define operands** (for/list ([o (in-list operands*)]) 366 | (or (operand-value o) 367 | (inline-expressions (operand-exp o) 368 | 'effect 369 | (operand-env o) 370 | (operand-effort-counter o) 371 | size-counter)))) 372 | (define operands*** 373 | (for/list ([ov (in-list operands**)] 374 | [o (in-list operands)] 375 | #:unless (simple? ov)) 376 | (decrement! size-counter (operand-size o)) 377 | ov)) 378 | (if (null? operands***) e (make-begin operands*** e))])) 379 | 380 | ;; Performs the actual inlining 381 | ;; Lambda-Expr App-Context Env -> Exp 382 | (define (inline proc context env effort-counter size-counter) 383 | (with-output-language (Lpurifyletrec expr) 384 | ;(printf "inline:~n proc: ~a~n ctx: ~a~n env: ~a~n~n" proc context env) 385 | (nanopass-case (Lpurifyletrec lambda) proc 386 | [(#%plain-lambda ,formals 387 | (assigned (,v ...) ,expr)) 388 | (define formals* (formals->identifiers Lpurifyletrec formals)) 389 | (define rest? (formals-rest? Lpurifyletrec formals)) 390 | (define opnds (app-operands context)) 391 | (define opnds* 392 | (cond 393 | [rest? 394 | (define-values (single-opnds rest-opnds) 395 | (split-at opnds (- (length formals*) 1))) 396 | (append single-opnds 397 | ;; TODO, does this operand need to be 398 | ;; residulized for effect? 399 | ;; or recalculate effort counter? 400 | (list 401 | (make-operand 402 | `(#%plain-app (primitive list) 403 | ,(map operand-exp rest-opnds) ...) 404 | (apply hash-union (hash) 405 | (map operand-env rest-opnds)) 406 | (operand-effort-counter (first rest-opnds)))))] 407 | [else opnds])) 408 | (define env* (extend-env* env formals* opnds*)) 409 | ;(printf "inline2:~n expr: ~a~n fml*: ~a~n opnds*: ~a~n env*: ~a~n~n" 410 | ; expr formals* opnds* env*) 411 | (define body (inline-expressions expr 412 | (app-context context) 413 | env* 414 | effort-counter 415 | size-counter)) 416 | ;(printf "inline3:~n proc: ~a~n ctxt: ~a~n body: ~a~n~n" proc context body) 417 | (define result 418 | (if (operands-match? formals opnds) 419 | (make-let (map (env-lookup env*) formals*) 420 | opnds* 421 | (map (env-lookup env*) v) 422 | body 423 | size-counter) 424 | `(#%plain-app (#%plain-lambda (,formals* ...) 425 | (assigned (,v ...) 426 | ,body)) 427 | ,(map (curryr score-value-visit-operand! size-counter) 428 | opnds*) ...))) 429 | ;(printf "inline4:~n proc: ~a~n ctxt: ~a~n result: ~a~n~n" proc context result) 430 | (set-app-inlined?! context #t) 431 | result]))) 432 | 433 | ;; Does constant fold on primitives (if possible) 434 | ;; ID Context Counter -> Expr 435 | (define (fold-prim prim context size-counter) 436 | (define operands (app-operands context)) 437 | ;(printf "fold-prim:~n prim: ~a~n ctx: ~a~n operands: ~a~n operand-vals: ~a~n~n" 438 | ; prim context operands (map operand-value operands)) 439 | (with-output-language (Lpurifyletrec expr) 440 | (define result 441 | (or (and (effect-free? prim) 442 | (match (app-context context) 443 | ['effect `(primitive void)] 444 | ['test (and (return-true? prim) `(quote #t))] 445 | [else #f])) 446 | (and (foldable? prim) 447 | (let ([vals (map value-visit-operand! operands)]) 448 | ;(printf "fold-prim2:~n prim: ~a~n vals: ~a~n~n" prim vals) 449 | (define-values (consts? operands*) 450 | (for/fold ([const-vals #t] 451 | [ops null]) 452 | ([v (in-list vals)]) 453 | (values 454 | (and const-vals 455 | (nanopass-case (Lpurifyletrec expr) v 456 | [(quote ,datum) #t] 457 | [else #f])) 458 | (cons 459 | (nanopass-case (Lpurifyletrec expr) v 460 | [(quote ,datum) datum] 461 | [else #f]) 462 | ops)))) 463 | (define operands** (reverse operands*)) 464 | (and consts? 465 | (with-handlers ([exn? (lambda (x) #f)]) 466 | `(quote ,(parameterize ([current-namespace (make-base-namespace)]) 467 | (eval (cons prim (for/list ([o (in-list operands**)]) 468 | (list 'quote o)))))))))))) 469 | ;(printf "fold-prim3: ~n result: ~a~n~n" result) 470 | (cond 471 | [result (for-each (curryr set-operand-residualized-for-effect?! #t) operands) 472 | (set-app-inlined?! context #t) 473 | result] 474 | [else (decrement! size-counter 1) 475 | `(primitive ,prim)]))) 476 | 477 | ;; Resets the inlined process inside of `app` contexts 478 | ;; Recurse all the way to the outer most context. 479 | ;; App-Context -> Void 480 | (define (reset-integrated! context) 481 | (set-app-inlined?! context #f) 482 | (define context* (app-context context)) 483 | (when (app? context*) 484 | (reset-integrated! context))) 485 | 486 | ;; Decrements the given counter by amount steps 487 | ;; If the result goes below 0, then undo the attempt at inlining 488 | ;; and call the counters continuation. 489 | ;; Counter Number -> Void 490 | (define (decrement! counter amount) 491 | (define n (- (counter-value counter) amount)) 492 | (set-counter-value! counter n) 493 | (when (< n 0) 494 | ;(displayln "DING!") 495 | (when (app? (counter-context counter)) 496 | (reset-integrated! (counter-context counter))) 497 | ((counter-k counter) #f))) 498 | 499 | (define-pass inline-expressions 500 | : Lpurifyletrec (e context env effort-counter size-counter) -> Lpurifyletrec () 501 | 502 | (Expr : expr (e [context context] 503 | [env env] 504 | [effort-counter effort-counter] 505 | [size-counter size-counter]) 506 | -> expr () 507 | [(quote ,datum) `(quote ,datum)] 508 | [,v (inline-ref v context env effort-counter size-counter)] 509 | [(begin ,[expr1 'effect env effort-counter size-counter -> expr1] ... 510 | ,[expr2 context env -> expr2]) 511 | (make-begin expr1 expr2)] 512 | [(if ,[expr1 'test env effort-counter size-counter -> expr1] ,expr2 ,expr3) 513 | (nanopass-case (Lpurifyletrec expr) (result-expr expr1) 514 | [(quote ,datum) 515 | (make-begin (list expr1) 516 | (inline-expressions (if datum expr2 expr3) 517 | context 518 | env 519 | effort-counter 520 | size-counter))] 521 | [else 522 | (define context* (if (app? context) 'value context)) 523 | (define expr2* 524 | (inline-expressions expr2 context* env effort-counter size-counter)) 525 | (define expr3* 526 | (inline-expressions expr3 context* env effort-counter size-counter)) 527 | (cond [(contextual-equal? expr2* expr3* context*) 528 | (make-begin (list expr1) expr2*)] 529 | [else 530 | (decrement! size-counter 1) 531 | `(if ,expr1 ,expr2* ,expr3*)])])] 532 | [(set!-values (,v ...) ,expr) 533 | (define v* (map (env-lookup env) v)) 534 | (cond 535 | [(ormap binding-referenced? (map variable-binding v)) 536 | (define expr* (inline-expressions expr 'value env effort-counter size-counter)) 537 | (map (curryr set-binding-assigned?! #t) (map variable-binding v*)) 538 | `(set!-values (,v* ...) ,expr*)] 539 | [else 540 | (make-begin 541 | (list 542 | (inline-expressions expr 'effect env effort-counter size-counter)) 543 | `(#%plain-app (primitive void)))])] 544 | [(#%plain-app ,expr ,expr* ...) 545 | (inline-call expr 546 | (map (curryr make-operand env effort-counter) expr*) 547 | context 548 | env 549 | effort-counter 550 | size-counter)] 551 | [(primitive ,id) 552 | (match context 553 | ['effect `'#t] 554 | ['test `'#t] 555 | ['value (decrement! size-counter 1) e] 556 | [(struct* app ()) (fold-prim id context size-counter)])] 557 | [(let ([,v* ,expr*] ...) 558 | (begin-set! 559 | (assigned (,v ...) 560 | ,expr))) 561 | (inline-expressions 562 | `(#%plain-app (#%plain-lambda (,v* ...) 563 | (assigned (,v ...) 564 | ,expr)) 565 | ,expr* ...) 566 | context env effort-counter size-counter)] 567 | [(let ([,v* ,expr*] ...) 568 | (begin-set! 569 | ,set-expr ... 570 | (assigned (,v ...) 571 | ,expr))) 572 | (define env* (extend-env* env v* (make-list (length v*) #f))) 573 | (define ie* (curryr inline-expressions context env* effort-counter size-counter)) 574 | `(let ([,(map (env-lookup env*) v*) ,(map ie* expr*)] ...) 575 | (begin-set! 576 | ,(map ie* set-expr) ... 577 | (assigned (,(map (env-lookup env*) v) ...) 578 | ,(ie* expr))))] 579 | [(letrec ([,v ,lambda] ...) 580 | ,expr) 581 | (define env* (extend-env* env v (make-list (length v) #f))) 582 | (define v* (map (env-lookup env*) v)) 583 | (define operands (map (curryr make-operand env* effort-counter) lambda)) 584 | (for ([i (in-list v*)] 585 | [j (in-list operands)]) 586 | (set-variable-operand! i j)) 587 | ;(printf "inline-expressions-letrec:~n env*: ~a~n v*: ~a~n operands: ~a~n~n" 588 | ; env* v* operands) 589 | (define expr* (inline-expressions expr context env* effort-counter size-counter)) 590 | (define filtered-vars 591 | (for/list ([i (in-list v*)] 592 | [j (in-list operands)] 593 | #:when (binding-referenced? (variable-binding i))) 594 | (cons i j))) 595 | ;(printf "inline-expressions-letrec-2:~n expr: ~a~n expr*: ~a~n filtered-vars: ~a~n~n" 596 | ; expr expr* filtered-vars) 597 | (cond [(or (null? filtered-vars) 598 | (nanopass-case (Lpurifyletrec expr) expr* 599 | [(quote ,datum) #t] 600 | [(primitive ,id) #t] 601 | [else #f])) 602 | expr*] 603 | [else 604 | (decrement! size-counter 1) 605 | `(letrec ([,(dict-keys filtered-vars) 606 | ,(map operand-value (dict-values filtered-vars))] ...) 607 | ,expr*)])] 608 | [(case-lambda ,lambda ...) 609 | (match context 610 | ['effect `'#t] 611 | ['teset `'#t] 612 | ['value 613 | (decrement! size-counter 1) 614 | `(case-lambda ,(map (curryr Lambda context env effort-counter size-counter) lambda) ...)] 615 | [(struct* app ()) 616 | (define res 617 | (for/fold ([acc #f]) 618 | ([l (in-list lambda)]) 619 | (or acc 620 | (nanopass-case (Lpurifyletrec lambda) l 621 | [(#%plain-lambda ,formals ,abody) 622 | (define opnds (app-operands context)) 623 | (and (operands-match? formals opnds) 624 | (Lambda l context env effort-counter size-counter))])))) 625 | (or res `(case-lambda ,lambda ...))])]) 626 | 627 | (Lambda : lambda (e [context context] 628 | [env env] 629 | [effort-counter effort-counter] 630 | [size-counter size-counter]) 631 | -> lambda () 632 | [(#%plain-lambda ,formals (assigned (,v ...) ,expr)) 633 | (match context 634 | ['effect `'#t] 635 | ['test `'#t] 636 | ['value 637 | (decrement! size-counter 1) 638 | (define formals* (formals->identifiers Lpurifyletrec formals)) 639 | (define env* (extend-env* env formals* (make-list (length formals*) #f))) 640 | `(#%plain-lambda ,(convert-formals env* formals) 641 | (assigned 642 | (,(map (env-lookup env*) v) ...) 643 | ,(inline-expressions expr 'value env* effort-counter size-counter)))] 644 | [(struct* app ()) (inline e context env effort-counter size-counter)])]) 645 | 646 | (LinkletForm : linklet-form (e [context context] 647 | [env env] 648 | [effort-counter effort-counter] 649 | [size-counter size-counter]) 650 | -> linklet-form ()) 651 | 652 | (begin 653 | ;(printf "inline-expressions:~n exp: ~a~n env: ~a~n ctx: ~a~n~n" e env context) 654 | (decrement! effort-counter 1) 655 | (LinkletForm e context env effort-counter size-counter))) 656 | 657 | (define (~inline-expressions e 658 | [context 'value] 659 | [env (hash)] 660 | [effort-counter (make-counter (current-inline-effort-limit) 661 | #:k (lambda (x) 662 | (raise e)))] 663 | [size-counter (make-counter (current-inline-size-limit) 664 | #:k (lambda (x) 665 | (raise e)))]) 666 | (with-handlers ([Lpurifyletrec? (lambda (x) x)]) 667 | (inline-expressions e context env effort-counter size-counter))) 668 | -------------------------------------------------------------------------------- /private/parser.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide parse-and-rename) 4 | 5 | (require nanopass/base 6 | syntax/parse 7 | syntax/id-table 8 | racket/match 9 | racket/dict 10 | racket/function 11 | "languages.rkt" 12 | "utils.rkt") 13 | 14 | (define current-global-env (make-parameter (make-free-id-table))) 15 | 16 | ; Initial environment for local variables 17 | (define initial-env (make-immutable-free-id-table)) 18 | (define (extend-env env vars) 19 | (for/fold ([acc env]) 20 | ([var (in-list vars)]) 21 | (dict-set acc var (make-variable (syntax->datum var) 22 | #:source-location (syntax-source var))))) 23 | 24 | (define ((lookup-env env) var #:binding [binding (make-binding)]) 25 | (define old-var 26 | (dict-ref env var 27 | (lambda () 28 | (dict-ref (current-global-env) var #f)))) 29 | (cond [old-var 30 | (struct-copy variable old-var 31 | [name (syntax->datum var)] 32 | [srcloc (syntax-source var)])] 33 | [else 34 | (define x (make-variable (syntax->datum var) 35 | #:source-location (syntax-source var) 36 | #:binding binding)) 37 | (dict-set! (current-global-env) var x) 38 | x])) 39 | 40 | ;; Parse and alpha-rename expanded program 41 | (define-pass parse-and-rename : * (form) -> Lsrc () 42 | (parse-top : * (form env) -> top-level-form () 43 | (syntax-parse form 44 | #:literals (#%expression module #%plain-module-begin begin begin-for-syntax) 45 | [(#%expression body) 46 | `(#%expression ,(parse-expr #'body env))] 47 | [(module id:id path 48 | (#%plain-module-begin body ...)) 49 | (parameterize ([current-global-env (make-free-id-table)]) 50 | `(module ,(syntax->datum #'id) ,(syntax->datum #'path) 51 | (,(for/list ([i (in-list (syntax->list #'(body ...)))]) 52 | (parse-mod i env)) ...)))] 53 | [(begin body ...) 54 | `(begin* ,(for/list ([i (in-list (syntax->list #'(body ...)))]) 55 | (parse-top i env)) ...)] 56 | [(begin-for-syntax body ...) 57 | `(begin-for-syntax* ,(for/list ([i (in-list (syntax->list #'(body ...)))]) 58 | (parse-top (syntax-shift-phase-level i -1) env)) ...)] 59 | [else 60 | (parse-gen #'else env)])) 61 | 62 | (parse-mod : * (form env) -> module-level-form () 63 | (syntax-parse form 64 | #:literals (#%provide begin-for-syntax #%declare module module* 65 | #%plain-module-begin) 66 | [(#%provide spec ...) 67 | `(#%provide ,(for/list ([s (in-list (syntax->list #'(spec ...)))]) 68 | (parse-raw-provide-spec s env)) ...)] 69 | [(begin-for-syntax body ...) 70 | `(begin-for-syntax ,(for/list ([i (in-list (syntax->list #'(body ...)))]) 71 | (parse-mod (syntax-shift-phase-level i -1) env)) ...)] 72 | [(#%declare keyword ...) 73 | `(#%declare ,(syntax->list #'(keyword ...)) ...)] 74 | [(module id:id path 75 | (#%plain-module-begin body ...)) 76 | (parameterize ([current-global-env (make-free-id-table)]) 77 | `(submodule ,(syntax->datum #'id) ,(syntax->datum #'path) 78 | (,(for/list ([i (in-list (syntax->list #'(body ...)))]) 79 | (parse-mod i env)) ...)))] 80 | [(module* id:id path 81 | (#%plain-module-begin body ...)) 82 | (parameterize ([current-global-env (make-free-id-table)]) 83 | `(submodule* ,(syntax->datum #'id) ,(syntax->datum #'path) 84 | (,(for/list ([i (in-list (syntax->list #'(body ...)))]) 85 | (parse-mod i env)) ...)))] 86 | [else 87 | (parse-gen #'else env)])) 88 | 89 | (parse-gen : * (form env) -> general-top-level-form () 90 | (syntax-parse form 91 | #:literals (define-values define-syntaxes #%require) 92 | [(define-values (id:id ...) body) 93 | ;(define env* (extend-env env (syntax->list #'(id ...)))) 94 | `(define-values (,(for/list ([i (in-list (syntax->list #'(id ...)))]) 95 | (parse-expr i env)) ...) 96 | ,(parse-expr #'body env))] 97 | [(define-syntaxes (id:id ...) body) 98 | ;(define env* (extend-env env (syntax->list #'(id ...)))) 99 | `(define-syntaxes (,(for/list ([i (in-list (syntax->list #'(id ...)))]) 100 | (parse-expr i env)) ...) 101 | ,(parse-expr (syntax-shift-phase-level #'body -1) env))] 102 | [(#%require spec ...) 103 | `(#%require ,(for/list ([s (in-list (syntax->list #'(spec ...)))]) 104 | (parse-raw-require-spec s env)) ...)] 105 | [else 106 | (parse-expr #'else env)])) 107 | 108 | (parse-expr : * (form env) -> expr () 109 | (syntax-parse form 110 | #:literals (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! 111 | quote quote-syntax with-continuation-mark #%plain-app 112 | #%top #%variable-reference) 113 | [id:id (cond [(primitive-identifier? #'id) 114 | `(primitive ,(primitive->symbol #'id))] 115 | [else 116 | (match (identifier-binding #'id) 117 | ;; HORRIBLE cludge, because identifier-bindings 118 | ;; returns #f for top level bound variables. 119 | [#f ((lookup-env (make-free-id-table)) #'id)] 120 | ['lexical ((lookup-env env) #'id)] 121 | [`(,mp ,s ,mp* ,s* ,eni ,ei ,ei*) 122 | ((lookup-env env) 123 | #'id #:binding (make-module-binding mp s mp* s* eni ei ei*))])])] 124 | 125 | [(#%plain-lambda formals body* ... body) 126 | (define-values (formals* env*) (parse-formals #'formals env)) 127 | `(#%plain-lambda ,formals* 128 | ,(for/list ([b (in-list (syntax->list #'(body* ...)))]) 129 | (parse-expr b env*)) ... 130 | ,(parse-expr #'body env*))] 131 | [(case-lambda (formals body* ... body) ...) 132 | (match (for/list ([formal (in-list (syntax->list #'(formals ...)))] 133 | [b1 (in-list (syntax->list #'(body ...)))] 134 | [b (in-list (syntax->list #'((body* ...) ...)))]) 135 | (define-values (formals* env*) (parse-formals formal env)) 136 | (list formals* 137 | (for/list ([b* (in-list (syntax->list b))]) 138 | (parse-expr b* env*)) 139 | (parse-expr b1 env*))) 140 | [`((,formal ,body* ,body) ...) 141 | `(case-lambda (,formal ,body* ... ,body) ...)])] 142 | [(if test tbranch fbranch) 143 | `(if ,(parse-expr #'test env) 144 | ,(parse-expr #'tbranch env) 145 | ,(parse-expr #'fbranch env))] 146 | [(begin body* ... body) 147 | `(begin ,(for/list ([b (in-list (syntax->list #'(body* ...)))]) 148 | (parse-expr b env)) ... 149 | ,(parse-expr #'body env))] 150 | [(begin0 body body* ...) 151 | `(begin0 ,(parse-expr #'body env) 152 | ,(for/list ([b (in-list (syntax->list #'(body* ...)))]) 153 | (parse-expr b env)) ...)] 154 | [(let-values ([(ids:id ...) val] ...) 155 | body* ... body) 156 | (define env* (extend-env env 157 | (apply 158 | append 159 | (map syntax->list (syntax->list #'((ids ...) ...)))))) 160 | (match (for/list ([i (in-list (syntax->list #'((ids ...) ...)))] 161 | [v (in-list (syntax->list #'(val ...)))]) 162 | (list (map (lookup-env env*) (syntax->list i)) 163 | (parse-expr v env))) 164 | [`([(,args ...) ,exp] ...) 165 | `(let-values ([(,args ...) ,exp] ...) 166 | ,(for/list ([b (in-list (syntax->list #'(body* ...)))]) 167 | (parse-expr b env*)) ... 168 | ,(parse-expr #'body env*))])] 169 | [(letrec-values ([(ids:id ...) val] ...) 170 | body* ... body) 171 | (define env* (extend-env env 172 | (apply 173 | append 174 | (map syntax->list (syntax->list #'((ids ...) ...)))))) 175 | (match (for/list ([i (in-list (syntax->list #'((ids ...) ...)))] 176 | [v (in-list (syntax->list #'(val ...)))]) 177 | (list (map (lookup-env env*) (syntax->list i)) 178 | (parse-expr v env*))) 179 | [`([(,args ...) ,exp] ...) 180 | `(letrec-values ([(,args ...) ,exp] ...) 181 | ,(for/list ([b (in-list (syntax->list #'(body* ...)))]) 182 | (parse-expr b env*)) ... 183 | ,(parse-expr #'body env*))])] 184 | [(set! id:id body) 185 | `(set! ,(parse-expr #'id env) ,(parse-expr #'body env))] 186 | [(quote datum) 187 | `(quote ,(syntax->datum #'datum))] 188 | [(quote-syntax datum) 189 | `(quote-syntax ,#'datum)] 190 | [(quote-syntax datum #:local) 191 | `(quote-syntax-local ,#'datum)] 192 | [(with-continuation-mark key val result) 193 | `(with-continuation-mark ,(parse-expr #'key env) ,(parse-expr #'val env) 194 | ,(parse-expr #'result env))] 195 | [(#%plain-app func body ...) 196 | `(#%plain-app ,(parse-expr #'func env) 197 | ,(for/list ([i (in-list (syntax->list #'(body ...)))]) 198 | (parse-expr i env)) ...)] 199 | [(#%top . id:id) 200 | `(#%top . ,(parse-expr #'id (make-immutable-free-id-table)))] 201 | [(#%variable-reference id:id) 202 | `(#%variable-reference ,(parse-expr #'id env))] 203 | [(#%variable-reference (#%top . id:id)) 204 | `(#%variable-reference-top ,((lookup-env env) #'id))] 205 | [(#%variable-reference) 206 | `(#%variable-reference)])) 207 | 208 | (parse-formals : * (formals env) -> formals (env) 209 | (syntax-parse formals 210 | [(ids:id ...) 211 | (define env* (extend-env env (syntax->list #'(ids ...)))) 212 | (values 213 | `(,(for/list ([i (in-list (syntax->list #'(ids ...)))]) 214 | (parse-expr i env*)) ...) 215 | env*)] 216 | [(id:id ids:id ... . rest:id) 217 | (define env* (extend-env env (list* #'id #'rest (syntax->list #'(ids ...))))) 218 | (values 219 | `(,(parse-expr #'id env*) 220 | ,(for/list ([i (in-list (syntax->list #'(ids ...)))]) 221 | (parse-expr i env*)) ... 222 | . ,(parse-expr #'rest env*)) 223 | env*)] 224 | [rest:id 225 | (define env* (extend-env env (list #'rest))) 226 | (values (parse-expr #'rest env*) env*)])) 227 | 228 | (parse-raw-require-spec : * (form env) -> raw-require-spec () 229 | (syntax-parse form 230 | #:datum-literals (for-meta for-syntax for-template for-label just-meta) 231 | [(for-meta phase-level phaseless-req-spec ...) 232 | `(for-meta 233 | ,(syntax-e #'phase-level) 234 | ,(for/list ([i (in-list (syntax->list #'(phaseless-req-spec ...)))]) 235 | (parse-phaseless-req-spec i env)) ...)] 236 | [(for-syntax phaseless-req-spec ...) 237 | `(for-meta 238 | ,1 239 | ,(for/list ([i (in-list (syntax->list #'(phaseless-req-spec ...)))]) 240 | (parse-phaseless-req-spec i env)) ...)] 241 | [(for-template phaseless-req-spec ...) 242 | `(for-meta 243 | ,-1 244 | ,(for/list ([i (in-list (syntax->list #'(phaseless-req-spec ...)))]) 245 | (parse-phaseless-req-spec i env)) ...)] 246 | [(for-label phaseless-req-spec ...) 247 | `(for-meta 248 | ,#f 249 | ,(for/list ([i (in-list (syntax->list #'(phaseless-req-spec ...)))]) 250 | (parse-phaseless-req-spec i env)) ...)] 251 | [(just-meta phase-level raw-req-spec ...) 252 | `(just-meta 253 | ,(syntax-e #'phase-level) 254 | ,(for/list ([i (in-list (syntax->list #'(raw-req-spec ...)))]) 255 | (parse-raw-require-spec i env)) ...)] 256 | [else (parse-phaseless-req-spec #'else env)])) 257 | 258 | (parse-phaseless-req-spec : * (form env) -> phaseless-req-spec () 259 | (syntax-parse form 260 | #:datum-literals (only prefix all-except prefix-all-except rename) 261 | [(only raw-module-path ids:id ...) 262 | `(only ,(parse-raw-module-path #'raw-module-path env) 263 | ,(map (curryr parse-expr env) (syntax->list #'(ids ...))) ...)] 264 | [(prefix id:id raw-module-path) 265 | `(prefix-all-except ,(syntax-e #'id) 266 | ,(parse-raw-module-path #'raw-module-path env))] 267 | [(all-except raw-module-path ids:id ...) 268 | `(all-except ,(parse-raw-module-path #'raw-module-path env) 269 | ,(map (curryr parse-expr env) 270 | (syntax->list #'(ids ...))) ...)] 271 | [(prefix-all-except id:id raw-module-path ids:id ...) 272 | `(prefix-all-except 273 | ,(syntax-e #'id) 274 | ,(parse-raw-module-path #'raw-module-path env) 275 | ,(map (curryr parse-expr env) (syntax->list #'(ids ...))) ...)] 276 | [(rename raw-module-path id1:id id2:id) 277 | `(rename ,(parse-raw-module-path #'raw-module-path env) 278 | ,(parse-expr #'id1 env) 279 | ,(parse-expr #'id2 env))] 280 | [else (parse-raw-module-path #'else env)])) 281 | 282 | (parse-raw-provide-spec : * (form env) -> raw-provide-spec () 283 | (syntax-parse form 284 | #:literals (for-meta for-syntax for-label) 285 | #:datum-literals (protect) 286 | [(for-meta phase-level phaseless-prov-spec) 287 | `(for-meta* ,(syntax-e #'phase-level) 288 | ,(parse-phaseless-prov-spec #'phaseless-prov-spec env))] 289 | [(for-syntax phaseless-prov-spec) 290 | `(for-meta* ,1 ,(parse-phaseless-prov-spec #'phaseless-prov-spec env))] 291 | [(for-label phaseless-prov-spec) 292 | `(for-meta* ,#f ,(parse-phaseless-prov-spec #'phaseless-prov-spec env))] 293 | [(protect raw-provide-spec) 294 | `(protect ,(parse-raw-provide-spec #'raw-provide-spec env))] 295 | [else (parse-phaseless-prov-spec #'else env)])) 296 | 297 | (parse-raw-module-path : * (form env) -> raw-module-path () 298 | (syntax-parse form 299 | #:literals (submod) 300 | [(submod path ids:id ...+) 301 | `(submod ,(parse-raw-root-module-path #'path env) 302 | ,(for/list ([i (in-list (syntax->list #'(ids ...)))]) 303 | (syntax-e i)) ...)] 304 | [else (parse-raw-root-module-path #'else env)])) 305 | 306 | (parse-raw-root-module-path : * (form env) -> raw-root-module-path () 307 | (syntax-parse form 308 | #:literals (quote lib file planet) 309 | [i:id (syntax-e #'i)] 310 | [s:str (syntax-e #'s)] 311 | [(quote id:id) `(quote* ,(syntax-e #'id))] 312 | [(lib s ...) 313 | `(lib ,(for/list ([i (in-list (syntax->list #'(s ...)))]) 314 | (syntax-e i)) ...)] 315 | [(file s) `(file ,(syntax-e #'s))] 316 | [(planet s1 317 | (s2 s3 s4 ...)) 318 | `(planet ,(syntax-e #'s1) 319 | (,(syntax-e #'s2) 320 | ,(syntax-e #'s3) 321 | ,(for/list ([i (in-list (syntax->list #'(s4 ...)))]) 322 | (syntax-e i)) ...))] 323 | [else 324 | #:when (path? (syntax-e #'else)) 325 | (syntax-e #'else)])) 326 | 327 | (parse-phaseless-prov-spec : * (form env) -> phaseless-prov-spec () 328 | (syntax-parse form 329 | #:datum-literals (rename struct all-from all-from-except all-define 330 | all-defined-except prefix-all-defined 331 | prefix-all-defined-except expand protect) 332 | [id:id (parse-expr #'id env)] 333 | [(rename id1:id id2:id) 334 | `(rename* ,(parse-expr #'id1 env) ,(parse-expr #'id2 env))] 335 | [(struct name:id (fields:id ...)) 336 | `(struct ,(parse-expr #'name env) 337 | (,(map (curryr parse-expr env) 338 | (syntax->list #'(fields ...))) ...))] 339 | [(all-from raw-module-path) 340 | `(all-from-except ,(parse-raw-module-path #'raw-module-path env))] 341 | [(all-from-except raw-module-path ids:id ...) 342 | `(all-from-except 343 | ,(parse-raw-module-path #'raw-module-path env) 344 | ,(map (curryr parse-expr env) (syntax->list #'(ids ...))) ...)] 345 | [(all-defined) `(all-defined-except)] 346 | [(all-defined-except ids:id ...) 347 | `(all-defined-except 348 | ,(map (curryr parse-expr env) (syntax->list #'(ids ...))) ...)] 349 | [(prefix-all-defined prefix:id) 350 | `(prefix-all-defined-except ,(syntax-e #'prefix))] 351 | [(prefix-all-defined-except prefix:id ids:id ...) 352 | `(prefix-all-defined-except 353 | ,(syntax-e #'prefix) 354 | ,(map (curryr parse-expr env) (syntax->list #'(ids ...))) ...)] 355 | [(protect spec ...) 356 | `(protect* 357 | ,(map (curryr parse-phaseless-prov-spec env) 358 | (syntax->list #'(spec ...))) ...)])) 359 | 360 | (parse-top form initial-env)) -------------------------------------------------------------------------------- /private/passes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require nanopass/base 6 | syntax/parse 7 | racket/match 8 | racket/set 9 | racket/dict 10 | racket/hash 11 | racket/port 12 | racket/list 13 | racket/function 14 | racket/bool 15 | racket/stxparam 16 | racket/stxparam-exptime 17 | racket/block 18 | racket/splicing 19 | compiler/zo-marshal 20 | syntax/toplevel 21 | syntax/strip-context 22 | rackunit 23 | (prefix-in zo: compiler/zo-structs) 24 | (rename-in racket/base 25 | [compile base:compile] 26 | [current-compile base:current-compile]) 27 | (for-syntax racket/base 28 | syntax/parse 29 | racket/syntax 30 | racket/stxparam 31 | racket/stxparam-exptime) 32 | "languages.rkt" 33 | "utils.rkt") 34 | 35 | ;; Identify all assigned variables in a function. (variables that are set!-ed) 36 | ;; This has two major effects. 37 | ;; First, the surce for functions is changed: 38 | ;; (#%plain-lambda (id ...) body) => 39 | ;; (#%plpain-lambda (id ...) (abody (id ...) body) 40 | ;; Where the id list in the abody is the assigned variables 41 | ;; Second, the mutated field in every variable is updated to denote 42 | ;; that it is assigned. 43 | (define-pass identify-assigned-variables : Lsrc (e) -> Lidentifyassigned () 44 | (definitions 45 | (define-syntax-rule (formals->identifiers* fmls) 46 | (formals->identifiers Lidentifyassigned fmls))) 47 | (Lambda : lambda (e) -> lambda ('()) 48 | [(#%plain-lambda ,[formals] ,[expr assigned*]) 49 | (values `(#%plain-lambda ,formals 50 | (assigned (,(set-intersect assigned* 51 | (formals->identifiers* formals)) 52 | ...) 53 | ,expr)) 54 | (set-remove assigned* (formals->identifiers* formals)))]) 55 | (Expr : expr (e) -> expr ('()) 56 | [(set! ,v ,[expr assigned*]) 57 | (set-binding-assigned?! (variable-binding v) #t) 58 | (values `(set! ,v ,expr) 59 | (set-add assigned* v))] 60 | [(let-values ([(,v ...) ,[expr assigned]] ...) 61 | ,[expr* assigned*]) 62 | (values `(let-values ([(,v ...) ,expr] ...) 63 | (assigned (,(set-intersect assigned* (apply set-union '() v)) ...) ,expr*)) 64 | (apply set-union '() (set-remove assigned* v) assigned))] 65 | [(letrec-values ([(,v ...) ,[expr assigned]] ...) 66 | ,[expr* assigned*]) 67 | (values `(letrec-values ([(,v ...) ,expr] ...) 68 | (assigned (,(set-intersect assigned* (apply set-union '() v)) ...) ,expr*)) 69 | (apply set-union '() (set-remove assigned* v) assigned))] 70 | ;; Really *should* be generated 71 | [(if ,[expr1 assigned1] ,[expr2 assigned2] ,[expr3 assigned3]) 72 | (values `(if ,expr1 ,expr2 ,expr3) 73 | (set-union assigned1 assigned2 assigned3))] 74 | [(with-continuation-mark ,[expr1 assigned1] ,[expr2 assigned2] ,[expr3 assigned3]) 75 | (values `(with-continuation-mark ,expr1 ,expr2 ,expr3) 76 | (set-union assigned1 assigned2 assigned3))] 77 | [(begin ,[expr* assigned*] ... ,[expr assigned]) 78 | (values `(begin ,expr* ... ,expr) 79 | (apply set-union assigned assigned*))] 80 | [(begin0 ,[expr assigned] ,[expr* assigned*] ...) 81 | (values `(begin0 ,expr ,expr* ...) 82 | (apply set-union assigned assigned*))] 83 | [(#%plain-app ,[expr assigned] ,[expr* assigned*] ...) 84 | (values `(#%plain-app ,expr ,expr* ...) 85 | (apply set-union assigned assigned*))] 86 | [(case-lambda ,[lambda assigned] ...) 87 | (values `(case-lambda ,lambda ...) 88 | (apply set-union '() assigned))]) 89 | (GeneralTopLevelForm : general-top-level-form (e) -> general-top-level-form ('()) 90 | [(define-values (,v ...) ,[expr assigned]) 91 | (values `(define-values (,v ...) ,expr) 92 | (set-subtract assigned v))]) 93 | (LinkletForm : linklet-form (e) -> linklet-form ('())) 94 | (let-values ([(e* free*) (LinkletForm e)]) 95 | e*)) 96 | 97 | ;; Purify letrecs so that they only contain lambda expressions that are not 98 | ;; ever assigned. 99 | (define-pass purify-letrec : Lidentifyassigned (e) -> Lpurifyletrec () 100 | (Expr : expr (e) -> expr () 101 | [(set! ,v ,[expr]) 102 | `(set!-values (,v) ,expr)] 103 | [(letrec-values ([(,v) ,[lambda]] ...) 104 | (assigned (,v* ...) ,[expr])) 105 | (guard (set-empty? (set-intersect v* v))) 106 | `(letrec ([,v ,lambda] ...) 107 | ,expr)] 108 | [(letrec-values ([(,v ...) ,[expr]] ...) 109 | (assigned (,v* ...) ,[expr*])) 110 | (define flattened-ids (apply append v)) 111 | `(let ([,flattened-ids ,(make-list (length flattened-ids) `(undefined))] ...) 112 | (begin-set! 113 | (set!-values (,v ...) ,expr) ... 114 | (assigned (,(apply set-union v* v) ...) 115 | ,expr*)))] 116 | [(let-values ([(,v) ,[expr]] ...) 117 | ,[abody]) 118 | `(let ([,v ,expr] ...) 119 | (begin-set! 120 | ,abody))] 121 | [(let-values ([(,v ...) ,[expr]] ...) 122 | (assigned (,v* ...) ,[expr*])) 123 | (define flattened-ids (apply append v)) 124 | `(let ([,flattened-ids ,(make-list (length flattened-ids) `(undefined))] ...) 125 | (begin-set! 126 | (set!-values (,v ...) ,expr) ... 127 | (assigned (,v* ...) 128 | ,expr*)))])) 129 | 130 | 131 | ;; Converts assigned variables using the assigned variable pass from earlier. 132 | ;; Assignments are now explicitely boxed: 133 | ;; (set!-values (x) 5) -> (set!-boxes (x) 5) 134 | ;; When an assigned variable is referenced, it is converted: 135 | ;; x -> (#%unbox x) 136 | ;; Finaally, the form that assigned the variable is converted to 137 | ;; x -> (let ([x (#%box x)]) ...) 138 | (define-pass convert-assignments : Lpurifyletrec (e) -> Lconvertassignments () 139 | (definitions 140 | (define ((lookup-env env) x) 141 | (dict-ref env x x)) 142 | (define (extend-env env assigned*) 143 | ;(define temp* (map (fresh) assigned*)) 144 | (define temp* assigned*) 145 | (append (map cons assigned* temp*) env)) 146 | (with-output-language (Lconvertassignments expr) 147 | (define (build-let id* expr* body) 148 | (if (null? id*) 149 | body 150 | `(begin 151 | (set!-values (,id*) (#%box ,expr*)) ... 152 | ,body) 153 | #;`(let ([,id* (#%box ,expr*)] ...) 154 | ,body))))) 155 | (Formals : formals (e [env '()]) -> formals () 156 | [,v ((lookup-env env) v)] 157 | [(,v ...) 158 | `(,(map (lookup-env env) v) ...)] 159 | [(,v ,v* ... . ,v2) 160 | `(,((lookup-env env) v) ,(map (lookup-env env) v*) ... . ,((lookup-env env) v2))]) 161 | 162 | ; We can assume quote will never happen, as it's only there for the optimizer 163 | (Lambda : lambda (e [env '()]) -> lambda () 164 | [(#%plain-lambda ,formals 165 | (assigned (,v ...) ,expr)) 166 | (define env* (extend-env env v)) 167 | `(#%plain-lambda ,(Formals formals env*) 168 | ,(build-let v (map (lookup-env env*) v) 169 | (Expr expr env* #t)))]) 170 | (Expr : expr (e [env '()] [boxes? #t]) -> expr () 171 | [(quote ,datum) `(quote ,datum)] 172 | [(let ([,v ,[expr]] ...) 173 | (begin-set! 174 | ,set-expr ... 175 | (assigned (,v* ...) ,expr*))) 176 | (cond [(null? v) (Expr expr* env #t)] 177 | [else (define env* (extend-env env v*)) 178 | (define let* (build-let v* (map (lookup-env env*) v*) 179 | (Expr expr* env* #t))) 180 | (if (= (length set-expr) 0) 181 | `(let ([,(map (lookup-env env*) v) ,expr] ...) 182 | ,let*) 183 | `(let ([,(map (lookup-env env*) v) ,expr] ...) 184 | (begin 185 | ,(for/list ([e (in-list set-expr)]) 186 | (Expr e env* #f)) ... 187 | ,let*)))])] 188 | [,v 189 | (if (dict-has-key? env v) `(#%unbox ,v) v)] 190 | [(set!-values (,v ...) ,expr) 191 | (define expr* (Expr expr env #f)) 192 | (if boxes? 193 | `(set!-boxes (,v ...) ,expr*) 194 | `(set!-values (,(map (lookup-env env) v) ...) ,expr*))])) 195 | 196 | ;; First part of closure conversion, detects which variables are free 197 | ;; and attaches them to their respective procedures. 198 | ;; (lambda (x) y) -> (lambda (x) (free (y) () y)) 199 | ;; The first parens are for local variables and the second parens 200 | ;; are for global (module level) variables. 201 | (define-pass uncover-free : Lconvertassignments (e) -> Luncoverfree () 202 | (definitions 203 | (define-syntax-rule (formals->identifiers* formals) 204 | (formals->identifiers Luncoverfree formals))) 205 | (Lambda : lambda (e [env '()]) -> lambda ('() '()) 206 | [(#%plain-lambda ,[formals] ,expr*) 207 | (define id* (formals->identifiers* formals)) 208 | (define-values (expr free-local free-global) (Expr expr* (set-union env id*))) 209 | (define free-local* (set-subtract free-local id*)) 210 | (values `(#%plain-lambda ,formals 211 | (free (,free-local* ...) (,free-global ...) ,expr)) 212 | free-local* 213 | free-global)]) 214 | (GeneralTopLevelForm : general-top-level-form (e [env '()]) -> general-top-level-form ('() '()) 215 | [(define-values (,v ...) ,[expr free-local free-global]) 216 | (values `(define-values (,v ...) ,expr) 217 | free-local 218 | (set-union free-global v))]) 219 | (Expr : expr (e [env '()]) -> expr ('() '()) 220 | [,v (if (set-member? env v) 221 | (values v (list v) '()) 222 | (values v '() (list v)))] 223 | [(let ([,v* ,[expr* env -> expr* free-local* free-global*]] ...) 224 | ,expr**) 225 | (define-values (expr free-local free-global) (Expr expr** (set-union env v*))) 226 | (values 227 | `(let ([,v* ,expr*] ...) 228 | ,expr) 229 | (apply set-union (set-subtract free-local v*) free-local*) 230 | (apply set-union free-global free-global*))] 231 | [(letrec ([,v* ,lambda**] ...) 232 | ,expr**) 233 | (define env* (set-union env v*)) 234 | (define-values (expr free-local free-global) (Expr expr** env*)) 235 | (define-values (lambda* free-local* free-global*) 236 | (for/fold ([lambda* null] 237 | [free-local* null] 238 | [free-global* null]) 239 | ([i (in-list lambda**)]) 240 | (define-values (l fl fg) (Lambda i env*)) 241 | (values (cons l lambda*) (cons fl free-local*) (cons fg free-global*)))) 242 | (values `(letrec ([,v* ,(reverse lambda*)] ...) 243 | ,expr) 244 | (apply set-union (set-subtract free-local v*) (reverse free-local*)) 245 | (apply set-union (set-subtract free-global v*) (reverse free-global*)))] 246 | [(set!-boxes (,v) ,[expr free-local free-global]) 247 | (if (set-member? env v) 248 | (values `(set!-boxes (,v) ,expr) (set-add free-local v) free-global) 249 | (values `(set!-values (,v) ,expr) free-local (set-add free-global v)))] 250 | [(set!-boxes (,v ...) ,[expr free-local free-global]) 251 | (values `(set!-boxes (,v ...) ,expr) 252 | (set-union free-local (set-intersect v env)) 253 | (set-union free-global (set-subtract v env)))] 254 | [(set!-values (,v ...) ,[expr free-local free-global]) 255 | (values `(set!-values (,v ...) ,expr) 256 | (set-union free-local (set-intersect v env)) 257 | (set-union free-global (set-subtract v env)))] 258 | [(#%box ,v) 259 | (if (set-member? env v) 260 | (values `(#%box ,v) (list v) '()) 261 | (values `(#%box ,v) '() (list v)))] 262 | [(#%unbox ,v) 263 | (if (set-member? env v) 264 | (values `(#%unbox ,v) (list v) '()) 265 | (values `(#%unbox ,v) '() (list v)))] 266 | [(#%variable-reference) 267 | (values `(#%variable-reference) 268 | null 269 | '(#f))] 270 | [(#%variable-reference ,v) 271 | (if (set-member? env v) 272 | (values `(#%variable-reference ,v) (list v) '()) 273 | (values `(#%variable-reference ,v) '() (list v)))] 274 | ;; Everything below here really is boilerplate 275 | [(case-lambda ,[lambda free-local free-global] ...) 276 | (values `(case-lambda ,lambda ...) 277 | (apply set-union '() free-local) 278 | (apply set-union '() free-global))] 279 | [(if ,[expr1 free-local1 free-global1] 280 | ,[expr2 free-local2 free-global2] 281 | ,[expr3 free-local3 free-global3]) 282 | (values `(if ,expr1 ,expr2 ,expr3) 283 | (set-union free-local1 free-local2 free-local3) 284 | (set-union free-global1 free-global2 free-global3))] 285 | [(begin ,[expr* free-local* free-global*] ... 286 | ,[expr free-local free-global]) 287 | (values `(begin ,expr* ... ,expr) 288 | (apply set-union free-local free-local*) 289 | (apply set-union free-global free-global*))] 290 | [(begin0 ,[expr free-local free-global] 291 | ,[expr* free-local* free-global*] ...) 292 | (values `(begin0 ,expr ,expr* ...) 293 | (apply set-union free-local free-local*) 294 | (apply set-union free-global free-global*))] 295 | [(with-continuation-mark ,[expr1 free-local1 free-global1] 296 | ,[expr2 free-local2 free-global2] 297 | ,[expr3 free-local3 free-global3]) 298 | (values `(with-continuation-mark ,expr1 ,expr2 ,expr3) 299 | (set-union free-local1 free-local2 free-local3) 300 | (set-union free-global1 free-global2 free-global3))] 301 | [(#%plain-app ,[expr free-local free-global] 302 | ,[expr* free-local* free-global*] ...) 303 | (values `(#%plain-app ,expr ,expr* ...) 304 | (apply set-union free-local free-local*) 305 | (apply set-union free-global free-global*))]) 306 | (LinkletForm : linklet-form (e) -> linklet-form ('() '())) 307 | (let-values ([(expr locals globals) (LinkletForm e)]) 308 | expr)) 309 | 310 | (define-pass closurify-letrec : Luncoverfree (e) -> Lclosurify () 311 | (definitions 312 | (define (remove-index l index) 313 | (append (take l index) (drop l (+ 1 index))))) 314 | (Formals : formals (e) -> formals ()) 315 | [Expr : expr (e) -> expr () 316 | [(letrec () ,[expr]) 317 | expr] 318 | [(letrec ([,v (#%plain-lambda ,formals (free (,v1* ...) (,binding2* ...) ,expr*))] ...) 319 | ,expr) 320 | (define empty-index 321 | (for/fold ([acc #f]) 322 | ([i (in-list v1*)] 323 | [iter (in-range (length v1*))]) 324 | (if (null? i) iter acc))) 325 | (if empty-index 326 | `(let ([,(list-ref v empty-index) 327 | (closure ,(list-ref v empty-index) 328 | ,(Expr (with-output-language (Luncoverfree expr) 329 | `(#%plain-lambda ,(list-ref formals empty-index) 330 | (free (,(list-ref v1* empty-index) ...) 331 | (,(list-ref binding2* empty-index) ...) 332 | ,(list-ref expr* empty-index))))))]) 333 | ,(Expr (with-output-language (Luncoverfree expr) 334 | `(letrec ([,(remove-index v empty-index) 335 | (#%plain-lambda ,(remove-index formals empty-index) 336 | (free (,(remove-index v1* empty-index) ...) 337 | (,(remove-index binding2* empty-index) ...) 338 | ,(remove-index expr* empty-index)))] 339 | ...) 340 | ,expr)))) 341 | `(letrec ([,v (#%plain-lambda ,(map Formals formals) 342 | (free (,v1* ...) (,binding2* ...) 343 | ,(map Expr expr*)))] ...) 344 | ,(Expr expr)))]]) 345 | 346 | (define-pass void-lets : Lclosurify (e) -> Lvoidlets () 347 | (Expr : expr (e) -> expr () 348 | [(letrec ([,v ,[lambda]] ...) 349 | ,[expr]) 350 | `(let-void (,v ...) 351 | (letrec ([,v ,lambda] ...) 352 | ,expr))] 353 | [(let ([,v ,[expr1]]) ,[expr]) 354 | `(let ([,v ,expr1]) ,expr)] 355 | [(let ([,v (undefined)] ...) ,[expr]) 356 | `(let-void (,v ...) 357 | ,expr)] 358 | [(let ([,v ,[expr1]] ...) ,[expr]) 359 | `(let-void (,v ...) 360 | (begin 361 | (set!-values (,v) ,expr1) ... 362 | ,expr))])) 363 | 364 | (define-pass debruijn-indices : Lvoidlets (e) -> Ldebruijn () 365 | (definitions 366 | (define-syntax-rule (formals->identifiers* fmls) 367 | (formals->identifiers Lreintroducesyntax fmls)) 368 | (define-syntax-rule (formals-rest?* fmls) 369 | (formals-rest? Lreintroducesyntax fmls)) 370 | (define (extend-env env start ids) 371 | (for/fold ([env env] [ref start]) 372 | ([i (in-list ids)]) 373 | (values (dict-set env i (+ ref 1)) (+ ref 1)))) 374 | (define (lookup-env env id) 375 | (dict-ref env id)) 376 | (define (make-global-env prefix) 377 | (define ids (nanopass-case (Ldebruijn prefix-form) prefix 378 | [(prefix (,binding ...) (,stx ...)) binding])) 379 | (for/fold ([env (hash)]) 380 | ([i (in-list ids)] [index (in-range (length ids))]) 381 | (hash-set env i index))) 382 | (define ((var->index env frame global-env) id) 383 | (if (dict-has-key? env id) 384 | (- frame (lookup-env env id)) 385 | (error 'compiler "Variable not bound ~a" id))) 386 | ;; Convert a list of identifiers to it's range and offset 387 | ;; (valid because list ids should be consecutive 388 | ;; (list symbol) -> (values exact-nonnegative-integer exact-nonnegative-integer) 389 | (define (ids->range env frame ids) 390 | (define indices (map (var->index env frame '()) ids)) ;; TODO '() should be global env 391 | (values (length indices) (car indices)))) 392 | (Lambda : lambda (e [env '()] [frame 0] [global-env '()] [prefix-frame 0]) -> lambda () 393 | [(#%plain-lambda ,formals 394 | (free (,v2 ...) (,binding3 ...) 395 | ,expr)) 396 | (define params (formals->identifiers* formals)) 397 | (define rest? (formals-rest?* formals)) 398 | (define-values (env* frame*) (extend-env env frame (reverse (append v2 params)))) 399 | (define frame** (if (= (length binding3) 0) frame* (+ frame* 1))) 400 | (define locals (map (var->index env frame global-env) v2)) 401 | `(#%plain-lambda ,(length params) 402 | ,rest? 403 | (,(if (= (length binding3) 0) 404 | locals 405 | (cons (- frame prefix-frame) locals)) ...) 406 | (,(map ((curry dict-ref) global-env) binding3) ...) 407 | ,(Expr expr env* frame** global-env frame**))]) 408 | (Expr : expr (e [env '()] [frame 0] [global-env '()] [prefix-frame 0]) -> expr () 409 | [,v ((var->index env frame global-env) v)] 410 | [(primitive ,id) `(primitive ,(dict-ref primitive-table* id))] 411 | [(#%box ,v) `(#%box ,((var->index env frame global-env) v))] 412 | [(#%unbox ,v) `(#%unbox ,((var->index env frame global-env) v))] 413 | [(set!-values (,v ...) ,[expr]) 414 | (define-values (count offset) (ids->range env frame v)) 415 | `(set!-values ,count ,offset ,expr)] 416 | [(set!-boxes (,v ...) ,[expr]) 417 | (define-values (count offset) (ids->range env frame v)) 418 | `(set!-boxes ,count ,offset ,expr)] 419 | [(set!-global ,v ,[expr]) 420 | `(set!-global ,(- frame prefix-frame) ,(dict-ref global-env v) ,expr)] 421 | [(#%variable-reference) 422 | `(#%variable-reference-none ,(- frame prefix-frame) ,(hash-ref global-env #f))] 423 | [(#%variable-reference ,v) `(#%variable-reference ,((var->index env frame) v))] 424 | [(let ([,v ,expr1]) 425 | ,expr) 426 | (define-values (env* frame*) (extend-env env frame (list v))) 427 | `(let-one ,(Expr expr1 env (+ frame 1) global-env prefix-frame) 428 | ,(Expr expr env* frame* global-env prefix-frame))] 429 | [(let-void (,v ...) 430 | ,expr) 431 | (define-values (env* frame*) (extend-env env frame (reverse v))) 432 | `(let-void ,(length v) 433 | ,(Expr expr env* frame* global-env prefix-frame))] 434 | [(letrec ([,v ,[lambda]] ...) 435 | ,[expr]) 436 | `(letrec (,lambda ...) 437 | ,expr)] 438 | [(#%plain-app ,expr ,expr* ...) 439 | (define expr1 (Expr expr env (+ frame (length expr*)) global-env prefix-frame)) 440 | (define expr*1 (map (lambda (e) 441 | (Expr e env (+ frame (length expr*)) global-env prefix-frame)) 442 | expr*)) 443 | `(#%plain-app ,expr1 ,expr*1 ...)]) 444 | (GeneralTopLevelForm : general-top-level-form (e [env '()] [frame 0] [global-env '()]) 445 | -> general-top-level-form () 446 | [(define-values (,v ...) ,[expr]) 447 | `(define-values (,(map ((curry dict-ref) global-env) v) ...) ,expr)]) 448 | (CompilationTop : compilation-top (e) -> compilation-top () 449 | [(program ,[prefix-form] ,top-level-form) 450 | `(program ,prefix-form 451 | ,(TopLevelForm top-level-form '() 0 (make-global-env prefix-form) 0))])) 452 | 453 | #| 454 | 455 | (define-pass find-let-depth : Ldebruijn (e) -> Lfindletdepth () 456 | (PrefixForm : prefix-form (e depths) -> prefix-form () 457 | [(prefix (,binding ...) (,stx ...)) 458 | `(prefix (,binding ...) (,stx ...) ,(apply max 1 depths))]) 459 | (Lambda : lambda (e) -> lambda (0) 460 | [(#%plain-lambda ,eni1 ,boolean (,[binding2] ...) (,[binding3] ...) ,[expr depth]) 461 | (define depth* (+ eni1 (length binding2) depth)) 462 | (values `(#%plain-lambda ,eni1 ,boolean (,binding2 ...) (,binding3 ...) 463 | ,(+ 5 464 | eni1 465 | (if boolean 1 0) 466 | (length binding2) 467 | (length binding3) 468 | depth*) 469 | ,expr) 470 | 1)]) 471 | [Binding : binding (e) -> binding (0)] 472 | (Expr : expr (e) -> expr (0) 473 | [(closure ,v ,[lambda depth]) 474 | (values `(closure ,v ,lambda) depth)] 475 | [(let-void ,eni ,[expr depth]) 476 | (values `(let-void ,eni ,expr) 477 | (+ eni depth))] 478 | [(let-one ,[expr depth] ,[expr1 depth1]) 479 | (values `(let-one ,expr ,expr1) 480 | (+ 1 (max depth depth1)))] 481 | [(letrec (,[lambda depth*] ...) ,[expr depth]) 482 | (values `(letrec (,lambda ...) ,expr) 483 | (+ depth (length lambda) (apply max 0 depth*)))] 484 | ;; Everything below this line is boilerplate (except the main body) 485 | [(set!-values ,eni1 ,eni2 ,[expr depth]) 486 | (values `(set!-values ,eni1 ,eni2 ,expr) depth)] 487 | [(set!-boxes ,eni1 ,eni2 ,[expr depth]) 488 | (values `(set!-boxes ,eni1 ,eni2 ,expr) depth)] 489 | [(set!-global ,eni1 ,eni2 ,[expr depth]) 490 | (values `(set!-global ,eni1 ,eni2 ,expr) depth)] 491 | [(case-lambda ,[lambda depth] ...) 492 | (values `(case-lambda ,lambda ...) 493 | (apply max 0 depth))] 494 | [(if ,[expr1 depth1] ,[expr2 depth2] ,[expr3 depth3]) 495 | (values `(if ,expr1 ,expr2 ,expr3) 496 | (max depth1 depth2 depth3))] 497 | [(begin ,[expr* depth*] ... ,[expr depth]) 498 | (values `(begin ,expr* ... ,expr) 499 | (apply max depth depth*))] 500 | [(begin0 ,[expr depth] ,[expr* depth*] ...) 501 | (values `(begin0 ,expr ,expr* ...) 502 | (apply max depth depth*))] 503 | [(with-continuation-mark ,[expr1 depth1] ,[expr2 depth2] ,[expr3 depth3]) 504 | (values `(with-continuation-mark ,expr1 ,expr2 ,expr3) 505 | (max depth1 depth2 depth3))] 506 | [(#%plain-app ,[expr depth] ,[expr* depth*] ...) 507 | (values `(#%plain-app ,expr ,expr* ...) 508 | (+ (length depth*) (apply max depth depth*)))]) 509 | (TopLevelForm : top-level-form (e) -> top-level-form (0) 510 | [,submodule-form (SubmoduleForm submodule-form)] 511 | [(#%expression ,[expr depth]) 512 | (values `(#%expression ,expr) depth)] 513 | [(begin* ,[top-level-form depth] ...) 514 | (values `(begin* ,top-level-form ...) 515 | (apply max 0 depth))] 516 | [(begin-for-syntax* ,prefix-form ,[top-level-form depth] ...) 517 | (values `(begin-for-syntax* ,(PrefixForm prefix-form (apply max 1 depth)) 518 | ,top-level-form ...) 519 | 0)] 520 | [(define-syntaxes* (,v ...) ,prefix-form ,[expr depth]) 521 | (values `(define-syntaxes* (,v ...) ,(PrefixForm prefix-form (list depth)) ,expr) 522 | 0)]) 523 | (ModuleLevelForm : module-level-form (e) -> module-level-form (0)) 524 | (SubmoduleForm : submodule-form (e) -> submodule-form (0) 525 | [(module ,id ,module-path ,prefix-form 526 | (,[raw-provide-spec] ...) 527 | (,[raw-require-spec] ...) 528 | (,[raw-provide-spec*] ...) 529 | (,[module-level-form depth] ...) 530 | (,[syntax-level-form] ...) 531 | (,[submodule-form** depth**] ...) 532 | (,[submodule-form* depth*] ...)) 533 | (values `(module ,id ,module-path 534 | ,(PrefixForm prefix-form depth) 535 | (,raw-provide-spec ...) 536 | (,raw-require-spec ...) 537 | (,raw-provide-spec* ...) 538 | (,module-level-form ...) 539 | (,syntax-level-form ...) 540 | (,submodule-form** ...) 541 | (,submodule-form* ...)) 542 | 0)]) 543 | (GeneralTopLevelForm : general-top-level-form (e) -> general-top-level-form (0) 544 | [(define-values (,eni ...) ,[expr depth]) 545 | (values `(define-values (,eni ...) ,expr) depth)]) 546 | (CompilationTop : compilation-top (e) -> compilation-top () 547 | [(program ,prefix-form ,[top-level-form depth]) 548 | `(program ,(PrefixForm prefix-form (list depth)) ,top-level-form)])) 549 | 550 | (define-pass build-module-registry : Lfindletdepth (e) -> Lbuildmoduleregistry () 551 | (definitions 552 | (define internal-module-registry 553 | (make-module-registry)) 554 | (define current-module-path 555 | (module-registry->current-module-path internal-module-registry)) 556 | (define (RawProvideSpec->hash spec) 557 | (for/hash ([s (in-list spec)]) 558 | (nanopass-case (Lbuildmoduleregistry raw-provide-spec) s 559 | [(for-meta* ,phase-level 560 | (,phaseless-prov-spec ...) 561 | (,phaseless-prov-spec* ...)) 562 | (values phase-level phaseless-prov-spec)])))) 563 | (CompilationTop : compilation-top (e) -> compilation-top () 564 | [(program ,[prefix-form] ,[top-level-form]) 565 | `(program ,prefix-form ,internal-module-registry ,top-level-form)]) 566 | (SubmoduleForm : submodule-form (e) -> submodule-form () 567 | [(module ,id ,module-path ,[prefix-form] 568 | (,[raw-provide-spec] ...) 569 | (,[raw-require-spec] ...) 570 | (,[raw-provide-spec*] ...) 571 | (,[module-level-form] ...) 572 | (,[syntax-level-form] ...) 573 | (,submodule-form ...) 574 | (,submodule-form* ...)) 575 | (define rps (RawProvideSpec->hash raw-provide-spec)) 576 | (define rps* (RawProvideSpec->hash raw-provide-spec*)) 577 | (add-module-to-registry! 578 | internal-module-registry 579 | reintroducesyntax id 580 | (hash-union rps rps* 581 | #:combine (lambda (a b) 582 | (append a b)))) 583 | (parameterize ([current-module-path (append (current-module-path) (list id))]) 584 | `(module ,id ,module-path ,prefix-form 585 | (,raw-provide-spec ...) 586 | (,raw-require-spec ...) 587 | (,raw-provide-spec* ...) 588 | (,module-level-form ...) 589 | (,syntax-level-form ...) 590 | (,(map SubmoduleForm submodule-form) ...) 591 | (,(map SubmoduleForm submodule-form*) ...)))])) 592 | 593 | |# -------------------------------------------------------------------------------- /private/tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require nanopass/base 4 | syntax/parse 5 | racket/match 6 | racket/set 7 | racket/dict 8 | racket/hash 9 | racket/port 10 | racket/list 11 | racket/function 12 | racket/bool 13 | racket/stxparam 14 | racket/stxparam-exptime 15 | racket/block 16 | racket/splicing 17 | compiler/zo-marshal 18 | syntax/toplevel 19 | syntax/strip-context 20 | rackunit 21 | (prefix-in zo: compiler/zo-structs) 22 | (rename-in racket/base 23 | [compile base:compile] 24 | [current-compile base:current-compile]) 25 | (for-syntax racket/base 26 | syntax/parse 27 | racket/syntax 28 | racket/stxparam 29 | racket/stxparam-exptime) 30 | "languages.rkt" 31 | "utils.rkt" 32 | "components.rkt" 33 | "compiler.rkt") 34 | 35 | (module+ test 36 | (require rackunit 37 | rackunit/text-ui) 38 | 39 | (provide (all-defined-out)) 40 | 41 | ;; Store of all tests created with define-compiler-test 42 | (define all-compiler-tests '()) 43 | 44 | ; Defines a test-suite for nanopass, 45 | ; binds quasiquote to the language, test called `lang`-tests 46 | ; lang tests ... -> void 47 | (define-syntax (define-compiler-test stx) 48 | (syntax-parse stx 49 | [(_ lang form body ...+) 50 | #:with with-output-language (format-id stx "with-output-language") 51 | #:with name (format-id stx "~a-tests~a" #'lang (gensym)) 52 | #:with current-compile (format-id stx "current-compile") 53 | #`(begin 54 | (define name 55 | (with-output-language (lang form) 56 | (let ([current-compile current-compile-top]) 57 | (test-suite 58 | (format "Test suite for: ~a" '#,(syntax->datum #'lang)) 59 | (test-case (format "Test case for: ~a" '#,(syntax->datum #'lang)) 60 | body) ...)))) 61 | (set! all-compiler-tests (cons name all-compiler-tests)))])) 62 | 63 | ;; Run all tests defined with define-compiler-test 64 | (define-syntax-rule (run-all-compiler-tests) 65 | (let () 66 | (define res (map run-tests (reverse all-compiler-tests))) 67 | (exit-handler (lambda (code) 68 | (max code (min (apply + res) 255)))) 69 | (void))) 70 | 71 | (define current-visited-structs (make-parameter (set))) 72 | 73 | (define (compiler-equal? actual expected) 74 | (cond [(set-member? (current-visited-structs) (cons actual expected)) 75 | #t] 76 | [(and (syntax? actual) (syntax? expected)) 77 | (equal? (syntax->datum actual) (syntax->datum expected))] 78 | [(and (variable? actual) (variable? expected)) 79 | (equal? (variable-name actual) (variable-name expected))] 80 | [else 81 | (parameterize ([current-visited-structs 82 | (set-add (current-visited-structs) (cons actual expected))]) 83 | (equal?/recur actual expected compiler-equal?))])) 84 | (define-binary-check (check-compiler-equal? compiler-equal? actual expected)) 85 | 86 | ;; Compare result of current compiler to regular compiler 87 | (define-syntax (compile-compare stx) 88 | (syntax-case stx () 89 | [(_ expression) 90 | #`(test-case "Test case for finished compiler" 91 | #,(quasisyntax/loc stx 92 | (check-equal? 93 | (parameterize ([current-namespace (make-base-namespace)]) 94 | (namespace-require 'racket/undefined) 95 | #,(quasisyntax/loc stx 96 | (eval #,(syntax/loc stx 97 | (compile (namespace-syntax-introduce 98 | (strip-context expression))))))) 99 | (parameterize ([current-namespace (make-base-namespace)]) 100 | (namespace-require 'racket/undefined) 101 | (eval (namespace-syntax-introduce 102 | (strip-context expression)))))))])) 103 | 104 | ;; Used to update the current compiler while testing 105 | (define current-compile-number 1) 106 | (define current-compile-top (list-ref compilers current-compile-number)) 107 | (define (update-current-compile!) 108 | (set! current-compile-number (+ current-compile-number 1)) 109 | (set! current-compile-top (list-ref compilers current-compile-number)))) 110 | 111 | ;; =================================================================================================== 112 | 113 | (module+ test 114 | (update-current-compile!) 115 | (block 116 | (define x (make-variable 'x)) 117 | (define a (make-variable 'a)) 118 | (define b (make-variable 'b)) 119 | (define c (make-variable 'c)) 120 | (define match (make-variable 'match)) 121 | (define match2 (make-variable 'match2)) 122 | (define-compiler-test Lsrc top-level-form 123 | (check-compiler-equal? 124 | (current-compile #'(lambda (x) x)) 125 | `(#%expression (#%plain-lambda (,x) ,x))) 126 | (check-compiler-equal? 127 | (current-compile #'(module outer racket 128 | (#%plain-module-begin 129 | (module* post racket 130 | (#%plain-module-begin 131 | (+ 1 2))) 132 | (+ 3 4) 133 | (module pre racket 134 | (#%plain-module-begin 135 | (+ 5 6)))))) 136 | `(module outer racket 137 | ((submodule* post racket 138 | ((#%plain-app (primitive +) '1 '2))) 139 | (#%plain-app (primitive +) '3 '4) 140 | (submodule pre racket 141 | ((#%plain-app (primitive +) '5 '6)))))) 142 | (check-compiler-equal? 143 | (current-compile #'(begin-for-syntax 144 | (define x 5))) 145 | `(begin-for-syntax* 146 | (define-values (,x) '5))) 147 | (check-compiler-equal? 148 | (current-compile #'(module test racket 149 | (#%plain-module-begin 150 | (begin-for-syntax 151 | (define x 5))))) 152 | `(module test racket 153 | ((begin-for-syntax 154 | (define-values (,x) '5))))) 155 | (check-compiler-equal? 156 | (current-compile #'(lambda () 5)) 157 | `(#%expression (#%plain-lambda () '5))) 158 | (check-compiler-equal? 159 | (current-compile #'(lambda (a b . c) 160 | (apply + a b c))) 161 | `(#%expression (#%plain-lambda (,a ,b . ,c) 162 | (#%plain-app (primitive apply) (primitive +) ,a ,b ,c)))) 163 | (check-compiler-equal? 164 | (current-compile #'(module foo racket/base 165 | (#%plain-module-begin 166 | (require racket/match) 167 | (#%provide (all-from-except racket/match match))))) 168 | `(module foo racket/base 169 | ((#%require racket/match) 170 | (#%provide (all-from-except racket/match ,(make-variable 'match)))))) 171 | (check-compiler-equal? 172 | (current-compile #'(module bar racket/base 173 | (#%plain-module-begin 174 | (#%require (for-template racket/base) 175 | (for-label racket/base) 176 | (just-meta 0 racket)) 177 | 42))) 178 | `(module bar racket/base 179 | ((#%require (for-meta -1 racket/base) 180 | (for-meta #f racket/base) 181 | (just-meta 0 racket)) 182 | '42))) 183 | (check-compiler-equal? 184 | (current-compile #'(module bar racket/base 185 | (#%plain-module-begin 186 | (#%require (only racket/match match) 187 | (all-except racket/match match) 188 | (rename racket/match match2 match) 189 | (prefix match2: racket/match) 190 | (prefix-all-except match: racket/match match) 191 | ; TODO (planet "match" ("match" "match")) ; Not a real package 192 | )))) 193 | `(module bar racket/base 194 | ((#%require (only racket/match ,match) 195 | (all-except racket/match ,match) 196 | (rename racket/match ,match2 ,match) 197 | (prefix-all-except match2: racket/match) 198 | (prefix-all-except match: racket/match ,match) 199 | ; TODO (planet "match" ("match" "match")) 200 | )))) 201 | (check-compiler-equal? 202 | (current-compile #'(module bar racket 203 | (#%plain-module-begin 204 | (define x 5) 205 | (provide x)))) 206 | `(module bar racket 207 | ((define-values (,x) '5) 208 | (#%provide ,x)))) 209 | (let*-values ([(code) (current-compile #'(begin (define x 5) 210 | x))] 211 | [(v1 v2) (nanopass-case (Lsrc top-level-form) code 212 | [(begin* (define-values (,var1) ,expr) 213 | ,var2) 214 | (values var1 var2)])]) 215 | (check-true (equal? v1 v2))) 216 | (check-compiler-equal? 217 | (current-compile #`(eval #'(+ 1 2))) 218 | `(#%plain-app (primitive eval) (quote-syntax ,#'(+ 1 2)))) 219 | (check-compiler-equal? 220 | (current-compile #`(eval (quote-syntax (+ 1 2) #:local))) 221 | `(#%plain-app (primitive eval) (quote-syntax-local ,#'(+ 1 2)))) 222 | (check-compiler-equal? 223 | (current-compile #'(begin 224 | (define x 5) 225 | (#%variable-reference (#%top . x)))) 226 | `(begin* 227 | (define-values (,x) '5) 228 | (#%variable-reference-top ,x))) 229 | (check-compiler-equal? 230 | (current-compile #'(module foo racket/base 231 | (#%plain-module-begin 232 | (#%require (for-label racket/match)) 233 | (#%provide (for-label match)) 234 | (define x 5) 235 | (#%provide (protect x))))) 236 | `(module foo racket/base 237 | ((#%require (for-meta #f racket/match)) 238 | (#%provide (for-meta* #f ,match)) 239 | (define-values (,x) '5) 240 | (#%provide (protect ,x))))) 241 | (check-compiler-equal? 242 | (current-compile #'(module foo racket/base 243 | (#%plain-module-begin 244 | (module bar racket/base 245 | (#%plain-module-begin 246 | 42)) 247 | (#%require (submod "." bar))))) 248 | `(module foo racket/base 249 | ((submodule bar racket/base 250 | ('42)) 251 | (#%require (submod "." bar)))))))) 252 | 253 | ;; =================================================================================================== 254 | 255 | (module+ test 256 | (update-current-compile!) 257 | (block 258 | (define x (make-variable 'x)) 259 | (define-compiler-test Lsubmodules top-level-form 260 | (check-compiler-equal? 261 | (current-compile #'(module foo racket/base 262 | (#%plain-module-begin 263 | (module bar racket/base 264 | (#%plain-module-begin 265 | 12)) 266 | (define x 5) 267 | (module* baz racket/base 268 | (#%plain-module-begin 269 | 1))))) 270 | `(module foo racket/base 271 | ((#%plain-app (primitive void)) 272 | (define-values (,x) '5) 273 | (#%plain-app (primitive void))) 274 | ((module bar racket/base 275 | ('12) () ())) 276 | ((module baz racket/base 277 | ('1) () ())))) 278 | (check-compiler-equal? 279 | (current-compile #'(module outer racket 280 | (#%plain-module-begin 281 | (begin-for-syntax 282 | (define x 6) 283 | (module* test #f 284 | (#%plain-module-begin 285 | x)))))) 286 | `(module outer racket 287 | ((begin-for-syntax 288 | (define-values (,x) '6) 289 | (#%plain-app (primitive void)))) 290 | () 291 | ((module test #f 292 | (,x) () ())))) 293 | (check-compiler-equal? 294 | (current-compile #'(module outer racket 295 | (#%plain-module-begin 296 | (module* inner #f 297 | (#%plain-module-begin 298 | 5))))) 299 | `(module outer racket 300 | ((#%plain-app (primitive void))) 301 | () 302 | ((module inner #f 303 | ('5) () ())))) 304 | (check-compiler-equal? 305 | (current-compile #'(module foo racket/base 306 | (#%plain-module-begin 307 | (begin 308 | (module bar racket/base 309 | (#%plain-module-begin 310 | 5)) 311 | (module baz racket/base 312 | (#%plain-module-begin 313 | 6)) 314 | (define x 5)) 315 | x))) 316 | `(module foo racket/base 317 | ((#%plain-app (primitive void)) 318 | (#%plain-app (primitive void)) 319 | (define-values (,x) '5) 320 | ,x) 321 | ((module bar racket/base 322 | ('5) () ()) 323 | (module baz racket/base 324 | ('6) () ())) 325 | ())) 326 | (check-compiler-equal? 327 | (current-compile #'(module foo racket/base 328 | (#%plain-module-begin 329 | (module bar racket/base 330 | (#%plain-module-begin 331 | (module baz racket/base 332 | (#%plain-module-begin 333 | 42))))))) 334 | `(module foo racket/base 335 | ((#%plain-app (primitive void))) 336 | ((module bar racket/base 337 | ((#%plain-app (primitive void))) 338 | ((module baz racket/base 339 | ('42) 340 | () ())) 341 | ())) 342 | ()))))) 343 | 344 | ;; =================================================================================================== 345 | 346 | (module+ test 347 | (update-current-compile!) 348 | (block 349 | (define x (make-variable 'x)) 350 | (define-compiler-test Lreqprov top-level-form 351 | (check-compiler-equal? 352 | (current-compile #'(module foo racket 353 | (#%plain-module-begin 354 | (#%require (for-syntax racket/match) 355 | (for-meta 2 racket/list)) 356 | (#%provide (for-syntax (all-from-except racket/match match)) 357 | (for-meta 2 (all-from-except racket/list)) 358 | (all-defined))))) 359 | `(module foo racket 360 | ((for-meta* 1 (all-from-except racket/match ,(make-variable 'match))) 361 | (for-meta* 2 (all-from-except racket/list)) 362 | (all-defined-except)) 363 | ((for-meta 1 racket/match) 364 | (for-meta 2 racket/list)) 365 | ((#%plain-app (primitive void)) (#%plain-app (primitive void))) 366 | () ())) 367 | (check-compiler-equal? 368 | (current-compile #'(module foo racket 369 | (#%plain-module-begin 370 | (begin-for-syntax 371 | (define x 5) 372 | (#%provide x))))) 373 | `(module foo racket 374 | ((for-meta* 1 ,x)) 375 | () 376 | ((begin-for-syntax 377 | (define-values (,x) '5) 378 | (#%plain-app (primitive void)))) 379 | () ())) 380 | (check-compiler-equal? 381 | (current-compile #'(module test racket/base 382 | (#%plain-module-begin 383 | (#%require racket/match) 384 | (display (+ 1 2))))) 385 | `(module test racket/base 386 | () 387 | (racket/match) 388 | ((#%plain-app (primitive void)) 389 | (#%plain-app (primitive display) (#%plain-app (primitive +) '1 '2))) 390 | () ()))))) 391 | 392 | ;; =================================================================================================== 393 | 394 | (module+ test 395 | (update-current-compile!) 396 | (block 397 | (define x (make-variable 'x)) 398 | (define-compiler-test Lsyntax top-level-form 399 | (check-compiler-equal? 400 | (current-compile #'(module foo racket 401 | (#%plain-module-begin 402 | (begin-for-syntax 403 | (define x 5)) 404 | (define-syntax foo (lambda (x) x))))) 405 | `(module foo racket 406 | () () 407 | ((#%plain-app (primitive void)) 408 | (#%plain-app (primitive void))) 409 | ((syntax 1 ((begin-for-syntax 410 | (define-values (,x) '5)) 411 | (define-syntaxes (,(make-variable 'foo)) (#%plain-lambda (,x) ,x))))) 412 | () ()))))) 413 | 414 | ;; =================================================================================================== 415 | 416 | (module+ test 417 | (update-current-compile!) 418 | (block 419 | (define x* (make-variable 'x)) 420 | (define y (make-variable 'y)) 421 | (define z (make-variable 'z)) 422 | (define-compiler-test Lmodulevars top-level-form 423 | (check-compiler-equal? 424 | (current-compile #'(module foo racket 425 | (#%plain-module-begin 426 | (define x 5) 427 | (define-syntax y 6) 428 | (begin-for-syntax 429 | (define z 8))))) 430 | `(module foo racket (prefix (,x*)) 431 | () () 432 | ((define-values (,x*) '5) 433 | (#%plain-app (primitive void)) 434 | (#%plain-app (primitive void))) 435 | ((syntax 1 436 | ((define-syntaxes (,y) (prefix ()) '6) 437 | (begin-for-syntax 438 | (prefix (,z)) 439 | (define-values (,z) '8))))) 440 | () ())) 441 | (check-compiler-equal? 442 | (current-compile #'(begin 443 | (module foo racket 444 | (#%plain-module-begin 445 | (provide x) 446 | (define x 5))) 447 | (require 'foo) 448 | x)) 449 | `(begin* 450 | (module foo racket (prefix (,x*)) 451 | (,x*) () 452 | ((#%plain-app (primitive void)) 453 | (define-values (,x*) '5)) 454 | () 455 | () ()) 456 | (#%require (quote* foo)) 457 | ,x*))))) 458 | 459 | ;; =================================================================================================== 460 | 461 | (module+ test 462 | (update-current-compile!) 463 | (block 464 | (define x (make-variable 'x)) 465 | (define-compiler-test Lscrubreqprov top-level-form 466 | (check-compiler-equal? 467 | (current-compile #'(begin 468 | (require racket/list) 469 | rest)) 470 | `(begin* 471 | (#%require (for-meta 0 racket/list)) 472 | ,(make-variable 'rest))) 473 | (check-compiler-equal? 474 | (current-compile #'(module test racket 475 | (#%plain-module-begin 476 | (#%require racket/match) 477 | (display (+ 1 2))))) 478 | `(module test racket (prefix ()) 479 | () 480 | ((for-meta 0 racket/match)) 481 | ((#%plain-app (primitive void)) 482 | (#%plain-app (primitive display) (#%plain-app (primitive +) '1 '2))) 483 | () () ())) 484 | (check-compiler-equal? 485 | (current-compile #'(module foo racket 486 | (#%plain-module-begin 487 | (provide x) 488 | (define x 5)))) 489 | `(module foo racket (prefix (,x)) 490 | ((for-meta* 0 ,x)) () 491 | ((#%plain-app (primitive void)) 492 | (define-values (,x) '5)) 493 | () () ()))))) 494 | 495 | ;; =================================================================================================== 496 | 497 | (module+ test 498 | (update-current-compile!) 499 | (block 500 | (define x (make-variable 'x)) 501 | (define y (make-variable 'y)) 502 | (define-compiler-test Lindirectprov top-level-form 503 | (check-compiler-equal? 504 | (current-compile #'(module foo racket 505 | (#%plain-module-begin 506 | (define x 5) 507 | (define y 6) 508 | (provide x) 509 | (provide y)))) 510 | `(module foo racket (prefix (,y ,x)) 511 | ((for-meta* 0 (,x ,y) ())) 512 | () 513 | () 514 | ((define-values (,x) '5) 515 | (define-values (,y) '6) 516 | (#%plain-app (primitive void)) 517 | (#%plain-app (primitive void))) 518 | () () ()))))) 519 | 520 | ;; =================================================================================================== 521 | 522 | (module+ test 523 | (update-current-compile!) 524 | (block 525 | (define x (make-variable 'x)) 526 | (define y (make-variable 'y)) 527 | (define f (make-variable 'f)) 528 | (define-compiler-test Lbeginexplicit top-level-form 529 | (check-compiler-equal? 530 | (current-compile #'(lambda (x) x x)) 531 | `(#%expression (#%plain-lambda (,x) (begin ,x ,x)))) 532 | (check-compiler-equal? 533 | (current-compile #'(case-lambda [(x) (+ x 1) (begin0 x (set! x 42))])) 534 | `(#%plain-lambda (,x) 535 | (begin (#%plain-app (primitive +) ,x'1) 536 | (begin0 ,x 537 | (set! ,x '42))))) 538 | (check-compiler-equal? 539 | (current-compile #'(case-lambda [(x) (+ x 1)] 540 | [(x y) x (+ x y)])) 541 | `(case-lambda (#%plain-lambda (,x) (#%plain-app (primitive +) ,x '1)) 542 | (#%plain-lambda (,x ,y) (begin ,x (#%plain-app (primitive +) ,x ,y))))) 543 | (check-compiler-equal? 544 | (current-compile #'(letrec ([f 5]) 545 | (display "Hello") 546 | f)) 547 | `(letrec-values ([(,f) '5]) 548 | (begin 549 | (#%plain-app (primitive display) '"Hello") 550 | ,f)))))) 551 | 552 | ;; =================================================================================================== 553 | 554 | (module+ test 555 | (update-current-compile!) 556 | (block 557 | (define x (make-variable 'x)) 558 | (define y (make-variable 'y)) 559 | (define-compiler-test Lidentifyassigned top-level-form 560 | (check-compiler-equal? 561 | (current-compile #'(letrec ([y 8]) 562 | y)) 563 | `(letrec-values ([(,y) '8]) 564 | (assigned () 565 | ,y))) 566 | (check-compiler-equal? 567 | (current-compile #'(let ([x 8]) 568 | (set! x 5) 569 | (+ x 42))) 570 | `(let-values ([(,x) '8]) 571 | (assigned (,x) 572 | (begin (set! ,x '5) 573 | (#%plain-app (primitive +) ,x '42))))) 574 | (check-compiler-equal? 575 | (current-compile #'(let ([x 1]) 576 | (letrec ([y (lambda (x) y)]) 577 | (+ x y)))) 578 | `(let-values ([(,x) '1]) 579 | (assigned () 580 | (letrec-values ([(,y) (#%plain-lambda (,x) (assigned () ,y))]) 581 | (assigned () 582 | (#%plain-app (primitive +) ,x ,y)))))) 583 | (check-compiler-equal? 584 | (current-compile #'(lambda x 585 | (set! x 42) 586 | x)) 587 | `(#%expression (#%plain-lambda ,x 588 | (assigned (,x) 589 | (begin 590 | (set! ,x '42) 591 | ,x)))))))) 592 | 593 | ;; =================================================================================================== 594 | 595 | ;; TODO: need tests here 596 | ;; (Use tests from cp0 pass) 597 | (module+ test 598 | (update-current-compile!)) 599 | 600 | ;; =================================================================================================== 601 | 602 | (module+ test 603 | (update-current-compile!) 604 | (block 605 | (define a (make-variable 'a)) 606 | (define b (make-variable 'b)) 607 | (define c (make-variable 'c)) 608 | (define f (make-variable 'f)) 609 | (define x (make-variable 'x)) 610 | (define y (make-variable 'y)) 611 | (define z (make-variable 'z)) 612 | (define-compiler-test Lpurifyletrec top-level-form 613 | (check-compiler-equal? 614 | (current-compile #'((lambda (x) 42) 54)) 615 | `'42) 616 | (check-compiler-equal? 617 | (current-compile #'((lambda (x) x) (lambda (y) y))) 618 | `(#%plain-lambda (,y) (assigned () ,y))) 619 | (check-compiler-equal? 620 | (current-compile #'(let ([x 5] 621 | [y 6]) 622 | (+ x y))) 623 | `'11) 624 | (check-compiler-equal? 625 | (current-compile #'(letrec-values ([(a) (lambda (x) a)]) 626 | a)) 627 | `(letrec ([,a (#%plain-lambda (,x) (assigned () ,a))]) 628 | ,a)) 629 | (check-compiler-equal? 630 | (current-compile #'(letrec-values ([(a) (lambda (x) b)] 631 | [(b) (lambda (y) a)]) 632 | (a b))) 633 | `(letrec ([,a (#%plain-lambda (,x) (assigned () ,b))] 634 | [,b (#%plain-lambda (,y) (assigned () ,a))]) 635 | ,b)) 636 | (check-compiler-equal? 637 | (current-compile #'(letrec-values ([(a) 5] 638 | [(b c) (values 6 7)]) 639 | (+ a b c))) 640 | `(let ([,a (undefined)] 641 | [,b (undefined)] 642 | [,c (undefined)]) 643 | (begin-set! 644 | (set!-values (,a) '5) 645 | (set!-values (,b ,c) (#%plain-app (primitive values) '6 '7)) 646 | (assigned (,c ,b ,a) 647 | (#%plain-app (primitive +) ,a ,b ,c))))) 648 | (check-compiler-equal? 649 | (current-compile #'(let ([x (if #t 5 6)]) 650 | (set! x (+ x 1)))) 651 | `(let ([,x '5]) 652 | (begin-set! 653 | (assigned (,x) (set!-values (,x) (#%plain-app (primitive +) ,x '1)))))) 654 | (check-compiler-equal? 655 | (current-compile #'(let-values ([(x y) (values 1 2)] 656 | [(z) 3]) 657 | (set! x 5) 658 | (+ y z))) 659 | `(let ([,x (undefined)] 660 | [,y (undefined)] 661 | [,z (undefined)]) 662 | (begin-set! 663 | (set!-values (,x ,y) (#%plain-app (primitive values) '1 '2)) 664 | (set!-values (,z) '3) 665 | (assigned (,x) 666 | (#%plain-app (primitive +) ,y ,z))))) 667 | (check-compiler-equal? 668 | (current-compile #'(let-values ([(x y) (values 1 2)]) 669 | (set! x y) 670 | y)) 671 | `(let ([,x (undefined)] 672 | [,y (undefined)]) 673 | (begin-set! 674 | (set!-values (,x ,y) (#%plain-app (primitive values) '1 '2)) 675 | (assigned (,x) 676 | ,y)))) 677 | (check-compiler-equal? 678 | (current-compile #'(letrec ([fact (lambda (x) 679 | (if (x . <= . 0) 680 | 1 681 | (* x (fact (- x 1)))))]) 682 | (fact 5))) 683 | `'120) 684 | (check-compiler-equal? 685 | (current-compile #'(string-append "hello " (symbol->string 'world))) 686 | `'"hello world") 687 | (check-compiler-equal? 688 | (current-compile #'(/ 5 0)) 689 | `(#%plain-app (primitive /) '5 '0)) 690 | (check-compiler-equal? 691 | (current-compile #'(let ([x 5]) 692 | (set! x 6) 693 | x)) 694 | `(let ([,x '5]) 695 | (begin-set! 696 | (assigned (,x) 697 | (begin 698 | (set!-values (,x) '6) 699 | ,x))))) 700 | (check-compiler-equal? 701 | (current-compile #'(let ([x 5]) 702 | (lambda (y) x))) 703 | `(#%plain-lambda (,y) (assigned () '5))) 704 | (check-compiler-equal? 705 | (current-compile #'(let ([x (read)]) 706 | (let ([x x]) 707 | (+ x x)))) 708 | `(let ([,x (#%plain-app (primitive read))]) 709 | (begin-set! 710 | (assigned () 711 | (#%plain-app (primitive +) ,x ,x))))) 712 | (check-compiler-equal? 713 | (current-compile #'(let () 714 | (define (f a) 715 | (f a)) 716 | (f (lambda (x) '(1 2 3))))) 717 | `(letrec ([,f (#%plain-lambda (,a) (assigned () (#%plain-app ,f ,a)))]) 718 | (let ([,a (#%plain-lambda (,x) (assigned () ','(1 2 3)))]) 719 | (begin-set! (assigned () (#%plain-app ,f ,a)))))) 720 | (check-compiler-equal? 721 | (current-compile #'(if (lambda (x) x) 5 6)) 722 | `'5) 723 | (check-compiler-equal? 724 | (current-compile #'(let ([x 5]) 725 | (set! x (begin (lambda (x) 5) 726 | 6)) 727 | x)) 728 | `(let ([,x '5]) 729 | (begin-set! 730 | (assigned (,x) 731 | (begin 732 | (set!-values (,x) '6) 733 | ,x))))) 734 | (check-compiler-equal? 735 | (current-compile #'((lambda (x) 5) 6 7)) 736 | `(#%plain-app 737 | (#%plain-lambda (,x) (assigned () '5)) 738 | '6 '7)) 739 | (current-compile 740 | #'(let () 741 | (define (fold l init f) 742 | (if (null? l) 743 | init 744 | (fold (cdr l) (f init (car l)) f))) 745 | (define (pow-sum l n) 746 | (fold l 0 (lambda (x y) (+ (expt x n) (expt y n))))) 747 | (pow-sum '(1 2 3) 2))) 748 | (check-compiler-equal? 749 | (current-compile 750 | #'((lambda (x . y) (apply + x y)) 751 | 5 6 7)) 752 | `(#%plain-app (primitive apply) (primitive +) '5 ','(6 7))) 753 | (check-compiler-equal? 754 | (current-compile 755 | #'(case-lambda [() 10] 756 | [(x) x] 757 | [(x y . z) z] 758 | [x x])) 759 | `(case-lambda [#%plain-lambda () (assigned () '10)] 760 | [#%plain-lambda (,x) (assigned () ,x)] 761 | [#%plain-lambda (,x ,y . ,z) (assigned () ,z)] 762 | [#%plain-lambda ,x (assigned () ,x)])) 763 | (check-compiler-equal? 764 | (current-compile 765 | #'((case-lambda [(x) x] 766 | [(x y) (+ x y)]) 42)) 767 | `'42)))) 768 | 769 | ;; =================================================================================================== 770 | 771 | 772 | (module+ test 773 | (update-current-compile!) 774 | (block 775 | (define x (make-variable 'x)) 776 | (define y (make-variable 'y)) 777 | (define f (make-variable 'f)) 778 | (define a (make-variable 'a)) 779 | (define-compiler-test Lconvertassignments top-level-form 780 | (check-compiler-equal? 781 | (current-compile #'(let ([x 5]) 782 | (set! x 6) 783 | x)) 784 | `(let ([,x '5]) 785 | (begin 786 | (set!-values (,x) (#%box ,x)) 787 | (begin 788 | (set!-boxes (,x) '6) 789 | (#%unbox ,x))))) 790 | (check-compiler-equal? 791 | (current-compile #'(lambda (x y) 792 | (set! x 5) 793 | (list x y))) 794 | `(#%expression (#%plain-lambda (,x ,y) 795 | (begin 796 | (set!-values (,x) (#%box ,x)) 797 | (begin 798 | (set!-boxes (,x) '5) 799 | (#%plain-app (primitive list) (#%unbox ,x) ,y)))))) 800 | (check-compiler-equal? 801 | (current-compile #'(lambda x 802 | (let () 803 | (set! x 42) 804 | (+ x 8)))) 805 | `(#%expression (#%plain-lambda ,x 806 | (begin 807 | (set!-values (,x) (#%box ,x)) 808 | (begin 809 | (set!-boxes (,x) '42) 810 | (#%plain-app (primitive +) (#%unbox ,x) '8)))))) 811 | (check-compiler-equal? 812 | (current-compile #'(let-values ([(x y) (values 1 2)]) 813 | (set! x y) 814 | y)) 815 | `(let ([,x (undefined)] 816 | [,y (undefined)]) 817 | (begin 818 | (set!-values (,x ,y) (#%plain-app (primitive values) '1 '2)) 819 | (begin 820 | (set!-values (,x) (#%box ,x)) 821 | ,y)))) 822 | (check-compiler-equal? 823 | (current-compile #'(letrec ([f (lambda (a) (f a))]) 824 | (f 1))) 825 | `(letrec ([,f (#%plain-lambda (,a) (#%plain-app ,f ,a))]) 826 | (#%plain-app ,f '1)))))) 827 | 828 | ;; =================================================================================================== 829 | 830 | (module+ test 831 | (update-current-compile!) 832 | (block 833 | (define x (make-variable 'x)) 834 | (define y (make-variable 'y)) 835 | (define z (make-variable 'z)) 836 | (define w (make-variable 'w)) 837 | (define f (make-variable 'f)) 838 | (define-compiler-test Luncoverfree compilation-top 839 | (check-compiler-equal? 840 | (current-compile #'(lambda (x) 841 | (lambda (y) 842 | x))) 843 | `(program (prefix ()) 844 | (#%expression 845 | (#%plain-lambda (,x) 846 | (free () () 847 | (#%plain-lambda (,y) 848 | (free (,x) () 849 | ,x))))))) 850 | (check-compiler-equal? 851 | (current-compile #'(let ([x 5]) 852 | (lambda (y) 853 | x))) 854 | `(program (prefix ()) (#%plain-lambda (,y) (free () () '5)))) 855 | (check-compiler-equal? 856 | (current-compile #'(begin 857 | (define x 5) 858 | (lambda y (if x 4 5)))) 859 | `(program (prefix (,x)) 860 | (begin* 861 | (define-values (,x) '5) 862 | (#%expression 863 | (#%plain-lambda ,y 864 | (free () (,x) 865 | (if ,x '4 '5))))))) 866 | (check-compiler-equal? 867 | (current-compile #'(let ([x 5]) 868 | (set! x 6) 869 | x)) 870 | `(program (prefix ()) 871 | (let ([,x '5]) 872 | (begin 873 | (set!-values (,x) (#%box ,x)) 874 | (begin 875 | (set!-boxes (,x) '6) 876 | (#%unbox ,x)))))) 877 | (check-compiler-equal? 878 | (current-compile #'(let ([x 6]) 879 | (letrec ([f (lambda () x)]) 880 | (set! x 7) 881 | (f f)))) 882 | `(program (prefix ()) 883 | (let ([,x '6]) 884 | (begin 885 | (set!-values (,x) (#%box ,x)) 886 | (letrec ([,f (#%plain-lambda () (free (,x) () (#%unbox ,x)))]) 887 | (begin 888 | (set!-boxes (,x) '7) 889 | (#%plain-app (#%plain-lambda () (free (,x) () (#%unbox ,x))) 890 | ,f))))))) 891 | (check-compiler-equal? 892 | (current-compile #'(begin 893 | (define x 5) 894 | (set! x 6))) 895 | `(program (prefix (,x)) 896 | (begin* 897 | (define-values (,x) '5) 898 | (set!-values (,x) '6)))) 899 | (check-compiler-equal? 900 | (current-compile #'(letrec ([f (lambda (x) x)]) 901 | (f 12))) 902 | `(program (prefix ()) '12)) 903 | (check-compiler-equal? 904 | (current-compile #'(begin 905 | (define x 5) 906 | (define y 6) 907 | (module foo racket/base 908 | (#%plain-module-begin 909 | (define x 12) 910 | (define z 13))))) 911 | `(program (prefix (,y ,x)) 912 | (begin* 913 | (define-values (,x) '5) 914 | (define-values (,y) '6) 915 | (module foo racket/base (prefix (,z ,x)) 916 | () () ((for-meta* 0 (,x ,z) ())) 917 | ((define-values (,x) '12) 918 | (define-values (,z) '13)) 919 | () () ())))) 920 | (check-compiler-equal? 921 | (current-compile #'(lambda (x) 922 | (#%variable-reference))) 923 | `(program (prefix (#f)) 924 | (#%expression 925 | (#%plain-lambda (,x) 926 | (free () (#f) 927 | (#%variable-reference)))))) 928 | (check-compiler-equal? 929 | (current-compile #'(module foobar racket/base 930 | (#%plain-module-begin 931 | (define x 5) 932 | (define-values (y z) (values 6 7)) 933 | (define-syntax w 'hello)))) 934 | `(program (prefix ()) 935 | (module foobar racket/base (prefix (,z ,y ,x)) 936 | () () ((for-meta* 0 (,x ,y ,z) (,w))) 937 | ((define-values (,x) '5) 938 | (define-values (,y ,z) (#%plain-app (primitive values) '6 '7)) 939 | (#%plain-app (primitive void))) 940 | ((syntax 1 ((define-syntaxes (,w) (prefix ()) 'hello)))) 941 | () ())))))) 942 | 943 | ;; =================================================================================================== 944 | 945 | (module+ test 946 | (update-current-compile!) 947 | (block 948 | (define x (make-variable 'x)) 949 | (define y (make-variable 'y)) 950 | (define z (make-variable 'z)) 951 | (define ccmk (make-variable 'contract-continuation-mark-key)) 952 | (define r (make-variable 'random)) 953 | (define-compiler-test Lraisetoplevel compilation-top 954 | (check-compiler-equal? 955 | (current-compile #'(begin 956 | (define x 5) 957 | (set! x 6) 958 | x)) 959 | `(program (prefix (,x)) 960 | (begin* 961 | (define-values (,x) '5) 962 | (set!-global ,x '6) 963 | (#%top . ,x)))) 964 | (check-compiler-equal? 965 | (current-compile #'(begin 966 | (define x 5) 967 | (#%variable-reference x))) 968 | `(program (prefix (,x)) 969 | (begin* 970 | (define-values (,x) '5) 971 | (#%variable-reference-top ,x)))) 972 | (check-compiler-equal? 973 | (current-compile #'(begin 974 | (define x 5) 975 | (lambda (y) 976 | (lambda (z) 977 | (+ x y z))))) 978 | `(program (prefix (,x)) 979 | (begin* 980 | (define-values (,x) '5) 981 | (#%expression 982 | (#%plain-lambda (,y) 983 | (free () (,x) 984 | (#%plain-lambda (,z) 985 | (free (,y) (,x) 986 | (#%plain-app 987 | (primitive +) 988 | (#%top . ,x) ,y ,z))))))))) 989 | (check-compiler-equal? 990 | (current-compile #'(begin 991 | (define x 5) 992 | (let ([y 6]) 993 | (set! x (+ x 1)) 994 | (set! y (+ y 1)) 995 | (+ x y)))) 996 | `(program (prefix (,x)) 997 | (begin* 998 | (define-values (,x) '5) 999 | (let ([,y '6]) 1000 | (begin 1001 | (set!-values (,y) (#%box ,y)) 1002 | (begin 1003 | (set!-global ,x (#%plain-app (primitive +) (#%top . ,x) '1)) 1004 | (set!-boxes (,y) (#%plain-app (primitive +) (#%unbox ,y) '1)) 1005 | (#%plain-app (primitive +) (#%top . ,x) (#%unbox ,y)))))))) 1006 | (check-compiler-equal? 1007 | (current-compile #'(begin (define x contract-continuation-mark-key) 1008 | x)) 1009 | `(program (prefix (,ccmk ,x)) 1010 | (begin* 1011 | (define-values (,x) (#%top . ,ccmk)) 1012 | (#%top . ,x)))) 1013 | (check-compiler-equal? 1014 | (current-compile #'(module foo racket 1015 | (#%plain-module-begin 1016 | (random)))) 1017 | `(program (prefix ()) 1018 | (module foo racket (prefix (,r)) 1019 | () () () 1020 | ((#%plain-app (#%top . ,r))) 1021 | () () ())))))) 1022 | 1023 | ;; =================================================================================================== 1024 | 1025 | 1026 | (module+ test 1027 | (update-current-compile!) 1028 | (block 1029 | (define x (make-variable 'x)) 1030 | (define f (make-variable 'f)) 1031 | (define g (make-variable 'g)) 1032 | (define-compiler-test Lclosurify compilation-top 1033 | (check-compiler-equal? 1034 | (current-compile #'(letrec ([f (lambda (x) x)]) 1035 | (f 12))) 1036 | `(program (prefix ()) '12)) 1037 | (check-compiler-equal? 1038 | (current-compile #'(letrec ([f (lambda (x) x)]) 1039 | (f f 12))) 1040 | `(program (prefix ()) 1041 | (let ([,f (closure ,f (#%plain-lambda (,x) (free () () ,x)))]) 1042 | (#%plain-app 1043 | (#%plain-lambda (,x) (free (,f) () ,f)) 1044 | ,f '12)))) 1045 | (check-compiler-equal? 1046 | (current-compile #'(letrec ([f (lambda () (g))] 1047 | [g (lambda () (f))]) 1048 | (f))) 1049 | `(program (prefix ()) 1050 | (letrec ([,f (#%plain-lambda () (free (,f) () (#%plain-app ,f)))]) 1051 | (#%plain-app ,f)))) 1052 | (check-compiler-equal? 1053 | (current-compile #'(letrec ([f (lambda (x) x)]) 1054 | (f f))) 1055 | `(program (prefix ()) 1056 | (let ([,f (closure ,f (#%plain-lambda (,x) (free () () ,x)))]) 1057 | ,f)))))) 1058 | 1059 | ;; =================================================================================================== 1060 | 1061 | (module+ test 1062 | (update-current-compile!) 1063 | (block 1064 | (define x (make-variable 'x)) 1065 | (define y (make-variable 'y)) 1066 | (define z (make-variable 'z)) 1067 | (define-compiler-test Lvoidlets compilation-top 1068 | (check-compiler-equal? 1069 | (current-compile #'(let ([x 1]) x)) 1070 | `(program (prefix ()) '1)) 1071 | (check-compiler-equal? 1072 | (current-compile #'(let ([x 1] 1073 | [y 2]) 1074 | (+ x y))) 1075 | `(program (prefix ()) '3)) 1076 | (check-compiler-equal? 1077 | (current-compile #'(let-values ([(x y) (values 1 2)] 1078 | [(z) 3]) 1079 | (set! x 5) 1080 | (+ x y z))) 1081 | `(program (prefix ()) 1082 | (let-void (,x ,y ,z) 1083 | (begin 1084 | (set!-values (,x ,y) (#%plain-app (primitive values) '1 '2)) 1085 | (set!-values (,z) '3) 1086 | (begin 1087 | (set!-values (,x) (#%box ,x)) 1088 | (begin 1089 | (set!-boxes (,x) '5) 1090 | (#%plain-app (primitive +) (#%unbox ,x) ,y ,z))))))) 1091 | (check-compiler-equal? 1092 | (current-compile #'(let ([x 5]) 1093 | (lambda (y) 1094 | (set! x 6) 1095 | (+ x y)))) 1096 | `(program (prefix ()) 1097 | (let ([,x '5]) 1098 | (begin 1099 | (set!-values (,x) (#%box ,x)) 1100 | (#%plain-lambda (,y) 1101 | (free (,x) () 1102 | (begin 1103 | (set!-boxes (,x) '6) 1104 | (#%plain-app (primitive +) 1105 | (#%unbox ,x) ,y))))))))))) 1106 | 1107 | ;; =================================================================================================== 1108 | 1109 | (module+ test 1110 | (update-current-compile!) 1111 | (block 1112 | (define x (make-variable 'x)) 1113 | (define y (make-variable 'y)) 1114 | (define z (make-variable 'z)) 1115 | (define-compiler-test Lscrubsyntax compilation-top 1116 | (check-compiler-equal? 1117 | (current-compile #'(syntax->datum #'(+ 1 2))) 1118 | `(program (prefix () (0)) 1119 | (,#'(+ 1 2)) 1120 | (#%plain-app (primitive syntax->datum) (quote-syntax 0)))) 1121 | (check-compiler-equal? 1122 | (current-compile #'(let ([x (quote-syntax (+ 1 2))]) 1123 | (let ([y (quote-syntax (+ 3 4) #:local)]) 1124 | (list (syntax->datum x) (syntax->datum y))))) 1125 | `(program (prefix () (0 1)) 1126 | (,#'(+ 1 2) ,#'(+ 3 4)) 1127 | (let ([,x (quote-syntax 0)]) 1128 | (let ([,y (quote-syntax 1)]) 1129 | (#%plain-app (primitive list) 1130 | (#%plain-app (primitive syntax->datum) ,x) 1131 | (#%plain-app (primitive syntax->datum) ,y))))))))) 1132 | 1133 | ;; =================================================================================================== 1134 | 1135 | (module+ test 1136 | (update-current-compile!)) 1137 | 1138 | ;; =================================================================================================== 1139 | 1140 | (module+ test 1141 | (update-current-compile!) 1142 | (block 1143 | (define x* (make-variable 'x)) 1144 | (define-compiler-test Ldebruijn compilation-top 1145 | (check-compiler-equal? 1146 | (current-compile #'(lambda (x) x)) 1147 | `(program (prefix () ()) (#%expression (#%plain-lambda 1 #f () () 0)))) 1148 | (check-compiler-equal? 1149 | (current-compile #'(let ([x 5]) 1150 | (lambda (y . z) x))) 1151 | `(program (prefix () ()) (#%plain-lambda 2 #t () () '5))) 1152 | (check-compiler-equal? 1153 | (current-compile #'(let ([x 5] 1154 | [y 6]) 1155 | (+ x y))) 1156 | `(program (prefix () ()) '11)) 1157 | (check-compiler-equal? 1158 | (current-compile #'(begin 1159 | (define x 5) 1160 | (+ x 5))) 1161 | `(program (prefix (,x*) ()) 1162 | (begin* 1163 | (define-values (0) '5) 1164 | (#%plain-app (primitive ,(dict-ref primitive-table* '+)) (#%top 2 0) '5)))) 1165 | (check-compiler-equal? 1166 | (current-compile #'(begin 1167 | (define x 5) 1168 | (lambda (y) 1169 | y x))) 1170 | `(program (prefix (,x*) ()) 1171 | (begin* 1172 | (define-values (0) '5) 1173 | (#%expression 1174 | (#%plain-lambda 1 #f (0) (0) 1175 | (#%top 0 0)))))) 1176 | ;; TODO 1177 | #;(check-equal? 1178 | (current-compile #'(begin 1179 | (module foo racket 1180 | (#%plain-module-begin 1181 | (provide x) 1182 | (define x 12))) 1183 | (require 'foo) 1184 | x)) 1185 | `(program (,x*) (begin* 1186 | (module foo racket (,x*) () 1187 | (,x*) () () 1188 | ((#%plain-app (primitive 35)) 1189 | (define-values (0) '12)) 1190 | () 1191 | () ()) 1192 | (#%require (for-meta 0 (quote* foo))) 1193 | (#%top 0 0))))))) 1194 | 1195 | ;; =================================================================================================== 1196 | 1197 | (module+ test 1198 | (update-current-compile!) 1199 | (define-compiler-test Lfindletdepth compilation-top 1200 | (check-compiler-equal? 1201 | (current-compile #'(lambda (x) (let ([y 5]) (+ x y)))) 1202 | `(program (prefix () () 1) 1203 | (#%expression 1204 | (#%plain-lambda 1 #f () () 9 1205 | (#%plain-app 1206 | (primitive ,(dict-ref primitive-table* '+)) 1207 | 2 '5))))) 1208 | (check-compiler-equal? 1209 | (current-compile #'(if (= 5 6) 1210 | (let ([x '5] 1211 | [y '6]) 1212 | y) 1213 | (let ([x '6]) 1214 | x))) 1215 | `(program (prefix () () 1) '6)))) 1216 | 1217 | ;; =================================================================================================== 1218 | 1219 | (module+ test 1220 | (update-current-compile!)) 1221 | 1222 | ;; =================================================================================================== 1223 | 1224 | (module+ test 1225 | (parameterize ([current-environment-variables 1226 | (environment-variables-copy (current-environment-variables))]) 1227 | (putenv "PLT_VALIDATE_COMPILE" "true") 1228 | (set! all-compiler-tests 1229 | (cons 1230 | (test-suite 1231 | "Tests for finished compiler" 1232 | (compile-compare #'42) 1233 | (compile-compare #'(if #t 5 6)) 1234 | (compile-compare #'((lambda (x) x) 42)) 1235 | (compile-compare #'((lambda (x) (+ x 5)) 84)) 1236 | (compile-compare #'(((lambda (x) (lambda (y) (+ x y))) 2) 3)) 1237 | ;; TODO this test 1238 | ;(compile-compare #'((lambda x (car x)) '(84 91 514))) 1239 | (compile-compare #'(let ([x (lambda () 42)]) 1240 | (x))) 1241 | (compile-compare #'(let ([x 5]) 1242 | (set! x 6) 1243 | x)) 1244 | (compile-compare #'(letrec ([f (lambda (x) x)]) 1245 | (f 12))) 1246 | ;; TODO This test 1247 | #;(compile-compare #'(letrec ([fact (lambda (x) 1248 | (if (x . <= . 0) 1249 | 1 1250 | (* x (fact (- x 1)))))]) 1251 | (fact 5))) 1252 | (compile-compare #'(with-continuation-mark 'hello 'world 1253 | (continuation-mark-set->list 1254 | (current-continuation-marks) 'hello))) 1255 | (compile-compare #'(if (= 4 4) 1256 | (begin 1257 | 1 ;; (random 1) TODO 1258 | 4) 1259 | 3)) 1260 | (compile-compare #'(let ([+ 12]) 1261 | (- + 8))) 1262 | (compile-compare #'(begin0 12 42 (+ 3 8))) 1263 | (compile-compare #'(begin 1264 | (define x 5) 1265 | x)) 1266 | (compile-compare #'(begin 1267 | (define x 5) 1268 | (set! x 6) 1269 | x)) 1270 | (compile-compare #'(begin 1271 | (define x 5) 1272 | (let ([b (lambda (y) (+ x y))]) 1273 | (b 12)))) 1274 | (compile-compare #'(begin 1275 | (define x 5) 1276 | ((lambda (y) 1277 | ((lambda (z) 1278 | (+ x y z)) 4)) 5))) 1279 | (compile-compare #'(begin 1280 | (define x 5) 1281 | (((let ([a (lambda (y) 1282 | (let ([b (lambda (z) 1283 | (+ x y z))]) 1284 | b))]) 1285 | a) 3) 4))) 1286 | (compile-compare #'(begin 1287 | (define x 5) 1288 | (let ([y 6]) 1289 | (set! x (+ x 1)) 1290 | (set! y (+ y 1)) 1291 | (+ x y)))) 1292 | (compile-compare #'(eval '(+ 1 2) 1293 | (variable-reference->namespace 1294 | (#%variable-reference)))) 1295 | (compile-compare #'(begin 1296 | (define x 48) 1297 | (let ([x 6]) 1298 | (#%top . x)))) 1299 | (compile-compare #'(call-with-current-continuation (lambda (x) 12))) 1300 | (compile-compare #'(syntax->datum #'(+ 1 2))) 1301 | (compile-compare #'(eval #'(+ 1 2))) 1302 | (compile-compare #'(parameterize ([current-namespace (make-base-namespace)]) 1303 | (eval '(+ 1 2)))) 1304 | ;(check-equal? (eval (compile #'(dict-ref (hash 1 2) 1))) 2) 1305 | (compile-compare #'(module foo racket 1306 | (#%plain-module-begin 1307 | (+ 1 2)))) 1308 | (compile-compare 1309 | #'(define-syntax defvar 1310 | (syntax-rules () 1311 | [(_ name val) 1312 | (namespace-variable-value 'name #f)]))) 1313 | (compile-compare 1314 | #'(begin 1315 | (module foo racket 1316 | (#%plain-module-begin 1317 | (random))) 1318 | (module bar racket 1319 | (#%plain-module-begin 1320 | (random))))) 1321 | (compile-compare #'(begin 1322 | (module foo racket 1323 | (#%plain-module-begin 1324 | (provide x) 1325 | (define x 481))) 1326 | (require 'foo) 1327 | x))) 1328 | all-compiler-tests)))) 1329 | 1330 | ;; =================================================================================================== 1331 | 1332 | (module+ test 1333 | (run-all-compiler-tests)) 1334 | -------------------------------------------------------------------------------- /private/utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (protect-out (all-defined-out))) 4 | 5 | (require nanopass/base 6 | racket/match 7 | racket/set 8 | racket/dict 9 | racket/struct 10 | racket/port 11 | racket/function 12 | racket/contract 13 | rackunit 14 | compiler/zo-parse 15 | syntax/modresolve 16 | syntax/toplevel 17 | syntax/strip-context) 18 | 19 | (require/expose compiler/decompile (primitive-table)) 20 | 21 | ; Pointer to a primitive module 22 | ; For use in primitive-identifier? and primitive->symbol 23 | (define primitive-module 24 | (car (identifier-binding #'+))) 25 | 26 | ; Determines if an identifier is a primitive. 27 | ; Identifier -> Boolean 28 | (define (primitive-identifier? identifier) 29 | (define binding (identifier-binding identifier)) 30 | (and (list? binding) (eq? (car binding) primitive-module))) 31 | 32 | ; Converts a primitive into one in Racket's primitive table 33 | ; Identifier -> Symbol 34 | (define (primitive->symbol identifier) 35 | (define binding (identifier-binding identifier)) 36 | (cadr binding)) 37 | 38 | (define primitive-table* 39 | (for/hash ([(k v) (in-hash primitive-table)]) 40 | (values v k))) 41 | 42 | (define (maybe-module-path? m) 43 | (or (module-path? m) (not m))) 44 | 45 | (define (phase-level? pl) 46 | (or (exact-integer? pl) (not pl))) 47 | 48 | (define (declaration-keyword? dk) 49 | #t) 50 | 51 | (define (datum? d) 52 | (not (syntax? d))) 53 | 54 | (define name? any/c) 55 | 56 | ; Represents a variable expression. 57 | ; One variable is bound to another if their bindings point point to the same location in memory 58 | ; Variables are not assigned or referenced by default, a pass changes that if it occurs 59 | (struct variable (name 60 | operand 61 | srcloc 62 | binding 63 | properties) 64 | #:mutable 65 | #:methods gen:custom-write 66 | [(define (write-proc data port mode) 67 | ((current-variable-printer) data port mode))] 68 | #:methods gen:equal+hash 69 | [(define (equal-proc a b t) (eq? (variable-binding a) (variable-binding b))) 70 | (define (hash-proc v t) (eq-hash-code (variable-binding v))) 71 | (define (hash2-proc v t) (eq-hash-code (variable-binding v)))]) 72 | (define (make-variable name 73 | #:operand [operand #f] 74 | #:properties [properties (make-hash)] 75 | #:source-location [srcloc #f] 76 | #:binding [binding (make-binding)]) 77 | (variable name operand srcloc binding properties)) 78 | 79 | (define debug-variable-printer 80 | (make-constructor-style-printer 81 | (lambda (obj) 'variable) 82 | (lambda (obj) (list (variable-name obj) 83 | (variable-operand obj) 84 | (variable-properties obj) 85 | (variable-binding obj))))) 86 | 87 | (define current-variable-printer 88 | (make-parameter 89 | (make-constructor-style-printer 90 | (lambda (obj) 'variable) 91 | (lambda (obj) (list (variable-name obj)))))) 92 | 93 | ; Binding object, ensures that two variables are equal. 94 | (struct binding (properties 95 | assigned? 96 | referenced? 97 | toplevel?) 98 | #:mutable 99 | #:methods gen:custom-write 100 | [(define (write-proc data port mode) 101 | ((current-binding-printer) data port mode))]) 102 | (define (make-binding #:properties [properties (make-hash)] 103 | #:assigned? [assigned? #f] 104 | #:referenced? [referenced? #f] 105 | #:top-level? [top-level? #f]) 106 | (binding properties assigned? referenced? top-level?)) 107 | 108 | (define current-binding-printer 109 | (make-parameter 110 | (make-constructor-style-printer 111 | (lambda (obj) 'binding) 112 | (lambda (obj) (list (binding-properties obj) 113 | (binding-assigned? obj) 114 | (binding-referenced? obj)))))) 115 | 116 | ; Extenion of binding, stores module level information 117 | ; Similar to results returned from `identifier-binding` function 118 | (struct module-binding binding (source-mod 119 | source-id 120 | nominal-source-mod 121 | nominal-source-id 122 | source-phase 123 | import-phase 124 | nominal-export-phase) 125 | #:mutable 126 | #:methods gen:custom-write 127 | [(define (write-proc data port mode) 128 | ((current-module-binding-printer) data port mode))]) 129 | (define (make-module-binding source-mod 130 | source-id 131 | nominal-source-mod 132 | nominal-source-id 133 | source-phase 134 | import-phase 135 | nominal-export-phase 136 | #:properties [properties (make-hash)] 137 | #:assigned? [assigned? #f] 138 | #:referenced? [referenced? #f]) 139 | (module-binding properties 140 | assigned? 141 | referenced? 142 | source-mod 143 | source-id 144 | nominal-source-mod 145 | nominal-source-id 146 | source-phase 147 | import-phase 148 | nominal-export-phase)) 149 | 150 | (define current-module-binding-printer 151 | (make-parameter (current-binding-printer))) 152 | 153 | (define module-binding-printer 154 | (make-constructor-style-printer 155 | (lambda (obj) 'module-binding) 156 | (lambda (obj) (list (binding-properties obj) 157 | (binding-assigned? obj) 158 | (binding-referenced? obj) 159 | (module-binding-source-mod obj) 160 | (module-binding-source-id obj) 161 | (module-binding-nominal-source-mod obj) 162 | (module-binding-nominal-source-id obj) 163 | (module-binding-source-phase obj) 164 | (module-binding-import-phase obj) 165 | (module-binding-nominal-export-phase obj))))) 166 | 167 | 168 | (define current-outer-pending-default-fuel (make-parameter 1)) 169 | 170 | (struct operand (exp 171 | env 172 | effort-counter 173 | value 174 | residualized-for-effect? 175 | size 176 | inner-pending? 177 | outer-pending) 178 | #:mutable) 179 | (define (make-operand exp env effort-counter 180 | #:value [value #f] 181 | #:residualized-for-effect? [residualized-for-effect? #f] 182 | #:size [size 0] 183 | #:inner-pending? [inner-pending? #f] 184 | #:outer-pending [outer-pending (current-outer-pending-default-fuel)]) 185 | (operand exp env effort-counter value residualized-for-effect? size inner-pending? outer-pending)) 186 | 187 | ; Grabs set of identifiers out of formals non-terminal in a language 188 | ; lang formals -> (listof identifiers) 189 | (define-syntax-rule (formals->identifiers lang fmls) 190 | (nanopass-case (lang formals) fmls 191 | [,v (list v)] 192 | [(,v (... ...)) v] 193 | [(,v ,v* (... ...) . ,v2) (set-union (list v v2) v*)])) 194 | 195 | ; lang formals -> boolean 196 | (define-syntax-rule (formals-rest? lang fmls) 197 | (nanopass-case (lang formals) fmls 198 | [,v #t] 199 | [(,v (... ...)) #f] 200 | [(,v ,v* (... ...) . ,v2) #t])) 201 | 202 | (define-syntax-rule (compiler-value? lang exp) 203 | (nanopass-case (lang top-level-form) exp 204 | [(quote ,datum) #t] 205 | [else #f])) 206 | -------------------------------------------------------------------------------- /scribblings/compiler2.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @require[@for-label[@only-in[compiler2 compile] 4 | @except-in[racket/base compile]]] 5 | 6 | @title{compiler2} 7 | @author{leif} 8 | 9 | @defmodule[compiler2] 10 | 11 | This is an unstable package for a variant of the Racket compiler written in 12 | Racket using Nanopass. 13 | It is not currently stable enough for most uses. 14 | 15 | @defproc[(compile [stx syntax?]) compilation-top?]{ 16 | The replacement compiler. Note that to use it, you must make sure to set 17 | @racket[current-compile] to be this compiler. 18 | } 19 | --------------------------------------------------------------------------------