├── .gitignore ├── NOTES ├── README.md └── src ├── extended-eval.rkt ├── fact.rkt ├── priminfo.rkt ├── prims.rkt └── spike.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | .*.sw? 2 | .sw? 3 | -------------------------------------------------------------------------------- /NOTES: -------------------------------------------------------------------------------- 1 | Structure of the Racket virtual machine model: 2 | 3 | 5 "registers" for the machine 4 | 5 | V - the most recent evaluated value 6 | S - the machine stack (it is a stack machine so all variables are stored and referenced here) 7 | H - the machine heap (this is where all the boxed data and closures go) 8 | T - text segment with the bodies of program segments and bytecode cycles 9 | C - command register, set of instructions to be run, this gets reloaded from the text segment) 10 | 11 | The commands are: 12 | 13 | i --> e 14 | | (swap n) 15 | | (reorder i (e m) ...) 16 | | (set n) 17 | | (set-box n) 18 | | (branch e e) 19 | | framepop 20 | | framepush 21 | | (call n) 22 | | (self-call x) 23 | 24 | where e is 25 | 26 | e --> (loc n) 27 | | (loc-noclr n) 28 | | (loc-clr n) 29 | | (loc-box n) 30 | | (loc-box-noclr n) 31 | | (loc-box-clr n) 32 | | (let-one e e) 33 | | (let-void n e) 34 | | (let-void-box n e) 35 | | (boxenv n e) 36 | | (install-value n e e) 37 | | (install-value-box n e e) 38 | | (application e e ...) 39 | | (seq e e e ...) 40 | | (branch e e e) 41 | | (let-rec (l ...) e) 42 | | (indirect x) 43 | | (proc-const (t ...) e) 44 | | (case-lam l ...) 45 | | l 46 | | v 47 | | (self-app x e_0 e_1 ...) 48 | | (primval ---) 49 | 50 | and l is 51 | 52 | l --> (lam n (n ...) x) 53 | 54 | and v is 55 | 56 | v --> number 57 | void 58 | 'variable 59 | b 60 | undefined 61 | (clos x) 62 | 63 | Ideas for abstracting this: 64 | 65 | 1. Follow the abstracting abstract machines approach, but apply it directly to 66 | the abstract machine that describes Racket. This is the approach Kimball is 67 | taking (it was my first thought too, but Matt seems to think it is a step a 68 | little too far off of the main abstracting abstract machines path). 69 | 70 | 2. Try to encode the byte code into a CESK machine and then follow the 71 | abstracting abstract machines approach. 72 | 73 | In doing #2: The value register is a bit of a strange artifact of the stack 74 | machine, maybe try to see if anyone has already converted a stack machine into 75 | a CESK machine. 76 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Abstract Machine for Racket Bytecode 2 | ===================================== 3 | 4 | This repository is a first pass at an abstract machine implementation for analyzing Racket bytecode. The current implemnetation is a concrete CESK machine that implements a subset of the Racket bytecode. (Basically, primitives, plus the core evaluation forms.) 5 | 6 | Usage 7 | ------ 8 | 9 | The main source file for the CESK machine is the `extended-eval.rkt` file, which can be loaded into Racket REPL as: 10 | 11 | ```racket 12 | (require "extended-eval.rkt") 13 | ``` 14 | 15 | The `cesk` procedure implements the CESK evaluator. The evaluator expects a transformed version of the byte code that can be produced by passing the quoted expression you wish to evaluate to `racket-source->anormal-form`. For instance, if we wanted to run the classic factorial of 5 program would could evaluate it as follows: 16 | 17 | ```racket 18 | (cesk 19 | (racket-source->anormal-form 20 | '(letrec ([factorial 21 | (lambda (n) 22 | (if (zero? n) 23 | 1 24 | (* n (factorial (- n 1)))))]) 25 | (factorial 5)))) 26 | ``` 27 | 28 | -------------------------------------------------------------------------------- /src/extended-eval.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require compiler/compiler 4 | compiler/zo-parse 5 | compiler/zo-marshal 6 | "priminfo.rkt") 7 | 8 | (define (compile-bytecode expr) 9 | (let ([tmp (make-temporary-file)]) 10 | (call-with-output-file tmp #:exists 'truncate 11 | (λ (p) 12 | (parameterize ([current-namespace (make-base-namespace)]) 13 | (write (compile expr) p)))) 14 | (begin0 15 | (call-with-input-file tmp zo-parse) 16 | (delete-file tmp)))) 17 | 18 | (define ip->bytecode 19 | (lambda (ip) 20 | (zo-parse ip))) 21 | 22 | (define zo-file->bytecode 23 | (lambda (fn) 24 | (call-with-input-file fn ip->bytecode))) 25 | 26 | (define source-file->bytecode 27 | (let ([compile-file (let ([compile-files (compile-zos #f)]) 28 | (lambda (fn dir) 29 | (compile-files (list fn) dir)))]) 30 | (lambda (fn) 31 | (let ([dir (make-temporary-file "rkt-compile-tmp-~a" 'directory)]) 32 | (parameterize ([current-namespace (make-base-namespace)] 33 | [compile-context-preservation-enabled #t]) 34 | (compile-file fn dir)) 35 | (zo-file->bytecode 36 | (path-replace-suffix (path->complete-path fn dir) "_rkt.zo")))))) 37 | 38 | (define source->bytecode 39 | (lambda (expr) 40 | (ip->bytecode 41 | (let ([out (open-output-bytes)]) 42 | (parameterize ([current-namespace (make-base-namespace)] 43 | [compile-context-preservation-enabled #t]) 44 | (write (compile expr) out)) 45 | (close-output-port out) 46 | (open-input-bytes (get-output-bytes out)))))) 47 | 48 | ;; 49 | ;; output grammar: 50 | ;; Prog --> `(, , ...) 51 | ;; Expr --> (loc ) 52 | ;; | (loc-clr ) 53 | ;; | (loc-noclr ) 54 | ;; | (loc-box ) 55 | ;; | (loc-box-clr ) 56 | ;; | (loc-box-noclr ) 57 | ;; | (let-one ) 58 | ;; | (let-void ) 59 | ;; | (let-void-box ) 60 | ;; | (install-value ) 61 | ;; | (install-value-box ) 62 | ;; | (boxenv ) 63 | ;; | (application ...) 64 | ;; | (seq ...) 65 | ;; | (branch ) 66 | ;; | (let-rec ... ) 67 | ;; | (lam ( ...) ( ...) ) 68 | ;; | (proc-const ( ...) ) 69 | ;; | (indirect ) 70 | ;; | (case-lam ) 71 | ;; | (constant ) 72 | ;; | (quote ) ;; maybe a variable reference? 73 | ;; | (primval ) 74 | ;; TextSegPart --> ( ) 75 | ;; 76 | (define (impl->model expr) 77 | (define cycled (cycle-points expr)) 78 | (define text-addr (make-hasheq)) 79 | (define next-loc 80 | (let ([suffix 0]) 81 | (λ () 82 | (set! suffix (add1 suffix)) 83 | (string->symbol (format "x~s" suffix))))) 84 | (define text-seg '()) 85 | (cons 86 | (let recur ([e expr]) 87 | (match e 88 | [(compilation-top _ _ e) (recur e)] 89 | [(localref #f n #f #t #f) `(loc ,n)] 90 | [(localref #f n #t _ #f) `(loc-clr ,n)] 91 | [(localref #f n #f #f #f) `(loc-noclr ,n)] 92 | [(localref #t n #f #t #f) `(loc-box ,n)] 93 | [(localref #t n #t _ #f) `(loc-box-clr ,n)] 94 | [(localref #t n #f #f #f) `(loc-box-noclr ,n)] 95 | [(let-one r b #f #f) `(let-one ,(recur r) ,(recur b))] 96 | [(let-void n #f b) `(let-void ,n ,(recur b))] 97 | [(let-void n #t b) `(let-void-box ,n ,(recur b))] 98 | [(install-value 1 n #f r b) `(install-value ,n ,(recur r) ,(recur b))] 99 | [(install-value 1 n #t r b) 100 | `(install-value-box ,n ,(recur r) ,(recur b))] 101 | [(boxenv n b) `(boxenv ,n ,(recur b))] 102 | [(application f as) `(application ,(recur f) ,@(map recur as))] 103 | [(seq es) `(seq ,@(map recur es))] 104 | [(branch c t e) `(branch ,(recur c) ,(recur t) ,(recur e))] 105 | [(let-rec rs b) `(let-rec ,@(map recur rs) ,(recur b))] 106 | [(lam _ _ _ τs #f ns `(val/ref ...) _ _ b) 107 | `(lam ,τs ,(vector->list ns) ,(recur b))] 108 | [(closure l _) 109 | (define (model-rep) 110 | (match-let ([`(lam ,τs () ,b) (recur l)]) 111 | `(proc-const ,τs ,b))) 112 | (if (hash-ref cycled e #f) 113 | `(indirect ,(let ([x (hash-ref text-addr e #f)]) 114 | (or x 115 | (let ([x (next-loc)]) 116 | (hash-set! text-addr e x) 117 | (set! text-seg (cons (list x (model-rep)) text-seg)) 118 | x)))) 119 | (model-rep))] 120 | [(case-lam _ ls) `(case-lam ,@(map recur ls))] 121 | [(? void?) `(constant ,(void))] 122 | [(? number?) `(constant ,e)] 123 | [(? boolean?) `(constant ,e)] 124 | [(? symbol?) `',e] ;; I think this corresponds to a variable reference (not sure) 125 | ;; "extended" cases 126 | [(primval n) `(primval ,(lookup-primitive n))] 127 | [_ (error 'impl->model "unrecognized form ~s" e)])) 128 | text-seg)) 129 | 130 | (define (cycle-points expr) 131 | (define seen (make-hasheq)) 132 | (let recur ([e expr]) 133 | (when (zo? e) ; i.e., not a literal 134 | (if (hash-ref seen e #f) 135 | (unless (closure? e) 136 | (error 'cycle-refs "illegal cycle through ~s" e)) 137 | (begin 138 | (hash-set! seen e #t) 139 | (match e 140 | [(compilation-top _ _ e) 141 | (recur e)] 142 | [(localref _ _ _ _ _) 143 | (void)] 144 | [(let-one r b _ _) 145 | (recur r) 146 | (recur b)] 147 | [(let-void _ _ b) 148 | (recur b)] 149 | [(install-value _ _ _ r b) 150 | (recur r) 151 | (recur b)] 152 | [(boxenv _ b) 153 | (recur b)] 154 | [(application f as) 155 | (recur f) 156 | (for-each recur as)] 157 | [(seq es) 158 | (for-each recur es)] 159 | [(branch c t e) 160 | (recur c) 161 | (recur t) 162 | (recur e)] 163 | [(let-rec rs b) 164 | (for-each recur rs) 165 | (recur b)] 166 | [(lam _ _ _ _ _ _ _ _ _ b) 167 | (recur b)] 168 | [(closure l _) 169 | (recur l)] 170 | [(case-lam _ ls) 171 | (for-each recur ls)] 172 | [_ (void)]))))) 173 | seen) 174 | 175 | ;; 176 | ;; input grammar: 177 | ;; Prog --> `(, , ...) 178 | ;; Expr --> (loc ) 179 | ;; | (loc-clr ) 180 | ;; | (loc-noclr ) 181 | ;; | (loc-box ) 182 | ;; | (loc-box-clr ) 183 | ;; | (loc-box-noclr ) 184 | ;; | (let-one ) 185 | ;; | (let-void ) 186 | ;; | (let-void-box ) 187 | ;; | (install-value ) 188 | ;; | (install-value-box ) 189 | ;; | (boxenv ) 190 | ;; | (application ...) 191 | ;; | (seq ...) 192 | ;; | (branch ) 193 | ;; | (let-rec ... ) 194 | ;; | (lam ( ...) ( ...) ) 195 | ;; | (proc-const ( ...) ) 196 | ;; | (indirect ) 197 | ;; | (case-lam ...) 198 | ;; | (constant ) 199 | ;; | (quote ) ;; maybe a variable reference? 200 | ;; | (primval ) 201 | ;; TextSegPart --> ( ) 202 | ;; 203 | ;; ---- 204 | ;; output grammar: 205 | ;; Prog --> (prog ([ ] ...) ) 206 | ;; TextSeg (removed) 207 | ;; Expr (unchanged) 208 | (define (model->prog pair) `(prog ,(cdr pair) ,(car pair))) 209 | 210 | (define-syntax rec 211 | (syntax-rules () 212 | [(_ id expr) (letrec ([id expr]) id)])) 213 | 214 | (define-syntax trace-define 215 | (syntax-rules () 216 | [(_ (name . args) body0 body1 ...) 217 | (define name 218 | (let ([depth 0]) 219 | (lambda targs 220 | (set! depth (+ depth 1)) 221 | (let loop ([n depth]) (unless (zero? n) (display #\|) (loop (- n 1)))) 222 | (pretty-print (cons 'name targs)) 223 | (call-with-values 224 | (lambda () (apply (lambda args body0 body1 ...) targs)) 225 | (lambda targs 226 | (set! depth (- depth 1)) 227 | (let loop ([n depth]) (unless (zero? n) (display #\|) (loop (- n 1)))) 228 | (if (= (length targs) 1) (pretty-print (car targs)) (pretty-print (cons 'values targs))) 229 | (apply values targs))))))] 230 | [(_ name lexpr) 231 | (define name 232 | (let ([depth 0]) 233 | (lambda args 234 | (set! depth (+ depth 1)) 235 | (let loop ([n depth]) (unless (zero? n) (write #\|) (loop (- n 1)))) 236 | (pretty-print (cons 'name args)) 237 | (call-with-values 238 | (lambda () (apply lexpr args)) 239 | (lambda args 240 | (set! depth (- depth 1)) 241 | (let loop ([n depth]) (unless (zero? n) (write #\|) (loop (- n 1)))) 242 | (if (= (length args) 1) (pretty-print (car args)) (pretty-print (cons 'values args))) 243 | (apply values args))))))])) 244 | 245 | (define next-symbol 246 | (let ([n 0]) 247 | (lambda () 248 | (begin0 249 | (string->symbol (string-append "t." (number->string n))) 250 | (set! n (+ n 1)))))) 251 | 252 | ;; 253 | ;; input grammar: 254 | ;; Prog --> (prog ([ ] ...) ) 255 | ;; Expr --> (loc ) 256 | ;; | (loc-clr ) 257 | ;; | (loc-noclr ) 258 | ;; | (loc-box ) 259 | ;; | (loc-box-clr ) 260 | ;; | (loc-box-noclr ) 261 | ;; | (let-one ) 262 | ;; | (let-void ) 263 | ;; | (let-void-box ) 264 | ;; | (install-value ) 265 | ;; | (install-value-box ) 266 | ;; | (boxenv ) 267 | ;; | (application ...) 268 | ;; | (seq ...) 269 | ;; | (branch ) 270 | ;; | (let-rec ... ) 271 | ;; | (lam ( ...) ( ...) ) 272 | ;; | (proc-const ( ...) ) 273 | ;; | (indirect ) 274 | ;; | (case-lam ...) 275 | ;; | (constant ) 276 | ;; | (quote ) ;; maybe a variable reference? 277 | ;; | (primval ) 278 | ;; 279 | ;; ----- 280 | ;; output grammar: 281 | ;; Prog --> (prog ([ ] ...) ) 282 | ;; Expr --> (ref ) 283 | ;; | (boxref ) 284 | ;; | (let ([ ] ...) ) 285 | ;; | (set! ) 286 | ;; | (set-box! ) 287 | ;; | (boxenv ) 288 | ;; | (application ...) 289 | ;; | (seq ...) 290 | ;; | (let-rec ([ ]) ) 291 | ;; | (lam (( : ) ...) ) 292 | ;; | (case-lam ...) 293 | ;; | (constant ) 294 | ;; | (quote ) 295 | ;; | (primval ) 296 | ;; 297 | (define (reintroduce-variables x) 298 | (define (next-symbol* n env) 299 | (for/fold ([ls '()] [env env]) ([n n]) 300 | (let ([x (next-symbol)]) (values (cons x ls) (cons x env))))) 301 | (define (Expr* env e*) 302 | (if (null? e*) '() (cons (Expr env (car e*)) (Expr* env (cdr e*))))) 303 | (define (Expr env x) 304 | (match x 305 | [`(loc ,n) `(ref normal ,(list-ref env n))] 306 | [`(loc-clr ,n) `(ref clr ,(list-ref env n))] 307 | [`(loc-noclr ,n) `(ref noclr ,(list-ref env n))] 308 | [`(loc-box ,n) `(boxref normal ,(list-ref env n))] 309 | [`(loc-box-clr ,n) `(boxref clr ,(list-ref env n))] 310 | [`(loc-box-noclr ,n) `(boxref noclr ,(list-ref env n))] 311 | [`(let-one ,e0 ,e1) 312 | (let ([x (next-symbol)]) 313 | `(let ([,x ,(Expr env e0)]) ,(Expr (cons x env) e1)))] 314 | [`(let-void ,n (let-rec ,e* ... ,e)) 315 | (let-values ([(x* env) (next-symbol* n env)]) 316 | (let ([e* (Expr* env e*)] [e (Expr env e)]) 317 | `(let-rec ,(map (lambda (x e) (list x e)) x* e*) ,e)))] 318 | [`(let-void ,n ,e) 319 | (let-values ([(x* env) (next-symbol* n env)]) 320 | `(let ,(map (lambda (x) (list x `(constant ,(void)))) x*) 321 | ,(Expr env e)))] 322 | [`(let-void-box ,n ,e) 323 | (let-values ([(x* env) (next-symbol* n env)]) 324 | `(let ,(map (lambda (x) (list x `(constant ,(void)))) x*) 325 | ,(let loop ([x* x*]) 326 | (if (null? x*) 327 | (Expr env e) 328 | `(seq (boxenv ,(car x*)) ,(loop (cdr x*)))))))] 329 | [`(install-value ,n ,e0 ,e1) 330 | `(seq (set! ,(list-ref env n) ,(Expr env e0)) ,(Expr env e1))] 331 | [`(install-value-box ,n ,e0 ,e1) 332 | `(seq (set-box! ,(list-ref env n) ,(Expr env e0)) ,(Expr env e1))] 333 | [`(boxenv ,n ,e) `(seq (boxenv ,(list-ref env n)) ,(Expr env e))] 334 | [`(application ,e ,e* ...) 335 | (let-values ([(rx* env) (next-symbol* e* env)]) 336 | `(application ,(Expr env e) ,@(Expr* env e*)))] 337 | [`(seq ,e* ...) `(seq ,@(Expr* env e*))] 338 | [`(branch ,e0 ,e1 ,e2) `(branch ,(Expr env e0) ,(Expr env e1) ,(Expr env e2))] 339 | [`(let-rec ,e* ... ,e) 340 | (if (null? e*) 341 | (Expr env e) 342 | (error 'reintroduce-variables 343 | "found let-rec outside of let-void ~s" x))] 344 | [`(lam (,ts* ...) (,n* ...) ,e) 345 | (let ([free-x* (map (lambda (n) (list-ref env n)) n*)]) 346 | (let-values ([(x* env) (next-symbol* ts* env)]) 347 | (let ([env (append free-x* env)]) 348 | `(lam 349 | ,(map (lambda (x ts) (list x ': ts)) x* ts*) 350 | ,(Expr env e)))))] 351 | [`(proc-const (,ts* ...) ,e) 352 | (let-values ([(x* env) (next-symbol* ts* env)]) 353 | `(lam ,(map (lambda (x ts) (list x ': ts)) x* ts*) ,(Expr env e)))] 354 | [`(indirect ,x) `(ref indirect ,x)] 355 | [`(case-lam ,e* ...) `(case-lam ,@(Expr* env e*))] 356 | [`(constant ,c) `(constant ,c)] 357 | [`(quote ,s) `(quote ,s)] 358 | [`(primval ,pr) `(primval ,pr)])) 359 | (define (Prog x) 360 | (match x 361 | [`(prog ([,x* ,e*] ...) ,e) 362 | (let ([e* (Expr* '() e*)] [e (Expr '() e)]) 363 | `(prog ,(map list x* e*) ,e))])) 364 | (Prog x)) 365 | 366 | ;; 367 | ;; input grammar: 368 | ;; Prog --> (prog ([ ] ...) ) 369 | ;; Expr --> (ref ) 370 | ;; | (boxref ) 371 | ;; | (let ([ ] ...) ) 372 | ;; | (set! ) 373 | ;; | (set-box! ) 374 | ;; | (boxenv ) 375 | ;; | (application ...) 376 | ;; | (seq ...) 377 | ;; | (let-rec ([ ] ...) ) 378 | ;; | (lam (( : ) ...) ) 379 | ;; | (case-lam ...) 380 | ;; | (constant ) 381 | ;; | (quote ) 382 | ;; | (primval ) 383 | ;; 384 | ;; ------ 385 | ;; output grammar: 386 | ;; Prog --> (prog ([ ] ...) ) 387 | ;; Lambda --> (lam (( : ) ...) ) 388 | ;; Expr --> 389 | ;; | (ref ) 390 | ;; | (boxref ) 391 | ;; | (let ([ ] ...) ) 392 | ;; | (set! ) 393 | ;; | (set-box! ) 394 | ;; | (boxenv ) 395 | ;; | (application ...) 396 | ;; | (seq ...) 397 | ;; | (let-rec ([ ] ...) ) 398 | ;; | (case-lam ...) 399 | ;; | (constant ) 400 | ;; | (quote ) 401 | ;; | (primval ) 402 | ;; 403 | (define (check-grammar x) 404 | (define (Expr! e) 405 | (match e 406 | [`(lam ((,x* : ,ts*) ...) ,e) (Expr! e)] 407 | [`(ref ,type ,x) (void)] 408 | [`(boxref ,type ,x) (void)] 409 | [`(let ([,x* ,e*] ...) ,e) (for-each Expr! e*) (Expr! e)] 410 | [`(set! ,x ,e) (Expr! e)] 411 | [`(set-box! ,x ,e) (Expr! e)] 412 | [`(boxenv ,x) (void)] 413 | [`(application ,e ,e* ...) (Expr! e) (for-each Expr! e*)] 414 | [`(seq ,e0 ,e1 ,e* ...) (Expr! e0) (Expr! e1) (for-each Expr! e*)] 415 | [`(branch ,e0 ,e1 ,e2) (Expr! e0) (Expr! e1) (Expr! e2)] 416 | [`(let-rec ([,x* ,le*] ...) ,e) (for-each Lambda! le*) (Expr! e)] 417 | [`(case-lam ,le* ...) (for-each Lambda! le*)] 418 | [`(constant ,c) (void)] 419 | [`(quote ,x) (void)] 420 | [`(primval ,prim) (void)] 421 | [_ (error 'check-grammar "unmatched language form ~s" e)])) 422 | (define (Lambda! le) 423 | (match le 424 | [`(lam ((,x* : ,ts*) ...) ,e) (Expr! e)] 425 | [_ (error 'check-grammar "invalid lambda expression ~s" le)])) 426 | (define (Prog! x) 427 | (match x 428 | [`(prog ([,x* ,le*] ...) ,e) (for-each Lambda! le*) (Expr! e)] 429 | [_ (error 'check-grammar "invalid program form ~s" x)])) 430 | (Prog! x) 431 | x) 432 | 433 | ;; 434 | ;; input grammar: 435 | ;; Prog --> (prog ([ ] ...) ) 436 | ;; Lambda --> (lam (( : ) ...) ) 437 | ;; Expr --> 438 | ;; | (ref ) 439 | ;; | (boxref ) 440 | ;; | (let ([ ] ...) ) 441 | ;; | (set! ) 442 | ;; | (set-box! ) 443 | ;; | (boxenv ) 444 | ;; | (application ...) 445 | ;; | (seq ...) 446 | ;; | (branch ) 447 | ;; | (let-rec ([ ] ...) ) 448 | ;; | (case-lam ...) 449 | ;; | (constant ) 450 | ;; | (quote ) 451 | ;; | (primval ) 452 | ;; 453 | ;; ------ 454 | ;; output grammar: 455 | ;; Lambda --> (lam (( : ) ...) ) 456 | ;; AExpr --> 457 | ;; | (case-lam ...) 458 | ;; | (boxref ) 459 | ;; | (constant ) 460 | ;; | (primval ) 461 | ;; | (primcall ...) 462 | ;; | (quote ) 463 | ;; CExpr --> (application ...) 464 | ;; | (branch ) 465 | ;; | (set! ) 466 | ;; | (set-box! ) 467 | ;; | (boxenv ) 468 | ;; | (let-rec ([ ] ...) ) 469 | ;; Expr --> 470 | ;; | 471 | ;; | (seq ) 472 | ;; | (let ( ) ) 473 | ;; 474 | (define (to-anormal-form x) 475 | (define (build-seq* e0 e1 e*) 476 | (if (null? e*) 477 | `(seq ,e0 ,e1) 478 | `(seq ,e0 ,(build-seq* e1 (car e*) (cdr e*))))) 479 | (define (build-let rx* re* body) 480 | (if (null? rx*) 481 | body 482 | (build-let (cdr rx*) (cdr re*) 483 | (let ([x (car rx*)]) 484 | (if x 485 | `(let (,x ,(car re*)) ,body) 486 | `(seq ,(car re*) ,body)))))) 487 | (define (AExpr* rx* re* e*) 488 | (if (null? e*) 489 | (values rx* re* '()) 490 | (let-values ([(rx* re* e) (AExpr rx* re* (car e*))]) 491 | (let-values ([(rx* re* e*) (AExpr* rx* re* (cdr e*))]) 492 | (values rx* re* (cons e e*)))))) 493 | (define (Binding* rx* re* x* e*) 494 | (if (null? x*) 495 | (values rx* re*) 496 | (let-values ([(rx* re* e) (CExpr rx* re* (car e*))]) 497 | (Binding* (cons (car x*) rx*) (cons e re*) (cdr x*) (cdr e*))))) 498 | (define (Lam le) 499 | (match le 500 | [`(lam (,x* ...) ,e) (let ([e (Expr e)]) `(lam ,x* ,e))])) 501 | (define (AExpr rx* re* e) 502 | (match e 503 | [`(let ([,x* ,e*] ...) ,body) 504 | (let-values ([(rx* re*) (Binding* rx* re* x* e*)]) 505 | (AExpr rx* re* body))] 506 | [`(seq ,e* ... ,e) 507 | (let ([re* (foldl (lambda (e re*) (cons (Expr e) re*)) re* e*)] 508 | [rx* (foldl (lambda (e rx*) (cons (next-symbol) rx*)) rx* e*)]) 509 | (AExpr rx* re* e))] 510 | [`(ref ,ref-type ,x) (values rx* re* e)] 511 | [`(boxref ,ref-type ,x) (values rx* re* e)] 512 | [`(application (primval ,prim) ,e* ...) 513 | (let-values ([(rx* re* e*) (AExpr* rx* re* e*)]) 514 | (values rx* re* `(primcall ,prim ,@e*)))] 515 | [`(application ,e ,e* ...) 516 | (let-values ([(rx* re* e) (AExpr rx* re* e)]) 517 | (let-values ([(rx* re* e*) (AExpr* rx* re* e*)]) 518 | (let ([t (next-symbol)]) 519 | (values (cons t rx*) (cons `(application ,e ,@e*) re*) `(ref normal ,t)))))] 520 | [`(set! ,x ,e) 521 | (let-values ([(rx* re* e) (AExpr rx* re* e)]) 522 | (values (cons #f rx*) (cons `(set! ,x ,e) re*) `(constant ,(void))))] 523 | [`(set-box! ,x ,e) 524 | (let-values ([(rx* re* e) (AExpr rx* re* e)]) 525 | (values (cons #f rx*) (cons `(set-box! ,x ,e) re*) `(constant ,(void))))] 526 | [`(boxenv ,x) (values (cons #f rx*) (cons `(boxenv ,x) re*) `(constant ,(void)))] 527 | [`(branch ,e0 ,e1 ,e2) 528 | (let-values ([(rx* re* e0) (AExpr rx* re* e0)]) 529 | (let ([e1 (Expr e1)] [e2 (Expr e2)] [t (next-symbol)]) 530 | (values (cons t rx*) (cons `(branch ,e0 ,e1 ,e2) re*) `(varref normal ,t))))] 531 | [`(let-rec ([,x* ,le*] ...) ,e) 532 | (let ([le* (map Lam le*)] [e (Expr e)] [t (next-symbol)]) 533 | (values (cons t rx*) (cons `(let-rec ,(map list x* le*) ,e) re*) `(ref normal ,t)))] 534 | [`(case-lam ,le* ...) (let ([le* (map Lam le*)]) (values rx* re* `(case-lam ,@le*)))] 535 | [`(constant ,const) (values rx* re* `(constant ,const))] 536 | [`(quote ,x) (values rx* re* `(quote ,x))] 537 | [`(primval ,x) (values rx* re* `(primval ,x))] 538 | [`(lam ((,x* : ,t*) ...) ,e) 539 | (let ([e (Expr e)]) 540 | (values rx* re* `(lam ,(map (lambda (x t) (list x ': t)) x* t*) ,e)))])) 541 | (define (CExpr rx* re* e) 542 | (match e 543 | [`(let ([,x* ,e*] ...) ,body) 544 | (let-values ([(rx* re*) (Binding* rx* re* x* e*)]) 545 | (CExpr rx* re* body))] 546 | [`(seq ,e* ... ,e) 547 | (let ([re* (foldl (lambda (e re*) (cons (Expr e) re*)) re* e*)] 548 | [rx* (foldl (lambda (e rx*) (cons (next-symbol) rx*)) rx* e*)]) 549 | (CExpr rx* re* e))] 550 | [`(application (primval ,prim) ,e* ...) 551 | (let-values ([(rx* re* e*) (AExpr* rx* re* e*)]) 552 | (values rx* re* `(primcall ,prim ,@e*)))] 553 | [`(application ,e ,e* ...) 554 | (let-values ([(rx* re* e) (AExpr rx* re* e)]) 555 | (let-values ([(rx* re* e*) (AExpr* rx* re* e*)]) 556 | (values rx* re* `(application ,e ,@e*))))] 557 | [`(set! ,x ,e) 558 | (let-values ([(rx* re* e) (AExpr rx* re* e)]) 559 | (values rx* re* `(set! ,x ,e)))] 560 | [`(set-box! ,x ,e) 561 | (let-values ([(rx* re* e) (AExpr rx* re* e)]) 562 | (values rx* re* `(set-box! ,x ,e)))] 563 | [`(boxenv ,x) (values rx* re* `(boxenv ,x))] 564 | [`(branch ,e0 ,e1 ,e2) 565 | (let-values ([(rx* re* e0) (AExpr rx* re* e0)]) 566 | (let ([e1 (Expr e1)] [e2 (Expr e2)]) 567 | (values rx* re* `(branch ,e0 ,e1 ,e2))))] 568 | [`(let-rec ([,x* ,le*] ...) ,e) 569 | (let ([le* (map Lam le*)] [e (Expr e)]) 570 | (values rx* re* `(let-rec ,(map list x* le*) ,e)))] 571 | [`(case-lam ,le* ...) (let ([le* (map Lam le*)]) (values rx* re* `(case-lam ,@le*)))] 572 | [_ (AExpr rx* re* e)])) 573 | (define (Expr e) 574 | (match e 575 | [`(seq ,e0 ,e1 ,e* ...) 576 | (let ([e0 (Expr e0)] [e1 (Expr e1)] [e* (map Expr e*)]) 577 | (build-seq* e0 e1 e*))] 578 | [`(let ([,x* ,e*] ...) ,body) 579 | (let-values ([(rx* re*) (Binding* '() '() x* e*)]) 580 | (let ([body (Expr body)]) 581 | (build-let rx* re* body)))] 582 | [_ (let-values ([(rx* re* body) (CExpr '() '() e)]) 583 | (build-let rx* re* body))])) 584 | (define (Prog p) 585 | (match p 586 | [`(prog ([,x* ,le*] ...) ,e) 587 | (let ([le* (map Lam le*)] [e (Expr e)]) 588 | `(let-rec ,(map list x* le*) ,e))])) 589 | (Prog x)) 590 | 591 | ;; output grammar: 592 | ;; Lambda --> (lam (( : ) ...) ) 593 | ;; AExpr --> 594 | ;; | (case-lam ...) 595 | ;; | (boxref ) 596 | ;; | (constant ) 597 | ;; | (primval ) 598 | ;; | (primcall ...) 599 | ;; | (quote ) 600 | ;; CExpr --> (application ...) 601 | ;; | (branch ) 602 | ;; | (set! ) 603 | ;; | (set-box! ) 604 | ;; | (boxenv ) 605 | ;; | (let-rec ([ ] ...) ) 606 | ;; | 607 | ;; Expr --> 608 | ;; | (seq ) 609 | ;; | (let ( ) ) 610 | ;; 611 | (define (cesk x) 612 | (define (empty-env) '()) 613 | (define (extend-env rho x addr) (cons (cons x addr) rho)) 614 | (define (extend-env* rho x* addr*) (foldl (lambda (x addr rho) (extend-env rho x addr)) rho x* addr*)) 615 | (define (apply-env rho x) 616 | (cond 617 | [(assq x rho) => cdr] 618 | [else (error 'apply-env "reference to unbound variable ~s" x)])) 619 | (define (empty-store) '()) 620 | (define (extend-store s addr val) (cons (cons addr val) s)) 621 | (define (extend-store* s addr* val*) (foldl (lambda (addr val rho) (extend-store s addr val)) s addr* val*)) 622 | (define (apply-store s addr) 623 | (cond 624 | [(assq addr s) => cdr] 625 | [else (error 'apply-store "reference to unallocated variable ~s" addr)])) 626 | (define (allocate s x) (gensym x)) 627 | (define (allocate* s x*) (map (lambda (x) (allocate s x)) x*)) 628 | (define (PrepPrimArgs e) e) 629 | (define (apply-proc e arg* s k) 630 | (define (return-vals x* expr rho) 631 | (let ([addr* (allocate* s (map car x*))]) 632 | (let ([rho (extend-env* rho (map car x*) addr*)]) 633 | (let ([s (extend-store* s addr* arg*)]) 634 | (values expr rho s k))))) 635 | (define (find-clause x** expr* arg* k) 636 | (let ([l (length arg*)]) 637 | (let loop ([x** x**] [expr* expr*]) 638 | (if (null? x**) 639 | (error 'apply-proc "incorrect number of arguments") 640 | (let ([x* (car x**)]) 641 | (if (= (length x*) l) 642 | (k x* (car expr*)) 643 | (loop (cdr x**) (cdr expr*)))))))) 644 | (match e 645 | [`(clo (,x* ...) ,expr ,rho) (return-vals x* expr rho)] 646 | [`(case-clo ,x** ,e* ,rho) 647 | (find-clause x** e* arg* 648 | (lambda (x* expr) (return-vals x* expr rho)))] 649 | [_ (error 'apply-proc "attempt to apply non-procedure value ~s" e)])) 650 | (define (apply-kont k val s) 651 | (match k 652 | [`(letk ,x ,rho ,e ,k) 653 | (let ([addr (allocate s x)]) 654 | (let ([rho (extend-env rho x addr)]) 655 | (let ([s (extend-store s addr val)]) 656 | (values e rho s k))))] 657 | [`(seqk ,rho ,expr ,k) 658 | (values expr rho s k)] 659 | [`(halt) (values val (empty-env) (empty-store) k)])) 660 | (define (AExpr e rho s) 661 | (match e 662 | [`(constant ,c) c] 663 | [`(lam (,x* ...) ,e) `(clo ,x* ,e ,rho)] 664 | [`(case-lam (lam (,x** ...) ,e*) ...) `(case-clo ,x** ,e* ,rho)] 665 | [`(ref ,ref-type ,x) (apply-store s (apply-env rho x))] 666 | [`(boxref ,ref-type ,x) (unbox (apply-store s (apply-env rho x)))] 667 | [`(primval ,x) (eval x)] 668 | [`(primcall ,prim ,e* ...) 669 | (let ([e* (map (lambda (e) (AExpr e rho s)) e*)]) 670 | (let ([e* (map PrepPrimArgs e*)]) 671 | (apply (eval prim) e*)))] 672 | [`(quote ,x) x])) 673 | (define (step e rho s k) 674 | (match e 675 | [`(let (,x0 ,e0) ,e1) 676 | (values e0 rho s `(letk ,x0 ,rho ,e1 ,k))] 677 | [`(seq ,e0 ,e1) 678 | (values e0 rho s `(seqk ,rho ,e1 ,k))] 679 | [`(application ,e ,e* ...) 680 | (let ([e (AExpr e rho s)] [e* (map (lambda (e) (AExpr e rho s)) e*)]) 681 | (apply-proc e e* s k))] 682 | [`(branch ,e0 ,e1 ,e2) 683 | (let ([e0 (AExpr e0 rho s)]) 684 | (values (if (eq? e0 #f) e2 e1) rho s k))] 685 | [`(set! ,x ,e) 686 | (let ([s (extend-store s (apply-env x) (AExpr e rho s))]) 687 | (apply-kont k `(constant ,(void))) s)] 688 | [`(set-box! ,x ,e) 689 | (let ([b (apply-store s (apply-env rho x))]) 690 | (set-box! b (AExpr e rho s)) 691 | (apply-kont k `(constant ,(void)) s))] 692 | [`(boxenv ,x) 693 | (let ([addr (apply-env rho x)]) 694 | (let ([val (apply-store s addr)]) 695 | (let ([s (extend-store s addr (box val))]) 696 | (apply-kont k `(constant ,(void)) s))))] 697 | [`(let-rec ([,x* ,le*] ...) ,e) 698 | (let ([addr* (allocate* s x*)]) 699 | (let ([rho (extend-env* rho x* addr*)]) 700 | (let ([le* (map (lambda (le) (AExpr le rho s)) le*)]) 701 | (let ([s (extend-store* s addr* le*)]) 702 | (values e rho s k)))))] 703 | [_ (apply-kont k (AExpr e rho s) s)])) 704 | (define (value-exp? exp) 705 | (if (pair? exp) 706 | (and (not (memq (car exp) '(let seq application brnch set! set-box! boxenv let-rec))) 707 | (memq (car exp) '(clo case-clo)) 708 | #t) 709 | #t)) 710 | (define (step-driver exp rho s k) 711 | (let-values ([(exp rho s k) (step exp rho s k)]) 712 | (if (and (value-exp? exp) (match k [`(halt) #t] [_ #f])) 713 | exp 714 | (step-driver exp rho s k)))) 715 | (step-driver x (empty-env) (empty-store) `(halt))) 716 | 717 | (define racket-source->bytecode (compose impl->model source->bytecode)) 718 | (define racket-source-file->bytecode (compose impl->model source-file->bytecode)) 719 | (define racket-zo-file->bytecode (compose impl->model zo-file->bytecode)) 720 | 721 | (define-syntax passes 722 | (syntax-rules () 723 | [(_ ?x f ...) (let* ([x ?x] [x (f x)] ...) x)])) 724 | 725 | (define (racket-source->anormal-form x) 726 | (passes x 727 | source->bytecode 728 | impl->model 729 | model->prog 730 | reintroduce-variables 731 | check-grammar 732 | to-anormal-form)) 733 | 734 | (provide (all-defined-out)) 735 | -------------------------------------------------------------------------------- /src/fact.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define fact 4 | (lambda (n) 5 | (if (zero? n) 6 | 1 7 | (* n (fact (- n 1)))))) 8 | 9 | (provide fact) 10 | -------------------------------------------------------------------------------- /src/priminfo.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require compiler/zo-parse) 4 | 5 | (define build-primitive-list 6 | (lambda () 7 | (map 8 | (lambda (key) 9 | (let ([ns (make-base-empty-namespace)]) 10 | (parameterize ([current-namespace ns]) 11 | (namespace-require key) 12 | (cons key 13 | (foldl (lambda (l ls) 14 | (let ([c (with-handlers ([exn:fail? (lambda (x) #f)]) (compile l))]) 15 | (if c 16 | (let ([v (zo-parse 17 | (let ([out (open-output-bytes)]) 18 | (write c out) 19 | (close-output-port out) 20 | (open-input-bytes (get-output-bytes out))))]) 21 | (match v 22 | [(struct compilation-top (_ prefix (struct primval (n)))) 23 | (let ([p (eval l)]) 24 | (cons 25 | (list l n (primitive? p) 26 | (and (procedure? p) (procedure-arity p)) 27 | (and (procedure? p) 28 | (call-with-values 29 | (lambda () (procedure-keywords p)) 30 | (lambda (req acc) 31 | (if (and (null? req) (null? acc)) 32 | #f 33 | (list req acc))))) 34 | (and (primitive? p) (primitive-result-arity p)) 35 | (value-contract p) 36 | ) 37 | ls))] 38 | [_ ls])) 39 | ls))) 40 | '() (namespace-mapped-symbols)))))) 41 | '('#%kernel '#%unsafe '#%flfxnum '#%futures '#%network '#%place '#%expobs)))) 42 | 43 | (define lookup-primitive 44 | (let ([prim->num (let ([ns (make-base-empty-namespace)]) 45 | (parameterize ([current-namespace ns]) 46 | (namespace-require ''#%kernel) 47 | (namespace-require ''#%unsafe) 48 | (namespace-require ''#%flfxnum) 49 | (namespace-require ''#%futures) 50 | (namespace-require ''#%network) 51 | (namespace-require ''#%place) 52 | (namespace-require ''#%expobs) 53 | (foldl (lambda (l ls) 54 | (let ([c (with-handlers ([exn:fail? (lambda (x) #f)]) (compile l))]) 55 | (if c 56 | (let ([v (zo-parse 57 | (let ([out (open-output-bytes)]) 58 | (write c out) 59 | (close-output-port out) 60 | (open-input-bytes (get-output-bytes out))))]) 61 | (match v 62 | [(struct compilation-top (_ prefix (struct primval (n)))) 63 | (cons (cons l n) ls)] 64 | [_ ls])) 65 | ls))) 66 | '() (namespace-mapped-symbols))))]) 67 | (let ([num->prim (map (lambda (p) (cons (cdr p) (car p))) prim->num)]) 68 | (lambda (x) 69 | (cond 70 | [(and (number? x) (assq x num->prim)) => cdr] 71 | [(and (symbol? x) (assq x prim->num)) => cdr] 72 | [else #f]))))) 73 | 74 | (provide lookup-primitive build-primitive-list) 75 | -------------------------------------------------------------------------------- /src/prims.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "priminfo.rkt") 4 | 5 | (define-syntax define-racket-prims 6 | (lambda (x) 7 | (define (->string x) 8 | (cond 9 | [(identifier? x) (symbol->string (syntax->datum x))] 10 | [(symbol? x) (symbol->string x)] 11 | [(string? x) x] 12 | [else (error '->string "not sure how to convert ~s to a string" x)])) 13 | (define (construct-id tid . rest) 14 | (when (null? rest) (error 'construct-id "must include more then just template id")) 15 | (datum->syntax tid 16 | (string->symbol 17 | (apply string-append (map ->string rest))))) 18 | (syntax-case x () 19 | [(k [type prim ...] ...) 20 | (and (andmap (lambda (type) (identifier? type)) (syntax-e #'(type ...))) 21 | (andmap (lambda (prim) (identifier? prim)) (syntax-e #'(prim ... ...)))) 22 | (with-syntax ([all-primitives (construct-id #'k "all-primitives")] 23 | [(type-primitives ...) 24 | (map (lambda (type) (construct-id #'k type "-primitives")) (syntax-e #'(type ...)))] 25 | [(primitive-type? ...) 26 | (map (lambda (type) (construct-id #'k "primitive-" type "?")) (syntax-e #'(type ...)))]) 27 | #'(begin 28 | (define type-primitives '(prim ...)) ... 29 | (define primitive-type? 30 | (lambda (x) 31 | (let ([p (if (exact-integer? x) (lookup-primitive x) x)]) 32 | (and (memq x type-primitives) #t)))) ... 33 | (define all-primitives (append type-primitives ...))))]))) 34 | 35 | (define-racket-prims 36 | [simple * + - / < <= = > >= abs acos add1 angle arithmetic-shift asin atan 37 | bitwise-and bitwise-bit-field bitwise-bit-set? bitwise-ior 38 | bitwise-not bitwise-xor ceiling complex? append assoc assq assv 39 | caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar 40 | caddar cadddr caddr cadr car cdaaar cdaadr cdaar cdadar cdaddr cdadr 41 | cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr cons boolean? 42 | box box-immutable box? byte? bytes bytes->immutable-bytes bytes->list 43 | bytes->path bytes->path-element bytes->string/latin-1 44 | bytes->string/locale bytes->string/utf-8 bytes-append bytes-copy 45 | bytes-copy! bytes-fill! bytes-length bytes-ref bytes-set! 46 | bytes-utf-8-index bytes-utf-8-length bytes-utf-8-ref bytes? bytes? char->integer char-alphabetic? char-blank? char-ci<=? 48 | char-ci=? char-ci>? char-downcase char-foldcase 49 | char-general-category char-graphic? char-iso-control? 50 | char-lower-case? char-numeric? char-punctuation? char-symbolic? 51 | char-title-case? char-titlecase char-upcase char-upper-case? 52 | char-utf-8-length char-whitespace? char<=? char=? 53 | char>? char? absolute-path? build-path build-path/convention-type 54 | cleanse-path complete-path? byte-pregexp byte-pregexp? byte-regexp 55 | byte-regexp? bound-identifier=? flmax flmin fl>= fl<= fl> fl< fl= 56 | fxmax fxmin fx>= fx<= fx> fx< fx= flsqrt flabs fl/ fl* fl- fl+ fxabs 57 | fxmodulo fxremainder fxquotient fx* fx- fx+ flimag-part flreal-part 58 | make-flrectangular flexpt flexp fllog flatan flacos flasin fltan 59 | flcos flsin flfloor flceiling flround fltruncate fl->fx fx->fl 60 | fxrshift fxlshift fxnot fxxor fxior fxand fl->exact-integer ->fl 61 | fxvector-set! fxvector-ref fxvector-length pregexp? regexp? 62 | regexp-replace* regexp-replace 63 | regexp-match-peek-positions-immediate/end 64 | regexp-match-peek-positions-immediate regexp-match-peek-immediate 65 | regexp-match-peek-positions/end regexp-match-peek-positions 66 | regexp-match-peek regexp-match? regexp-match-positions/end 67 | regexp-match-positions regexp-match/end regexp-match pregexp regexp 68 | string-locale-downcase string-locale-upcase string-foldcase 69 | string-titlecase string-downcase string-upcase string-normalize-nfkd 70 | string-normalize-nfd string-normalize-nfkc string-normalize-nfc 71 | string->immutable-string string-fill! string-copy! string-copy 72 | list->string string->list string-append substring string-ci>=? 73 | string-ci<=? string-locale-ci>? string-ci>? string-locale-ci=? string<=? string-locale>? string>? 75 | string-localefloating-point-bytes 78 | floating-point-bytes->real integer->integer-bytes 79 | integer-bytes->integer string->number number->string min max 80 | negative? positive? zero? modulo quotient/remainder remainder 81 | quotient sub1 inexact->exact exact->inexact magnitude imag-part 82 | real-part make-polar make-rectangular expt integer-sqrt/remainder 83 | integer-sqrt sqrt tan cos sin log exp denominator numerator round 84 | truncate floor lcm gcd integer-length even? odd? inexact? exact? 85 | real->double-flonum real->single-flonum single-flonum? flonum? 86 | inexact-real? fixnum? exact-positive-integer? 87 | exact-nonnegative-integer? exact-integer? integer? rational? real? 88 | number? set-box! unbox member memv memq list-ref list-tail reverse 89 | length list* list list? null? set-mcdr! set-mcar! mcdr mcar mcons 90 | mpair? pair? symbol->string string->symbol symbol-interned? 91 | symbol-unreadable? symbol? seconds->date void? void unsafe-fx<= 92 | unsafe-fx> unsafe-fx< unsafe-fx= unsafe-flsqrt unsafe-flabs 93 | unsafe-fl/ unsafe-fl* unsafe-fl- unsafe-fl+ unsafe-fxabs 94 | unsafe-fxmodulo unsafe-fxremainder unsafe-fxquotient unsafe-fx* 95 | unsafe-fx- unsafe-fx+ unsafe-flimag-part unsafe-flreal-part 96 | unsafe-make-flrectangular unsafe-u16vector-set! unsafe-u16vector-ref 97 | unsafe-s16vector-set! unsafe-s16vector-ref unsafe-fxvector-set! 98 | unsafe-fxvector-ref unsafe-fxvector-length unsafe-flvector-set! 99 | unsafe-flvector-ref unsafe-flvector-length unsafe-f64vector-set! 100 | unsafe-f64vector-ref unsafe-fl->fx unsafe-fx->fl unsafe-fxrshift 101 | unsafe-fxlshift unsafe-fxnot unsafe-fxxor unsafe-fxior unsafe-fxand 102 | unsafe-bytes-set! unsafe-bytes-ref unsafe-bytes-length 103 | unsafe-string-set! unsafe-string-ref unsafe-string-length 104 | unsafe-set-mcdr! unsafe-set-mcar! unsafe-mcdr unsafe-mcar 105 | unsafe-list-tail unsafe-list-ref unsafe-cdr unsafe-car unsafe-flmax 106 | unsafe-flmin unsafe-fl>= unsafe-fl<= unsafe-fl> unsafe-fl< unsafe-fl= 107 | unsafe-fxmax unsafe-fxmin unsafe-fx>= make-fxvector fxvector? 108 | fxvector flvector-set! flvector-ref flvector-length make-flvector 109 | flvector? flvector regexp-max-lookbehind print-as-expression 110 | print-boolean-long-form print-reader-abbreviations print-syntax-width 111 | print-mpair-curly-braces print-pair-curly-braces print-unreadable 112 | print-hash-table print-vector-length print-box print-struct 113 | print-graph equal-secondary-hash-code equal-hash-code eqv-hash-code 114 | eq-hash-code hash-remove hash-remove! hash-ref hash-set hash-set! 115 | hash-copy hash-count hash-weak? hash-equal? hash-eqv? hash-eq? hash? 116 | hasheqv hasheq hash make-immutable-hasheqv make-immutable-hasheq 117 | make-immutable-hash make-weak-hasheqv make-weak-hasheq make-weak-hash 118 | make-hasheqv make-hasheq make-hash immutable? keyword->string 119 | string->keyword keywordbytes/latin-1 string->bytes/locale string->bytes/utf-8 121 | list->bytes subbytes vector->values vector->immutable-vector 122 | vector-copy! vector-fill! list->vector vector->list vector-set! 123 | vector-ref vector-length vector-immutable vector make-vector 124 | integer->char vector? date-time-zone-offset date-dst? date-year-day 125 | date-week-day date-year date-month date-day date-hour date-minute 126 | date-second date? date equal?/recur equal? eqv? eq? read-accept-lang 127 | read-accept-reader read-accept-quasiquote read-accept-infix-dot 128 | read-accept-dot read-decimal-as-inexact read-accept-bar-quote 129 | read-accept-box read-accept-compiled read-accept-graph 130 | read-curly-brace-as-paren read-square-bracket-as-paren 131 | read-case-sensitive open-output-string open-output-bytes 132 | open-input-string open-input-bytes] 133 | [runtime-specific box-cas! alarm-evt always-evt choice-evt channel-put-evt 134 | channel-put-evt? channel? collect-garbage] 135 | [potentially-simple bytes-close-converter bytes-convert bytes-convert-end 136 | bytes-converter? bytes-open-converter weak-box? 137 | weak-box-value make-weak-box gensym 138 | string->unreadable-symbol string->uninterned-symbol] 139 | [io char-ready? byte-ready? banner close-input-port close-output-port 140 | current-directory file-size delete-directory make-directory copy-file 141 | rename-file-or-directory delete-file link-exists? directory-exists? 142 | file-exists? current-seconds current-gc-milliseconds 143 | current-process-milliseconds current-inexact-milliseconds 144 | current-milliseconds open-input-file port-closed? terminal-port? 145 | file-stream-port? output-port? input-port? peek-bytes! peek-bytes 146 | read-bytes! read-bytes peek-string! peek-string read-string! read-string 147 | read-line read-bytes-line read-byte-or-special read-byte 148 | read-char-or-special read-char read-language read-syntax/recursive 149 | read-syntax read/recursive read port-commit-peeked write-byte write-char 150 | newline peek-byte-or-special peek-byte peek-char-or-special peek-char 151 | write-special-avail* write-special flush-output print display write 152 | printf write-string write-bytes] 153 | [control abort-current-continuation break-enabled break-thread 154 | call-in-nested-thread call-with-composable-continuation 155 | call-with-continuation-barrier call-with-continuation-prompt 156 | call-with-current-continuation call-with-escape-continuation 157 | call-with-immediate-continuation-mark call-with-input-file 158 | call-with-output-file call-with-semaphore 159 | call-with-semaphore/enable-break call-with-values call/cc call/ec 160 | ormap andmap for-each map apply procedure? time-apply 161 | hash-iterate-key hash-iterate-value hash-iterate-next 162 | hash-iterate-first hash-for-each hash-map] 163 | [who-knows arity-at-least arity-at-least-value arity-at-least? 164 | checked-procedure-check-and-extract chaperone-box 165 | chaperone-continuation-mark-key chaperone-evt chaperone-hash 166 | chaperone-of? chaperone-procedure chaperone-prompt-tag 167 | chaperone-struct chaperone-struct-type chaperone-vector chaperone? 168 | compile compile-allow-set!-undefined 169 | compile-context-preservation-enabled 170 | compile-enforce-module-constants compile-syntax 171 | compiled-expression? compiled-module-expression?]) 172 | 173 | (define difference 174 | (lambda (s1 s2) 175 | (cond 176 | [(null? s1) '()] 177 | [(memq (car s1) s2) (difference (cdr s1) s2)] 178 | [else (cons (car s1) (difference (cdr s1) s2))]))) 179 | 180 | (define flat-full-prim-list (map car (apply append (map cdr (build-primitive-list))))) 181 | 182 | (define extra-prims (difference all-primitives flat-full-prim-list)) 183 | (define missing-prims (difference flat-full-prim-list all-primitives)) 184 | 185 | (provide (all-defined-out)) 186 | 187 | #| 188 | 189 | syntax: 190 | syntax-local-lift-provide 191 | syntax-local-lift-require 192 | syntax-local-lift-module-end-declaration 193 | syntax-local-lift-context 194 | syntax-local-lift-values-expression 195 | syntax-local-lift-expression 196 | rename-transformer-target 197 | rename-transformer? 198 | make-rename-transformer 199 | set!-transformer-procedure 200 | set!-transformer? 201 | make-set!-transformer 202 | syntax-local-transforming-module-provides? 203 | syntax-local-module-required-identifiers 204 | syntax-local-submodules 205 | syntax-local-module-defined-identifiers 206 | syntax-local-module-exports 207 | syntax-local-make-delta-introducer 208 | make-syntax-introducer 209 | syntax-local-introduce 210 | syntax-local-get-shadower 211 | identifier-remove-from-definition-context 212 | internal-definition-context? 213 | internal-definition-context-seal 214 | syntax-local-make-definition-context 215 | syntax-local-phase-level 216 | syntax-local-context 217 | syntax-local-name 218 | syntax-local-value/immediate 219 | syntax-local-value 220 | syntax-transforming-module-expression? 221 | syntax-transforming? 222 | variable-reference-constant? 223 | variable-reference->module-declaration-inspector 224 | variable-reference->module-base-phase 225 | variable-reference->phase 226 | variable-reference->namespace 227 | variable-reference->empty-namespace 228 | variable-reference->module-source 229 | variable-reference->resolved-module-path 230 | variable-reference->module-path-index 231 | variable-reference? 232 | free-label-identifier=? 233 | free-template-identifier=? 234 | free-transformer-identifier=? 235 | free-identifier=? 236 | syntax-shift-phase-level 237 | make-syntax-delta-introducer 238 | syntax-taint 239 | syntax-rearm 240 | syntax-disarm 241 | syntax-arm 242 | syntax-tainted? 243 | syntax-source-module 244 | syntax-track-origin 245 | syntax-property-symbol-keys 246 | syntax-property 247 | syntax-original? 248 | syntax->list 249 | syntax-source 250 | syntax-span 251 | syntax-position 252 | syntax-column 253 | syntax-line 254 | syntax-e 255 | datum->syntax 256 | syntax->datum 257 | syntax? 258 | 259 | modules/namespace: 260 | module-path-index-join 261 | module-path-index-submodule 262 | module-path-index-split 263 | module-path-index-resolve 264 | module-path-index? 265 | module-compiled-submodules 266 | module-compiled-language-info 267 | module-compiled-exports 268 | module-compiled-imports 269 | module-compiled-name 270 | module-path? 271 | module-predefined? 272 | module-declared? 273 | module->exports 274 | module->imports 275 | module->language-info 276 | module->namespace 277 | module-provide-protected? 278 | resolved-module-path-name 279 | make-resolved-module-path 280 | resolved-module-path? 281 | namespace-module-registry 282 | namespace-mapped-symbols 283 | namespace-undefine-variable! 284 | namespace-set-variable-value! 285 | namespace-variable-value 286 | namespace-base-phase 287 | namespace-module-identifier 288 | namespace-symbol->identifier 289 | namespace-require/expansion-time 290 | namespace-require/constant 291 | namespace-require/copy 292 | namespace-unprotect-module 293 | namespace-attach-module-declaration 294 | namespace-attach-module 295 | namespace-require 296 | namespace? 297 | 298 | i/o: 299 | current-drive 300 | file-or-directory-identity 301 | file-or-directory-permissions 302 | file-or-directory-modify-seconds 303 | make-file-or-directory-link 304 | filesystem-root-list 305 | directory-list 306 | expand-user-path 307 | simplify-path 308 | resolve-path 309 | path->complete-path 310 | relative-path? 311 | split-path 312 | path->directory-path 313 | string->path-element 314 | string->path 315 | path-element->string 316 | path-element->bytes 317 | path->bytes 318 | path->string 319 | system-path-convention-type 320 | path-convention-type 321 | path-for-some-system? 322 | path? 323 | 324 | threads: 325 | never-evt 326 | system-idle-evt 327 | thread-rewind-receive 328 | thread-receive-evt 329 | thread-try-receive 330 | thread-receive 331 | thread-send 332 | make-channel 333 | semaphore-peek-evt? 334 | semaphore-peek-evt 335 | semaphore-wait/enable-break 336 | semaphore-wait 337 | semaphore-try-wait? 338 | semaphore-post 339 | semaphore? 340 | make-semaphore 341 | current-thread-initial-stack-size 342 | evt? 343 | thread-cell-values? 344 | current-preserved-thread-cell-values 345 | thread-cell-set! 346 | thread-cell-ref 347 | make-thread-cell 348 | thread-cell? 349 | thread-dead-evt 350 | thread-suspend-evt 351 | thread-resume-evt 352 | thread-resume 353 | thread-suspend 354 | kill-thread 355 | current-thread 356 | thread-wait 357 | thread-dead? 358 | thread-running? 359 | thread? 360 | thread/suspend-to-kill 361 | thread 362 | 363 | gc: 364 | custodian-memory-accounting-available? 365 | custodian-limit-memory 366 | custodian-require-memory 367 | current-memory-use 368 | 369 | exceptions: 370 | raise 371 | uncaught-exception-handler 372 | struct:exn:break:hang-up 373 | exn:break:hang-up 374 | exn:break:hang-up? 375 | struct:exn:break:terminate 376 | exn:break:terminate 377 | exn:break:terminate? 378 | struct:exn:break 379 | exn:break 380 | exn:break? 381 | exn:break-continuation 382 | struct:exn:fail:user 383 | exn:fail:user 384 | exn:fail:user? 385 | struct:exn:fail:unsupported 386 | exn:fail:unsupported 387 | exn:fail:unsupported? 388 | struct:exn:fail:out-of-memory 389 | exn:fail:out-of-memory 390 | exn:fail:out-of-memory? 391 | struct:exn:fail:network 392 | exn:fail:network 393 | exn:fail:network? 394 | struct:exn:fail:filesystem:version 395 | exn:fail:filesystem:version 396 | exn:fail:filesystem:version? 397 | struct:exn:fail:filesystem:exists 398 | exn:fail:filesystem:exists 399 | exn:fail:filesystem:exists? 400 | struct:exn:fail:filesystem 401 | exn:fail:filesystem 402 | exn:fail:filesystem? 403 | struct:exn:fail:read:non-char 404 | exn:fail:read:non-char 405 | exn:fail:read:non-char? 406 | struct:exn:fail:read:eof 407 | exn:fail:read:eof 408 | exn:fail:read:eof? 409 | struct:exn:fail:read 410 | exn:fail:read 411 | exn:fail:read? 412 | exn:fail:read-srclocs 413 | struct:exn:fail:syntax:unbound 414 | exn:fail:syntax:unbound 415 | exn:fail:syntax:unbound? 416 | struct:exn:fail:syntax 417 | exn:fail:syntax 418 | exn:fail:syntax? 419 | exn:fail:syntax-exprs 420 | struct:exn:fail:contract:variable 421 | exn:fail:contract:variable 422 | exn:fail:contract:variable? 423 | exn:fail:contract:variable-id 424 | struct:exn:fail:contract:continuation 425 | exn:fail:contract:continuation 426 | exn:fail:contract:continuation? 427 | struct:exn:fail:contract:non-fixnum-result 428 | exn:fail:contract:non-fixnum-result 429 | exn:fail:contract:non-fixnum-result? 430 | struct:exn:fail:contract:divide-by-zero 431 | exn:fail:contract:divide-by-zero 432 | exn:fail:contract:divide-by-zero? 433 | struct:exn:fail:contract:arity 434 | exn:fail:contract:arity 435 | exn:fail:contract:arity? 436 | struct:exn:fail:contract 437 | exn:fail:contract 438 | exn:fail:contract? 439 | struct:exn:fail 440 | exn:fail 441 | exn:fail? 442 | struct:exn 443 | exn 444 | exn? 445 | exn-message 446 | exn-continuation-marks 447 | error-print-source-location 448 | error-print-context-length 449 | error-print-width 450 | error-escape-handler 451 | error-value->string-handler 452 | error-display-handler 453 | raise-arity-error 454 | raise-range-error 455 | raise-mismatch-error 456 | raise-arguments-error 457 | raise-result-error 458 | raise-argument-error 459 | raise-type-error 460 | raise-syntax-error 461 | raise-user-error 462 | error 463 | 464 | unknown: 465 | current-load-extension 466 | load-extension 467 | use-collection-link-paths 468 | use-user-specific-search-paths 469 | current-compiled-file-roots 470 | use-compiled-file-paths 471 | current-library-collection-paths 472 | find-system-path 473 | datum-intern-literal 474 | readtable-mapping 475 | readtable? 476 | make-readtable 477 | read-on-demand-source 478 | current-reader-guard 479 | current-readtable 480 | sync/timeout/enable-break 481 | sync/enable-break 482 | sync/timeout 483 | sync 484 | will-execute 485 | will-try-execute 486 | will-register 487 | will-executor? 488 | make-will-executor 489 | 490 | '( parameterization? 491 | parameter-procedure=? 492 | make-derived-parameter 493 | make-parameter 494 | parameter? 495 | current-thread-group 496 | make-thread-group 497 | thread-group? 498 | current-security-guard 499 | make-security-guard 500 | security-guard? 501 | current-namespace 502 | custodian-box? 503 | custodian-box-value 504 | make-custodian-box 505 | custodian-managed-list 506 | custodian-shutdown-all 507 | custodian? 508 | make-custodian 509 | current-custodian 510 | sleep 511 | make-empty-namespace 512 | vector-set-performance-stats! 513 | dump-memory-stats 514 | impersonator-prop:application-mark 515 | impersonator-property? 516 | make-impersonator-property 517 | impersonate-struct 518 | exn:srclocs-accessor 519 | exn:srclocs? 520 | prop:exn:srclocs 521 | special-comment? 522 | special-comment-value 523 | make-special-comment 524 | current-code-inspector 525 | current-inspector 526 | inspector? 527 | make-sibling-inspector 528 | make-inspector 529 | impersonator-property-accessor-procedure? 530 | struct-type-property-accessor-procedure? 531 | struct-constructor-procedure? 532 | struct-predicate-procedure? 533 | struct-accessor-procedure? 534 | struct-mutator-procedure? 535 | prefab-key? 536 | prefab-key->struct-type 537 | make-prefab-struct 538 | prefab-struct-key 539 | struct->vector 540 | struct-type-make-constructor 541 | struct-type-make-predicate 542 | struct-type-info 543 | struct-info 544 | procedure-extract-target 545 | procedure-struct-type? 546 | struct-type-property? 547 | struct-type? 548 | struct? 549 | handle-evt? 550 | poll-guard-evt 551 | nack-guard-evt 552 | handle-evt 553 | wrap-evt 554 | make-struct-field-mutator 555 | make-struct-field-accessor 556 | make-struct-type-property 557 | make-struct-type 558 | prop:method-arity-error 559 | liberal-define-context? 560 | prop:liberal-define-context 561 | prop:checked-procedure 562 | prop:set!-transformer 563 | prop:rename-transformer 564 | prop:output-port 565 | prop:input-port 566 | prop:impersonator-of 567 | prop:equal+hash 568 | prop:incomplete-arity 569 | prop:procedure 570 | prop:evt 571 | custom-print-quotable-accessor 572 | custom-print-quotable? 573 | prop:custom-print-quotable 574 | custom-write-accessor 575 | custom-write? 576 | prop:custom-write 577 | srcloc-span 578 | srcloc-position 579 | srcloc-column 580 | srcloc-line 581 | srcloc-source 582 | srcloc? 583 | srcloc 584 | struct:srcloc 585 | date*-time-zone-name 586 | date*-nanosecond 587 | date*? 588 | date* 589 | struct:date* 590 | struct:date 591 | struct:arity-at-least 592 | prop:arity-string 593 | current-logger 594 | log-receiver? 595 | logger-name 596 | logger? 597 | log-message 598 | make-log-receiver 599 | make-logger 600 | log-max-level 601 | log-level? 602 | exit 603 | executable-yield-handler 604 | exit-handler 605 | eval-jit-enabled 606 | current-compile 607 | current-eval 608 | namespace-syntax-introduce 609 | expand-syntax-to-top-form 610 | expand-to-top-form 611 | expand-syntax-once 612 | expand-once 613 | local-transformer-expand/capture-lifts 614 | local-transformer-expand 615 | local-expand/capture-lifts 616 | syntax-local-bind-syntaxes 617 | syntax-local-expand-expression 618 | local-expand 619 | expand-syntax 620 | expand 621 | eval-syntax 622 | eval 623 | impersonator-of? 624 | impersonator? 625 | not 626 | make-known-char-range-list 627 | impersonate-vector 628 | current-command-line-arguments 629 | system-library-subpath 630 | system-type 631 | putenv 632 | getenv 633 | version 634 | shared-bytes 635 | make-shared-bytes 636 | fprintf 637 | eprintf 638 | format 639 | system-language+country 640 | locale-string-encoding 641 | current-locale 642 | pipe-content-length 643 | eof-object? 644 | port-count-lines! 645 | port-file-identity 646 | port-file-unlock 647 | port-try-file-lock? 648 | file-stream-buffer-mode 649 | file-position* 650 | file-position 651 | port-print-handler 652 | port-write-handler 653 | port-display-handler 654 | port-read-handler 655 | write-special-evt 656 | write-bytes-avail-evt 657 | port-closed-evt 658 | progress-evt? 659 | port-progress-evt 660 | port-writes-special? 661 | port-writes-atomic? 662 | write-bytes-avail/enable-break 663 | write-bytes-avail* 664 | write-bytes-avail 665 | port-provides-progress-evts? 666 | peek-bytes-avail!/enable-break 667 | peek-bytes-avail!* 668 | peek-bytes-avail! 669 | read-bytes-avail!/enable-break 670 | read-bytes-avail!* 671 | read-bytes-avail! 672 | set-port-next-location! 673 | port-next-location 674 | make-pipe 675 | load 676 | with-input-from-file 677 | with-output-to-file 678 | make-output-port 679 | make-input-port 680 | open-input-output-file 681 | get-output-string 682 | get-output-bytes 683 | open-output-file 684 | port-count-lines-enabled 685 | load-on-demand-enabled 686 | global-port-print-handler 687 | current-write-relative-directory 688 | current-load-relative-directory 689 | current-load/use-compiled 690 | current-load 691 | current-error-port 692 | current-output-port 693 | current-input-port 694 | eof 695 | shell-execute 696 | current-subprocess-custodian-mode 697 | subprocess-group-enabled 698 | subprocess-wait 699 | subprocess? 700 | subprocess-pid 701 | subprocess-kill 702 | subprocess-status 703 | subprocess 704 | dynamic-require-for-syntax 705 | dynamic-require 706 | current-module-declare-source 707 | current-module-declare-name 708 | current-module-name-resolver 709 | identifier-prune-to-source-module 710 | identifier-prune-lexical-context 711 | identifier-label-binding 712 | identifier-template-binding 713 | identifier-transformer-binding 714 | identifier-binding 715 | current-evt-pseudo-random-generator 716 | current-pseudo-random-generator 717 | pseudo-random-generator? 718 | pseudo-random-generator-vector? 719 | pseudo-random-generator->vector 720 | vector->pseudo-random-generator! 721 | vector->pseudo-random-generator 722 | make-pseudo-random-generator 723 | random-seed 724 | random 725 | system-big-endian? 726 | hash-placeholder? 727 | make-hasheqv-placeholder 728 | make-hasheq-placeholder 729 | make-hash-placeholder 730 | placeholder? 731 | placeholder-set! 732 | placeholder-get 733 | make-placeholder 734 | make-reader-graph 735 | ephemeron? 736 | ephemeron-value 737 | make-ephemeron 738 | impersonate-hash 739 | impersonate-box 740 | current-get-interaction-input-port 741 | current-read-interaction 742 | current-prompt-read 743 | current-print 744 | primitive-result-arity 745 | primitive-closure? 746 | primitive? 747 | impersonate-procedure 748 | procedure-closure-contents-eq? 749 | procedure->method 750 | procedure-rename 751 | procedure-reduce-arity 752 | procedure-arity-includes? 753 | procedure-arity? 754 | procedure-arity 755 | object-name 756 | dynamic-wind 757 | continuation-mark-set->context 758 | continuation-mark-set? 759 | continuation-mark-set-first 760 | continuation-mark-set->list* 761 | continuation-mark-set->list 762 | continuation-marks 763 | current-continuation-marks 764 | impersonate-continuation-mark-key 765 | continuation-mark-key? 766 | make-continuation-mark-key 767 | impersonate-prompt-tag 768 | continuation-prompt-tag? 769 | default-continuation-prompt-tag 770 | make-continuation-prompt-tag 771 | continuation-prompt-available? 772 | continuation? 773 | values 774 | unsafe-struct*-set! 775 | unsafe-struct-set! 776 | unsafe-struct*-ref 777 | unsafe-struct-ref 778 | unsafe-vector*-set! 779 | unsafe-vector-set! 780 | unsafe-vector*-ref 781 | unsafe-vector-ref 782 | unsafe-vector*-length 783 | unsafe-vector-length 784 | unsafe-box*-cas! 785 | unsafe-set-box*! 786 | unsafe-set-box! 787 | unsafe-unbox* 788 | unsafe-unbox 789 | make-shared-fxvector 790 | shared-fxvector 791 | make-shared-flvector 792 | shared-flvector 793 | mark-future-trace-end! 794 | reset-future-logs-for-tracing! 795 | futures-enabled? 796 | would-be-future 797 | fsemaphore-try-wait? 798 | fsemaphore-post 799 | fsemaphore-wait 800 | fsemaphore-count 801 | make-fsemaphore 802 | fsemaphore? 803 | current-future 804 | touch 805 | processor-count 806 | future 807 | future?) 808 | |# 809 | -------------------------------------------------------------------------------- /src/spike.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "priminfo.rkt") 4 | (require compiler/zo-parse) 5 | (require compiler/compiler) 6 | 7 | (define ip->bytecode 8 | (lambda (ip) 9 | (zo-parse ip))) 10 | 11 | ; Originally pulled out the code from the compilation-top, but it is unclear 12 | ; that we can just discard the prefix, so I've gone back to just zo-parse. 13 | ; (match (zo-parse ip) 14 | ; [(struct compilation-top (_ _ code)) code] 15 | ; [_ #f]) 16 | ; 17 | 18 | (define zo-file->bytecode 19 | (lambda (fn) 20 | (call-with-input-file fn ip->bytecode))) 21 | 22 | (define source-file->bytecode 23 | (let ([compile-file (let ([compile-files (compile-zos #f)]) 24 | (lambda (fn dir) 25 | (compile-files (list fn) dir)))]) 26 | (lambda (fn) 27 | (let ([dir (make-temporary-file "rkt-compile-tmp-~a" 'directory)]) 28 | (compile-file fn dir) 29 | (zo-file->bytecode 30 | (path-replace-suffix (path->complete-path fn dir) "_rkt.zo")))))) 31 | 32 | (define source->bytecode 33 | (lambda (expr) 34 | (ip->bytecode 35 | (let ([out (open-output-bytes)]) 36 | (write (compile expr) out) 37 | (close-output-port out) 38 | (open-input-bytes (get-output-bytes out)))))) 39 | 40 | (define-syntax define-who 41 | (lambda (x) 42 | (syntax-case x () 43 | [(k name e) 44 | (with-syntax ([who (datum->syntax #'k 'who)]) 45 | #'(define name 46 | (let () 47 | (define who 'name) 48 | e)))] 49 | [(k (name . args) body0 body1 ...) 50 | (with-syntax ([who (datum->syntax #'k 'who)]) 51 | #'(define name 52 | (let () 53 | (define who 'name) 54 | (lambda args body0 body1 ...))))]))) 55 | 56 | ;; thoughts on how some of this fits into a cesk machine. 57 | ;; prefix: maybe this is some funky form of environment---we lookup syntax, 58 | ;; module, and top-level definitions from here. 59 | (define-who bytecode->cesk 60 | (lambda (bc) 61 | (let ([ht (make-hasheq)]) 62 | (let loop ([bc bc]) 63 | (when (zo? bc) 64 | (when (hash-ref ht bc #f) 65 | (error who "encountered cycle in code, hit ~s twice" bc)) 66 | (hash-set! ht bc #t)) 67 | (match bc 68 | [(struct compilation-top (max-let-depth prefix code)) ; top level of compilation 69 | ;; currently discarding the prefix---probably will need to determine how to incorporate 70 | (loop code)] 71 | [(struct prefix (num-lifts toplevels stxs)) ; prefix loaded into stack before running associated code 72 | ;; not sure what to do (yet) with prefix 73 | (error who "currently not processing prefixes, but found (prefix ~s ~s ~s)" 74 | num-lifts toplevels stxs)] 75 | [(struct global-bucket (name)) ; element of prefix to represent global variables 76 | ;; should only appear inside prefix, and not handling prefix yet 77 | (error who "currently not processing prefixes, but found (global-bucket ~s), which can only appear in prefix" 78 | name)] 79 | [(struct module-variable (modidx sym pos phase)) ; element of prefix to rerpresent variable from imported module (I think) 80 | ;; should only appear inside prefix, and not handling prefix yet 81 | (error who "currently not processing prefixes, but found (module-variable ~s ~s ~s ~s), which can only appear in prefix" 82 | modidx sym pos phase)] 83 | [(struct stx (encoded)) ; element of prefix (or req) used to indicate syntax put into the initial stack (from a module require?) 84 | ;; should only appear inside prefix, and not handling prefix yet 85 | (error who "currently not processing prefixes, but found (stx ~s), which can only appear in prefix" 86 | encoded)] 87 | [(struct def-values (ids rhs)) ; define values handler 88 | (loop rhs)] 89 | [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) ; define syntax 90 | (loop rhs)] 91 | [(struct seq-for-syntax (forms prefix max-let-depth dummy)) 92 | (for-each loop forms)] 93 | [(struct req (reqs dummy)) #f] 94 | [(struct seq (forms)) 95 | (for-each loop forms)] 96 | [(struct splice (forms)) 97 | (for-each loop forms)] 98 | [(struct inline-variant (direct inline)) 99 | (loop direct) 100 | (loop inline)] 101 | [(struct mod (name srcname self-modidx prefix provides requires body 102 | syntax-bodies unexported max-let-depth dummy lang-info 103 | internal-context pre-submodules post-submodules)) 104 | (for-each loop body)] 105 | [(struct provided (name src src-name nom-src src-phase protected?)) 106 | ;; currently not tracking provided from mod 107 | (error who "currently not processing provide lists, but found (provided ~s ~s ~s ~s ~s ~s)" 108 | name src src-name nom-src src-phase protected?)] 109 | [(struct lam (name flags num-params param-types rest? closure-map 110 | closure-types toplevel-map max-let-depth body)) 111 | (loop body)] 112 | [(struct closure (code gen-id)) 113 | (loop code)] 114 | [(struct case-lam (name clauses)) 115 | (for-each loop clauses)] 116 | [(struct let-one (rhs body flonum? unused?)) 117 | (loop rhs) 118 | (loop body)] 119 | [(struct let-void (count boxes? body)) 120 | (loop body)] 121 | [(struct install-value (count pos boxes? rhs body)) 122 | (loop rhs) 123 | (loop body)] 124 | [(struct let-rec (procs body)) 125 | (for-each loop procs) 126 | (loop body)] 127 | [(struct boxenv (pos body)) 128 | (loop body)] 129 | [(struct localref (unbox? pos clear? other-clears? flonum?)) #f] 130 | [(struct toplevel (depth pos const? ready?)) #f] 131 | [(struct topsyntax (depth pos midpt)) #f] 132 | [(struct application (rator rands)) 133 | (loop rator) 134 | (for-each loop rands)] 135 | [(struct branch (test then else)) 136 | (loop test) 137 | (loop then) 138 | (loop else)] 139 | [(struct with-cont-mark (key val body)) 140 | (loop key) 141 | (loop val) 142 | (loop body)] 143 | [(struct beg0 (seq)) 144 | (for-each loop seq)] 145 | [(struct varref (toplevel dummy)) #f] 146 | [(struct assign (id rhs undef-ok?)) 147 | (loop rhs)] 148 | [(struct apply-values (proc args-expr)) 149 | (loop proc) 150 | (loop args-expr)] 151 | [(struct primval (id)) #f] 152 | [(struct wrapped (datum wraps tamper-status)) #f] 153 | [(struct top-level-rename (flag)) #f] 154 | [(struct mark-barrier (value)) #f] 155 | [(struct free-id-info (path0 symbol0 path1 symbol1 phase0 phase1 phase2 156 | use-current-inspector?)) 157 | #f] 158 | [(struct lexical-rename (has-free-id-info? bool2 alist)) #f] 159 | [(struct phase-shift (amt src dest cancel-id)) #f] 160 | [(struct module-rename (phase kind set-id unmarshals rename mark-renames plus-kern?)) 161 | #f] 162 | [(struct all-from-module (path phase src-phase exceptions prefix context)) 163 | #f] 164 | [(struct simple-module-binding (path)) 165 | #f] 166 | [(struct phased-module-binding (path phase export-name nominal-path nominal-export-name)) 167 | #f] 168 | [(struct exported-nominal-module-binding (path export-name nominal-path nominal-export-name)) 169 | #f] 170 | [(struct nominal-module-binding (path nominal-path)) 171 | #f] 172 | [(struct exported-module-binding (path export-name)) 173 | #f] 174 | [(struct simple-nominal-path (value)) 175 | #f] 176 | [(struct imported-nominal-path (value import-phase)) 177 | #f] 178 | [(struct phased-nominal-path (value import-phase phase)) 179 | #f] 180 | [_ (printf "bytecode->cesk encountered ~s\n" bc)]))))) 181 | 182 | (provide zo-file->bytecode source->bytecode source-file->bytecode bytecode->cesk) 183 | 184 | --------------------------------------------------------------------------------