├── .gitignore ├── Compiler ├── .gitignore ├── assign-frame.ss ├── assign-new-frame.ss ├── assign-registers.ss ├── common.ss ├── compile.ss ├── convert-assignments.ss ├── convert-closures.ss ├── convert-complex-datum.ss ├── discard-call-live.ss ├── everybody-home.ss ├── expose-allocation-pointer.ss ├── expose-basic-blocks.ss ├── expose-frame-var.ss ├── expose-memory-operands.ss ├── finalize-frame-locations.ss ├── finalize-locations.ss ├── flatten-program.ss ├── flatten-set!.ss ├── generate-x86-64.ss ├── impose-calling-conventions.ss ├── introduce-procedure-primitives.ss ├── lift-letrec.ss ├── normalize-context.ss ├── optimize-direct-call.ss ├── optimize-jumps.ss ├── optimize-known-call.ss ├── optimize-source.ss ├── parse-scheme.ss ├── pmunit.ss ├── pre-assign-frame.ss ├── purify-letrec.ss ├── remove-anonymous-lambda.ss ├── remove-complex-opera*.ss ├── remove-let.ss ├── sanitize-binding-forms.ss ├── select-instructions.ss ├── specify-representation.ss ├── uncover-assigned.ss ├── uncover-frame-conflict.ss ├── uncover-free.ss ├── uncover-locals.ss ├── uncover-register-conflict.ss ├── utils.ss └── verify-uil.ss ├── CompilerHs ├── Compile.hs └── VerifyScheme.hs ├── Framework ├── driver.ss ├── fmts.pretty ├── helpers.ss ├── match.ss ├── nanopass.chezscheme.sls ├── nanopass.ss ├── nanopass │ ├── helpers.ss │ ├── implementation-helpers.chezscheme.sls │ ├── implementation-helpers.ikarus.ss │ ├── implementation-helpers.vicare.sls │ ├── language-helpers.ss │ ├── language-node-counter.ss │ ├── language.ss │ ├── meta-parser.ss │ ├── meta-syntax-dispatch.ss │ ├── nano-syntax-dispatch.ss │ ├── parser.ss │ ├── pass.ss │ ├── records.ss │ ├── syntaxconvert.ss │ └── unparser.ss ├── prims.ss ├── runtime.c ├── testing.ss ├── testing.ss.bak ├── wrappers.ss └── wrappers.ss.old ├── FrameworkHs ├── Driver.hs ├── Helpers.hs ├── ParseL01.hs ├── Prims.hs ├── SExpReader │ ├── LispData.hs │ └── Parser.hs └── Testing.hs ├── GrammarCompiler ├── common │ ├── aux.ss │ ├── desugar-directives.ss │ └── match.ss ├── haskell │ ├── assign-tags.ss │ ├── derive-parsing.ss │ ├── derive-printing.ss │ ├── emit-haskell.ss │ ├── flatten-datatypes.ss │ └── lift-prints.ss ├── main.ss └── scheme │ ├── emit-scheme.ss │ └── generate-verify.ss ├── Makefile ├── README.md ├── p423-compiler.cabal ├── scripts ├── LoadAndTest.hi ├── LoadAndTest.hs ├── LoadAndTest.o ├── compile_grammars.ss └── load_and_test.ss ├── source-grammar.ss └── test-suite.ss /.gitignore: -------------------------------------------------------------------------------- 1 | *.bak 2 | *.o 3 | *.hi 4 | \#*\# 5 | .\#* 6 | *~ 7 | t 8 | t.s 9 | *_flymake.hs 10 | .virthualenv 11 | dist 12 | -------------------------------------------------------------------------------- /Compiler/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/keyz/p423-compiler/5efe33f128d6d4b3decb818f315d9f14781cc241/Compiler/.gitignore -------------------------------------------------------------------------------- /Compiler/assign-frame.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A8 - Mar 6, 2015 4 | 5 | pass: assign-frame 6 | 7 | Input Grammar: 8 | Program ::= (letrec ((Label (lambda () Body)) *) Body) 9 | Body ::= (locals (UVar *) 10 | (ulocals (UVar *) 11 | (spills (UVar *) 12 | (locate ((UVar FVar) *) 13 | (frame-conflict ((UVar Var *) *) 14 | Tail))))) 15 | | (locate ((UVar Loc) *) Tail) 16 | Tail ::= (if Pred Tail Tail) 17 | | (begin Effect * Tail) 18 | | (Triv Loc *) 19 | Pred ::= (true) 20 | | (false) 21 | | (if Pred Pred Pred) 22 | | (begin Effect * Pred) 23 | | (Relop Triv Triv) 24 | Effect ::= (nop) 25 | | (set! Var Triv) 26 | | (set! Var (Binop Triv Triv)) 27 | | (set! Var (mref Triv Triv)) ;; a8 new 28 | | (return-point Label Tail) 29 | | (mset! Triv Triv Triv) ;; a8 new 30 | | (if Pred Effect Effect) 31 | | (begin Effect * Effect) 32 | Triv ::= Var 33 | | Integer | Label 34 | Loc ::= Reg | FVar 35 | Var ::= UVar | Loc 36 | 37 | 38 | Output Grammar (same as `assign-new-frame`): 39 | Program ::= (letrec ((Label (lambda () Body)) *) Body) 40 | Body ::= (locals (UVar *) ;; mod 41 | (ulocals (UVar *) 42 | (locate ((UVar FVar) *) 43 | (frame-conflict ((UVar Var *) *) 44 | Tail)))) 45 | | (locate ((UVar Loc) *) Tail) 46 | Tail ::= (if Pred Tail Tail) 47 | | (begin Effect * Tail) 48 | | (Triv Var *) ;; Note 'Var' not 'Loc'. ;; mod 49 | Pred ::= (true) 50 | | (false) 51 | | (if Pred Pred Pred) 52 | | (begin Effect * Pred) 53 | | (Relop Triv Triv) 54 | Effect ::= (nop) 55 | | (set! Var Triv) 56 | | (set! Var (Binop Triv Triv)) 57 | | (set! Var (mref Triv Triv)) ;; a8 new 58 | | (return-point Label Tail) 59 | | (mset! Triv Triv Triv) ;; a8 new 60 | | (if Pred Effect Effect) 61 | | (begin Effect * Effect) 62 | Triv ::= Var 63 | | Integer | Label 64 | Loc ::= Reg | FVar 65 | Var ::= UVar | Loc 66 | 67 | |# 68 | 69 | 70 | (library (Compiler assign-frame) 71 | (export assign-frame) 72 | (import 73 | (chezscheme) 74 | (Framework helpers) 75 | (Framework match)) 76 | 77 | (define-who assign-frame 78 | (define find-used 79 | (lambda (conflict* home*) 80 | (cond 81 | [(null? conflict*) '()] 82 | [(frame-var? (car conflict*)) 83 | (set-cons (car conflict*) (find-used (cdr conflict*) home*))] 84 | [(assq (car conflict*) home*) => 85 | (lambda (x) (set-cons (cadr x) (find-used (cdr conflict*) home*)))] 86 | [else (find-used (cdr conflict*) home*)]))) 87 | 88 | (define find-frame-var 89 | (lambda (used*) 90 | (let f ([index 0]) 91 | (let ([fv (index->frame-var index)]) 92 | (if (memq fv used*) (f (+ index 1)) fv))))) 93 | 94 | (define find-homes 95 | (lambda (var* ct home*) 96 | (if (null? var*) 97 | home* 98 | (let ([var (car var*)] [var* (cdr var*)]) 99 | (let ([conflict* (cdr (assq var ct))]) 100 | (let ([home (find-frame-var (find-used conflict* home*))]) 101 | (find-homes var* ct `((,var ,home) . ,home*)))))))) 102 | 103 | (define Body 104 | (lambda (body) 105 | (match body 106 | [(locals (,local* ...) 107 | (ulocals (,ulocal* ...) 108 | (spills (,spill* ...) 109 | (locate (,home* ...) 110 | (frame-conflict ,ct ,tail))))) 111 | (let ([home* (find-homes spill* ct home*)]) 112 | `(locals (,local* ...) 113 | (ulocals (,ulocal* ...) 114 | (locate (,home* ...) 115 | (frame-conflict ,ct ,tail)))))] 116 | [(locate (,home* ...) ,body) `(locate (,home* ...) ,body)] 117 | [,body (error who "invalid Body ~s" body)]))) 118 | 119 | (lambda (x) 120 | (match x 121 | [(letrec ([,label* (lambda () ,[Body -> body*])] ...) ,[Body -> body]) 122 | `(letrec ([,label* (lambda () ,body*)] ...) ,body)] 123 | [,x (error who "invalid Program ~s" x)]))) 124 | 125 | ) 126 | -------------------------------------------------------------------------------- /Compiler/common.ss: -------------------------------------------------------------------------------- 1 | (library (Compiler common) 2 | (export 3 | immediate-with-d? 4 | immediate? 5 | binop? 6 | relop? 7 | triv? 8 | primitives 9 | value-prim? 10 | pred-prim? 11 | effect-prim? 12 | prim?) 13 | 14 | (import (chezscheme) (Framework match) (Framework helpers)) 15 | 16 | (define (immediate-with-d? imm) 17 | (or (immediate? imm) 18 | (pair? imm) 19 | (vector? imm))) 20 | 21 | (define (immediate? imm) 22 | (or (memq imm '(#t #f ())) 23 | (and (integer? imm) 24 | (exact? imm) 25 | (fixnum-range? imm)))) 26 | 27 | (define (binop? x) 28 | (memq x '(mref + - * logand logor sra))) 29 | 30 | (define (relop? x) 31 | (memq x '(< > <= >= =))) 32 | 33 | (define (triv? t) 34 | (or (uvar? t) 35 | (label? t) 36 | (int64? t))) 37 | 38 | (define primitives 39 | '((+ . 2) (- . 2) (* . 2) (<= . 2) (< . 2) (= . 2) 40 | (>= . 2) (> . 2) (boolean? . 1) (car . 1) (cdr . 1) 41 | (cons . 2) (eq? . 2) (fixnum? . 1) (make-vector . 1) 42 | (null? . 1) (pair? . 1) (set-car! . 2) (set-cdr! . 2) 43 | (vector? . 1) (vector-length . 1) (vector-ref . 2) 44 | (vector-set! . 3) (void . 0))) 45 | 46 | (define (value-prim? x) 47 | (or (memq x '(+ - * car cdr cons make-vector vector-length vector-ref void)) 48 | (memq x '(make-procedure procedure-code procedure-ref)))) 49 | 50 | (define (pred-prim? x) 51 | (or (memq x '(< <= = >= > boolean? eq? fixnum? null? pair? vector?)) 52 | (memq x '(procedure?)))) 53 | 54 | (define (effect-prim? x) 55 | (or (memq x '(set-car! set-cdr! vector-set!)) 56 | (memq x '(procedure-set!)))) 57 | 58 | (define (prim? x) 59 | (or (value-prim? x) 60 | (pred-prim? x) 61 | (effect-prim? x) 62 | (eq? x 'procedure?) 63 | (memq x '(make-procedure procedure-code procedure-ref procedure-set!)))) 64 | 65 | ) 66 | -------------------------------------------------------------------------------- /Compiler/compile.ss: -------------------------------------------------------------------------------- 1 | (library (Compiler compile) 2 | (export p423-compile p423-step) 3 | (import 4 | (chezscheme) 5 | (Framework driver) 6 | (Framework wrappers) 7 | (Framework match) 8 | (Framework helpers) 9 | (Compiler parse-scheme) 10 | (Compiler convert-complex-datum) 11 | (Compiler uncover-assigned) 12 | (Compiler purify-letrec) 13 | (Compiler convert-assignments) 14 | (Compiler optimize-direct-call) 15 | (Compiler remove-anonymous-lambda) 16 | (Compiler sanitize-binding-forms) 17 | (Compiler uncover-free) 18 | (Compiler convert-closures) 19 | (Compiler optimize-known-call) 20 | (Compiler introduce-procedure-primitives) 21 | (Compiler optimize-source) 22 | (Compiler lift-letrec) 23 | (Compiler normalize-context) 24 | (Compiler specify-representation) 25 | (Compiler uncover-locals) 26 | (Compiler remove-let) 27 | (Compiler verify-uil) 28 | (Compiler remove-complex-opera*) 29 | (Compiler flatten-set!) 30 | (Compiler impose-calling-conventions) 31 | (Compiler expose-allocation-pointer) 32 | (Compiler uncover-frame-conflict) 33 | (Compiler pre-assign-frame) 34 | (Compiler assign-new-frame) 35 | (Compiler select-instructions) 36 | (Compiler uncover-register-conflict) 37 | (Compiler assign-registers) 38 | (Compiler everybody-home) 39 | (Compiler assign-frame) 40 | (Compiler finalize-frame-locations) 41 | (Compiler discard-call-live) 42 | (Compiler finalize-locations) 43 | (Compiler expose-frame-var) 44 | (Compiler expose-memory-operands) 45 | (Compiler expose-basic-blocks) 46 | (Compiler optimize-jumps) 47 | (Compiler flatten-program) 48 | (Compiler generate-x86-64)) 49 | 50 | (define (assemble thunk) 51 | (with-output-to-file "t.s" 52 | thunk 53 | 'replace) 54 | (unless (zero? (system "cc -m64 -o t t.s Framework/runtime.c")) 55 | (error 'assemble "assembly failed")) 56 | "./t") 57 | 58 | (define-compiler (p423-compile p423-step pass->wrapper) 59 | (parse-scheme) 60 | (convert-complex-datum) 61 | (uncover-assigned) 62 | (purify-letrec) 63 | (convert-assignments) 64 | (optimize-direct-call) 65 | (remove-anonymous-lambda) 66 | (sanitize-binding-forms) 67 | (uncover-free) 68 | (convert-closures) 69 | (optimize-known-call) 70 | (introduce-procedure-primitives) 71 | (optimize-source) 72 | (lift-letrec) 73 | (normalize-context) 74 | (specify-representation) 75 | (uncover-locals) 76 | (remove-let) 77 | (verify-uil) 78 | (remove-complex-opera*) 79 | (flatten-set!) 80 | (impose-calling-conventions) 81 | (expose-allocation-pointer) 82 | (uncover-frame-conflict) 83 | (pre-assign-frame) 84 | (assign-new-frame) 85 | (iterate 86 | (finalize-frame-locations) 87 | (select-instructions) 88 | (uncover-register-conflict) 89 | (assign-registers) 90 | (break/when everybody-home?) 91 | (assign-frame)) 92 | (discard-call-live) 93 | (finalize-locations) 94 | (expose-frame-var) 95 | (expose-memory-operands) 96 | (expose-basic-blocks) 97 | (optimize-jumps) 98 | (flatten-program) 99 | (generate-x86-64 assemble)) 100 | 101 | 102 | ) 103 | -------------------------------------------------------------------------------- /Compiler/convert-assignments.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A14 - Apr 18, 2014 4 | 5 | pass: convert-assignments 6 | This pass eliminates set! expressions and assigned variables. 7 | 1. introduces a let expression binding each assigned variable to a freshly allocated pair whose car is the original value of the variable 8 | 2. replaces each reference to an assigned variable with a call to car 9 | 3. replaces each assignment with a call to set-car! 10 | 11 | 1. 12 | (assigned (x ...) expr) -> 13 | (let ((x (cons t (void))) ...) expr) 14 | 15 | and replace the binding of x by the enclosing lambda or let expression with an identical binding for t, where each t is a new unique name. 16 | 17 | 2. 18 | Replace each reference x to an assigned variable with (car x) 19 | 20 | 3. 21 | Replace each assignment (set! x e) 22 | 23 | with (set-car! x e) 24 | 25 | Input: 26 | Prog ::= Expr 27 | Expr ::= (quote Immediate) 28 | | (let ([UVar Expr] *) Body) 29 | | (letrec ([UVar Lamb] *) Body) 30 | | (if Expr Expr Expr) 31 | | (begin Expr * Expr) 32 | | (set! UVar Expr) 33 | | (ValPrim Expr *) 34 | | (EffectPrim Expr *) 35 | | (PredPrim Expr *) 36 | | (Expr Expr *) 37 | | UVar 38 | Lamb ::= (lambda (UVar *) Body) 39 | Body ::= (assigned (UVar *) Expr) 40 | Datum ::= Immediate | (Datum *) | #(Datum *) 41 | Immediate ::= fixnum | () | #t | #f 42 | 43 | Output: 44 | Prog ::= Expr 45 | Expr ::= (quote Immediate) 46 | | (let ([UVar Expr] *) Expr) ;; mod 47 | | (letrec ([UVar Lamb] *) Expr) ;; mod 48 | | (if Expr Expr Expr) 49 | | (begin Expr * Expr) 50 | | (ValPrim Expr *) 51 | | (EffectPrim Expr *) 52 | | (PredPrim Expr *) 53 | | (Expr Expr *) 54 | | UVar 55 | Lamb ::= (lambda (UVar *) Expr) ;; mod 56 | Datum ::= Immediate | (Datum *) | #(Datum *) 57 | Immediate ::= fixnum | () | #t | #f 58 | 59 | |# 60 | 61 | 62 | 63 | (library (Compiler convert-assignments) 64 | (export convert-assignments) 65 | (import 66 | (chezscheme) 67 | (Framework match) 68 | (Framework helpers) 69 | (Compiler utils) 70 | (Compiler common)) 71 | 72 | (define-who convert-assignments 73 | 74 | (define foldl 75 | (lambda (f n ls) 76 | (cond 77 | [(null? ls) n] 78 | [else (foldl f (f n (car ls)) (cdr ls))]))) 79 | 80 | (define (Expr as-ls) 81 | (lambda (e) 82 | (match e 83 | [(quote ,d) (guard (immediate-with-d? d)) 84 | `(quote ,d)] 85 | [(let ([,uvar* ,[expr*]] ...) 86 | (assigned ,asv* 87 | ,[(Expr (append asv* as-ls)) -> expr])) 88 | (let-values ([(new-uvar* binds*) (gen-bindings uvar* asv*)]) 89 | (cond 90 | [(null? binds*) 91 | `(let ([,new-uvar* ,expr*] ...) ,expr)] 92 | [else 93 | `(let ([,new-uvar* ,expr*] ...) (let ,binds* ,expr))]))] 94 | [(letrec ([,uvar* ,[lamb*]] ...) ,[expr]) 95 | `(letrec ([,uvar* ,lamb*] ...) ,expr)] 96 | [(lambda (,uvar* ...) 97 | (assigned ,asv* 98 | ,[(Expr (append asv* as-ls)) -> expr])) 99 | (let-values ([(new-uvar* binds*) (gen-bindings uvar* asv*)]) 100 | (cond 101 | [(null? binds*) 102 | `(lambda (,new-uvar* ...) ,expr)] 103 | [else 104 | `(lambda (,new-uvar* ...) (let ,binds* ,expr))]))] 105 | [(if ,[test] ,[then] ,[else]) 106 | `(if ,test ,then ,else)] 107 | [(begin ,[expr*] ... ,[expr]) 108 | (make-begin `(,expr* ... ,expr))] 109 | [(set! ,uvar ,[expr]) 110 | (if (memq uvar as-ls) 111 | `(set-car! ,uvar ,expr) 112 | `(set! ,uvar ,expr))] 113 | [(,prim ,[expr*] ...) (guard (prim? prim)) 114 | `(,prim ,expr* ...)] 115 | [(,[rator] ,[rand*] ...) 116 | `(,rator ,rand* ...)] 117 | [,uvar (guard (uvar? uvar)) 118 | (if (memq uvar as-ls) 119 | `(car ,uvar) 120 | uvar)] 121 | [,el (errorf who "Invalid Expr ~s" el)]))) 122 | 123 | (define (gen-bindings uvar* asv*) 124 | (cond 125 | [(null? asv*) (values uvar* '())] 126 | [else 127 | (let* ([table (map (lambda (x) 128 | (cons x 129 | (unique-name (string->symbol (extract-root x))))) 130 | asv*)] 131 | [new-uvar* (map (lambda (x) 132 | (if (assq x table) 133 | (cdr (assq x table)) 134 | x)) 135 | uvar*)] 136 | [binds* (map (lambda (x) 137 | `[,(car x) (cons ,(cdr x) (void))]) 138 | table)]) 139 | (values new-uvar* binds*))])) 140 | 141 | (lambda (prog) 142 | ((Expr '()) prog))) 143 | ) 144 | 145 | -------------------------------------------------------------------------------- /Compiler/convert-closures.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A12 - Apr 09, 2015 4 | 5 | pass: convert-closures 6 | 7 | This pass converts lambda expressions with free variables into lambda expressions without free variables and makes explicit the representation of each procedure as a closure that encapsulates a pointer to the procedure's code and the values of its free variables: 8 | 9 | before: 10 | (letrec ([name.n 11 | (lambda (x ...) 12 | (free (fx ...) 13 | lambda-body))] 14 | ...) 15 | letrec-body) 16 | 17 | after: 18 | (letrec ([name$n 19 | (lambda (cp x ...) 20 | (bind-free (cp fx ...) 21 | lambda-body))] 22 | ...) 23 | (closures ([name.n name$n fx ...] ...) 24 | letrec-body)) 25 | 26 | As a summary, 27 | 1. `cp` will be added as the first parameter to each `lambda` exp 28 | 2. replacing the variables that the input-language letrec expression binds with labels 29 | 3. introducing a closures form within each letrec expression that creates a closure for each lambda expression, implicitly storing within the closure a pointer to the code (obtained via the code's new label) and the values of its free variables; and 30 | 4. converting each procedure call to pass along the closure as an explicit additional argument. 31 | 32 | Input: 33 | Prog ::= Expr 34 | Expr ::= (quote Immediate) 35 | | (let ([UVar Expr]*) Expr) 36 | | (letrec ((UVar (lambda (UVar *) (free (UVar *) Expr))) *) Expr) 37 | | (if Expr Expr Expr) 38 | | (begin Expr * Expr) 39 | | (ValPrim Expr *) 40 | | (EffectPrim Expr *) 41 | | (PredPrim Expr *) 42 | | (Expr Expr *) 43 | | UVar 44 | Immediate ::= fixnum | () | #t | #f 45 | 46 | Output: 47 | Prog ::= Expr 48 | Expr ::= (quote Immediate) 49 | | (let ([UVar Expr]*) Expr) 50 | | (letrec ((Label (lambda (UVar *) 51 | (bind-free (UVar *) Expr))) *) 52 | (closures ((UVar Label UVar *) *) Expr)) ;; new 53 | | (if Expr Expr Expr) 54 | | (begin Expr * Expr) 55 | | (ValPrim Expr *) 56 | | (EffectPrim Expr *) 57 | | (PredPrim Expr *) 58 | | (Expr Expr *) 59 | | UVar 60 | | Label ;; new 61 | Immediate ::= fixnum | () | #t | #f 62 | 63 | |# 64 | 65 | (library (Compiler convert-closures) 66 | (export convert-closures) 67 | (import 68 | (chezscheme) 69 | (Framework match) 70 | (Framework helpers) 71 | (Compiler utils) 72 | (Compiler common)) 73 | 74 | (define-who convert-closures 75 | 76 | (define (immediate? imm) 77 | (or (memq imm '(#t #f ())) 78 | (and (integer? imm) 79 | (exact? imm) 80 | (fixnum-range? imm)))) 81 | 82 | ;; for each uvar: generate a corresponding label 83 | (define (&label x) 84 | (values x (unique-label x))) 85 | 86 | ;; for each list of free vars -- i.e., (a.1 b.2 c.3): 87 | ;; return the list itself and a new cp 88 | (define (&cp x) 89 | (values x (unique-name 'cp))) 90 | 91 | (define (Expr expr) 92 | (match expr 93 | [(quote ,i) (guard (immediate? i)) 94 | `(quote ,i)] 95 | [(let ([,uvar* ,[exp*]] ...) ,[exp]) 96 | `(let ([,uvar* ,exp*] ...) ,exp)] 97 | [(letrec 98 | ([,[&label -> uvar* label*] 99 | (lambda (,arg* ...) 100 | (free ,[&cp -> freev* cp*] ,[exp*]))] ...) ,[exp]) 101 | `(letrec 102 | ([,label* 103 | (lambda (,cp* ,arg* ...) 104 | (bind-free (,cp* ,freev* ...) ,exp*))] ...) 105 | (closures ([,uvar* ,label* ,freev* ...] ...) ,exp))] 106 | [(if ,[test] ,[then] ,[else]) 107 | `(if ,test ,then ,else)] 108 | [(begin ,[exp*] ... ,[exp]) 109 | `(begin ,exp* ... ,exp)] 110 | [(,prim ,[exp*] ...) (guard (prim? prim)) 111 | `(,prim ,exp* ...)] 112 | [(,[rator] ,[rand*] ...) 113 | (cond 114 | [(uvar? rator) `(,rator ,rator ,rand* ...)] 115 | [else (let ([tmp (unique-name 'tmp)]) 116 | `(let ([,tmp ,rator]) 117 | (,tmp ,tmp ,rand* ...)))])] 118 | [,uvar (guard (uvar? uvar)) uvar] 119 | [,el (errorf who "Invalid Expr ~s" el)])) 120 | 121 | (lambda (prog) 122 | (Expr prog))) 123 | ) 124 | -------------------------------------------------------------------------------- /Compiler/convert-complex-datum.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A14 - Apr 18, 2014 4 | 5 | pass: convert-complex-datum 6 | 7 | This pass converts quoted pairs and vectors into code that builds them using cons and make-vector. 8 | 9 | e.g., 10 | '(1 (2 (3 4 5))) -> 11 | (cons '1 (cons (cons '2 (cons (cons '3 (cons '4 (cons '5 '()))) '())) '())) 12 | 13 | '#(32 (33 33) 34) -> 14 | (let ([tmp.1 (make-vector '3)]) 15 | (begin 16 | (vector-set! tmp.1 '0 '32) 17 | (vector-set! tmp.1 '1 (cons '33 (cons '33 '()))) 18 | (vector-set! tmp.1 '2 '34) 19 | tmp.1)) 20 | 21 | Moreover, it binds a new variable to the result of building the structure and reference the new variable in place of the quoted constant, such that the pair is created only once as desired. 22 | 23 | e.g., 24 | (let ([f.1 (lambda () '(1 . 2))]) 25 | (eq? (f.1) (f.1))) -> 26 | (let ([tmp.2 (cons '1 '2)]) 27 | (let ([f.1 (lambda () tmp.2)]) 28 | (eq? (f.1) (f.1)))) 29 | 30 | Input: 31 | Prog ::= Expr 32 | Expr ::= (quote Datum) 33 | | (let ([UVar Expr] *) Body) 34 | | (letrec ([UVar Expr] *) Body) 35 | | (lambda (UVar *) Body) 36 | | (if Expr Expr Expr) 37 | | (begin Expr * Expr) 38 | | (set! UVar Expr) 39 | | (ValPrim Expr *) 40 | | (EffectPrim Expr *) 41 | | (PredPrim Expr *) 42 | | (Expr Expr *) 43 | | UVar 44 | Body ::= Expr 45 | Datum ::= Immediate | (Datum *) | #(Datum *) 46 | Immediate ::= fixnum | () | #t | #f 47 | 48 | Output: 49 | Prog ::= Expr 50 | Expr ::= (quote Immediate) ;; mod 51 | | (let ([UVar Expr] *) Body) 52 | | (letrec ([UVar Expr] *) Body) 53 | | (lambda (UVar *) Body) 54 | | (if Expr Expr Expr) 55 | | (begin Expr * Expr) 56 | | (set! UVar Expr) 57 | | (ValPrim Expr *) 58 | | (EffectPrim Expr *) 59 | | (PredPrim Expr *) 60 | | (Expr Expr *) 61 | | UVar 62 | Body ::= Expr 63 | Datum ::= Immediate | (Datum *) | #(Datum *) 64 | Immediate ::= fixnum | () | #t | #f 65 | 66 | |# 67 | 68 | (library (Compiler convert-complex-datum) 69 | (export convert-complex-datum) 70 | (import 71 | (chezscheme) 72 | (Framework match) 73 | (Framework helpers) 74 | (Compiler utils) 75 | (Compiler common)) 76 | 77 | (define-who convert-complex-datum 78 | 79 | (define lets '()) 80 | 81 | (define (gen-vector target max ls) 82 | (let loop ([n 0] [ls ls] [acc '()]) 83 | (cond 84 | [(= n max) (reverse (cons target acc))] 85 | [else (loop (add1 n) 86 | (cdr ls) 87 | (cons `(vector-set! ,target (quote ,n) ,(car ls)) acc))]))) 88 | 89 | (define (Datum d) 90 | (match d 91 | [,i (guard (immediate? i)) `(quote ,i)] 92 | [(,[a] . ,[d]) `(cons ,a ,d)] 93 | [#(,[v*] ...) 94 | (let ([tmp (unique-name 'tmp)] 95 | [len (length v*)] 96 | [ls `(,v* ...)]) 97 | `(let ([,tmp (make-vector (quote ,len))]) 98 | (begin ,@(gen-vector tmp len ls))))])) 99 | 100 | (define (Expr expr) 101 | (match expr 102 | [(quote ,d) (guard (immediate? d)) 103 | `(quote ,d)] 104 | [(quote ,d) ;; (guard (or (pair? d) (vector? d))) 105 | (let ([tmp (unique-name 'tmp)]) 106 | (set! lets (cons `[,tmp ,(Datum d)] lets)) 107 | tmp)] 108 | [(let ([,uvar* ,[exp*]] ...) ,[exp]) 109 | `(let ([,uvar* ,exp*] ...) ,exp)] 110 | [(letrec ([,uvar* ,[exp*]] ...) ,[exp]) 111 | `(letrec ([,uvar* ,exp*] ...) ,exp)] 112 | [(lambda (,uvar* ...) ,[body]) 113 | `(lambda (,uvar* ...) ,body)] 114 | [(if ,[test] ,[then] ,[else]) 115 | `(if ,test ,then ,else)] 116 | [(begin ,[exp*] ... ,[exp]) 117 | `(begin ,exp* ... ,exp)] 118 | [(set! ,uvar ,[exp]) 119 | `(set! ,uvar ,exp)] 120 | [(,prim ,[exp*] ...) (guard (prim? prim)) 121 | `(,prim ,exp* ...)] 122 | [(,[rator] ,[rand*] ...) 123 | `(,rator ,rand* ...)] 124 | [,uvar (guard (uvar? uvar)) uvar] 125 | [,el (errorf who "Invalid Expr ~s" el)])) 126 | 127 | (lambda (prog) 128 | (set! lets '()) 129 | (let ([result (Expr prog)]) 130 | `(let ,lets ,result)))) 131 | ) 132 | -------------------------------------------------------------------------------- /Compiler/discard-call-live.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A8 - Mar 6, 2015 4 | 5 | pass: discard-call-live 6 | 7 | This pass discards the Loc* list included in each call. 8 | 9 | Input Grammar: 10 | Program ::= (letrec ((Label (lambda () Body)) *) Body) 11 | Body ::= (locals (UVar *) 12 | (ulocals (UVar *) 13 | (spills (UVar *) 14 | (locate ((UVar FVar) *) 15 | (frame-conflict ((UVar Var *) *) 16 | Tail))))) 17 | | (locate ((UVar Loc) *) Tail) 18 | Tail ::= (if Pred Tail Tail) 19 | | (begin Effect * Tail) 20 | | (Triv Loc *) 21 | Pred ::= (true) 22 | | (false) 23 | | (if Pred Pred Pred) 24 | | (begin Effect * Pred) 25 | | (Relop Triv Triv) 26 | Effect ::= (nop) 27 | | (set! Var Triv) 28 | | (set! Var (Binop Triv Triv)) 29 | | (set! Var (mref Triv Triv)) ;; a8 new 30 | | (return-point Label Tail) 31 | | (mset! Triv Triv Triv) ;; a8 new 32 | | (if Pred Effect Effect) 33 | | (begin Effect * Effect) 34 | Triv ::= Var 35 | | Integer | Label 36 | Loc ::= Reg | FVar 37 | Var ::= UVar | Loc 38 | 39 | Output Grammar: 40 | Program ::= (letrec ((Label (lambda () Body)) *) Body) 41 | Body ::= (locate ((UVar Loc) *) Tail) 42 | Tail ::= (if Pred Tail Tail) 43 | | (begin Effect * Tail) 44 | | (Triv) ;; mod 45 | Pred ::= (true) 46 | | (false) 47 | | (if Pred Pred Pred) 48 | | (begin Effect * Pred) 49 | | (Relop Triv Triv) 50 | Effect ::= (nop) 51 | | (set! Var Triv) 52 | | (set! Var (Binop Triv Triv)) 53 | | (set! Var (mref Triv Triv)) ;; a8 new 54 | | (return-point Label Tail) 55 | | (mset! Triv Triv Triv) ;; a8 new 56 | | (if Pred Effect Effect) 57 | | (begin Effect * Effect) 58 | Triv ::= Var 59 | | Integer | Label 60 | Loc ::= Reg | FVar 61 | Var ::= UVar | Loc 62 | 63 | |# 64 | 65 | (library (Compiler discard-call-live) 66 | (export discard-call-live) 67 | (import (chezscheme) 68 | (Framework helpers) 69 | (Framework match)) 70 | 71 | (define-who discard-call-live 72 | 73 | (define Tail 74 | (lambda (tail) 75 | (match tail 76 | [(begin ,[Effect -> ef*] ... ,[tail]) `(begin ,ef* ... ,tail)] 77 | [(if ,[Pred -> test] ,[conseq] ,[altern]) `(if ,test ,conseq ,altern)] 78 | [(,t ,live* ...) `(,t)] ;; discard it 79 | [,tail (errorf who "invalid Tail ~s" tail)]))) 80 | 81 | (define Effect 82 | (lambda (ef) 83 | (match ef 84 | [(mset! ,base ,offset ,t) ;; a8 new 85 | `(mset! ,base ,offset ,t)] 86 | [(set! ,v (mref ,base ,offset)) ;; a8 new 87 | `(set! ,v (mref ,base ,offset))] 88 | [(nop) '(nop)] 89 | [(set! ,x ,y) `(set! ,x ,y)] 90 | [(set! ,x (,binop ,y ,z)) `(set! ,x (,binop ,y ,z))] 91 | [(begin ,[ef*] ... ,[ef]) `(begin ,ef* ... ,ef)] ;; 92 | [(if ,[Pred -> test] ,[ef-c] ,[ef-a]) 93 | `(if ,test ,ef-c ,ef-a)] 94 | [(return-point ,label ,[Tail -> tail]) 95 | `(return-point ,label ,tail)] 96 | [,ef (errorf who "invalid Effect ~s" ef)]))) 97 | 98 | (define Pred 99 | (lambda (pr) 100 | (match pr 101 | [(true) '(true)] 102 | [(false) '(false)] 103 | [(if ,[test] ,[conseq] ,[altern]) `(if ,test ,conseq ,altern)] 104 | [(begin ,[Effect -> ef*] ... ,[pr]) `(begin ,ef* ... ,pr)] 105 | [(,relop ,x ,y) `(,relop ,x ,y)] 106 | [,pr (errorf who "invalid Pred ~s" pr)]))) 107 | 108 | (define Body 109 | (lambda (bd) 110 | (match bd 111 | [(locate ([,uvar* ,loc*] ...) ,[Tail -> tail]) 112 | `(locate ([,uvar* ,loc*] ...) ,tail)] 113 | [,bd (errorf who "invalid Body ~s" bd)]))) 114 | 115 | (lambda (x) 116 | (match x 117 | [(letrec ([,label* (lambda () ,[Body -> bd*])] ...) ,[Body -> bd]) 118 | `(letrec ([,label* (lambda () ,bd*)] ...) ,bd)] 119 | [,x (errorf who "invalid Program ~s" x)]))) 120 | 121 | ) 122 | -------------------------------------------------------------------------------- /Compiler/everybody-home.ss: -------------------------------------------------------------------------------- 1 | (library (Compiler everybody-home) 2 | (export everybody-home?) 3 | (import 4 | (chezscheme) 5 | (Framework match) 6 | (Framework helpers)) 7 | 8 | (define-who everybody-home? 9 | 10 | (define all-home? 11 | (lambda (body) 12 | (match body 13 | [(locals (,local* ...) 14 | (ulocals (,ulocal* ...) 15 | (spills (,spill* ...) 16 | (locate (,home* ...) 17 | (frame-conflict ,ct ,tail))))) #f] 18 | [(locate (,home* ...) ,tail) #t] 19 | [,x (error who "invalid Body ~s" x)]))) 20 | 21 | (lambda (x) 22 | (match x 23 | [(letrec ([,label* (lambda () ,body*)] ...) ,body) 24 | (andmap all-home? `(,body ,body* ...))] 25 | [,x (error who "invalid Program ~s" x)]))) 26 | 27 | ) 28 | -------------------------------------------------------------------------------- /Compiler/expose-allocation-pointer.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A8 - Mar 6, 2015 4 | 5 | pass: expose-allocation-pointer 6 | 7 | This pass eliminates the `(set! Var (alloc Triv))` form in `Effect`. 8 | 9 | Input Grammar: 10 | Program ::= (letrec ((Label (lambda () Body)) *) Body) 11 | Body ::= (locals (UVar *) 12 | (new-frames (Frame *) 13 | Tail)) 14 | Tail ::= (if Pred Tail Tail) 15 | | (begin Effect * Tail) 16 | | (Triv Var *) ;; Note 'Var' not 'Loc'. 17 | Pred ::= (true) 18 | | (false) 19 | | (if Pred Pred Pred) 20 | | (begin Effect * Pred) 21 | | (Relop Triv Triv) 22 | Effect ::= (nop) 23 | | (set! Var Triv) 24 | | (set! Var (Binop Triv Triv)) 25 | | (set! Var (alloc Triv)) ;; found you! 26 | | (set! Var (mref Triv Triv)) 27 | | (return-point Label Tail) 28 | | (mset! Triv Triv Triv) 29 | | (if Pred Effect Effect) 30 | | (begin Effect * Effect) 31 | Triv ::= Var 32 | | Integer | Label 33 | Loc ::= Reg | FVar 34 | Var ::= UVar | Loc 35 | Frame ::= (Uvar *) 36 | 37 | 38 | Output Grammar: 39 | Program ::= (letrec ((Label (lambda () Body)) *) Body) 40 | Body ::= (locals (UVar *) 41 | (new-frames (Frame *) 42 | Tail)) 43 | Tail ::= (if Pred Tail Tail) 44 | | (begin Effect * Tail) 45 | | (Triv Var *) ;; Note 'Var' not 'Loc'. 46 | Pred ::= (true) 47 | | (false) 48 | | (if Pred Pred Pred) 49 | | (begin Effect * Pred) 50 | | (Relop Triv Triv) 51 | Effect ::= (nop) 52 | | (set! Var Triv) 53 | | (set! Var (Binop Triv Triv)) 54 | | (set! Var (mref Triv Triv)) 55 | | (return-point Label Tail) 56 | | (mset! Triv Triv Triv) 57 | | (if Pred Effect Effect) 58 | | (begin Effect * Effect) 59 | Triv ::= Var 60 | | Integer | Label 61 | Loc ::= Reg | FVar 62 | Var ::= UVar | Loc 63 | Frame ::= (Uvar *) 64 | 65 | 66 | |# 67 | 68 | 69 | (library (Compiler expose-allocation-pointer) 70 | (export expose-allocation-pointer) 71 | (import (chezscheme) (Framework helpers) (Framework match)) 72 | 73 | (define-who expose-allocation-pointer 74 | 75 | (define (var? v) 76 | (or (uvar? v) (register? v) (frame-var? v))) 77 | 78 | (define (Var v) 79 | (if (var? v) 80 | v 81 | (errorf who "invalid Var ~s" v))) 82 | 83 | (define (triv? x) (or (var? x) (int64? x) (label? x))) 84 | 85 | (define (Triv t) (if (triv? t) t (errorf who "invalid Triv ~s" t))) 86 | 87 | (define (Effect ef) 88 | (match ef 89 | [(nop) '(nop)] 90 | [(begin ,[ef*] ... ,[ef]) 91 | (make-begin `(,ef* ... ,ef))] 92 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 93 | `(if ,test ,conseq ,altern)] 94 | [(mset! ,[Triv -> t1] ,[Triv -> t2] ,[Triv -> t3]) ;; a8 new 95 | `(mset! ,t1 ,t2 ,t3)] 96 | [(return-point ,label ,[Tail -> t]) 97 | `(return-point ,label ,t)] 98 | [(set! ,var (alloc ,[Triv -> t])) ;; a8 new 99 | (make-begin 100 | `((set! ,var ,allocation-pointer-register) 101 | (set! ,allocation-pointer-register 102 | (+ ,allocation-pointer-register ,t))))] 103 | [(set! ,var (mref ,[Triv -> t1] ,[Triv -> t2])) ;; a8 new 104 | `(set! ,var (mref ,t1 ,t2))] 105 | [(set! ,var (,binop ,[Triv -> x] ,[Triv -> y])) 106 | (guard (memq binop '(+ - * logand logor sra))) 107 | `(set! ,var (,binop ,x ,y))] 108 | [(set! ,var ,[Triv -> tr]) 109 | `(set! ,var ,tr)] 110 | [,ef (errorf who "invalid Effect ~s" ef)])) 111 | 112 | (define (Pred pr) 113 | (match pr 114 | [(true) '(true)] 115 | [(false) '(false)] 116 | [(if ,[test] ,[conseq] ,[altern]) 117 | `(if ,test ,conseq ,altern)] 118 | [(begin ,[Effect -> ef*] ... ,[pred]) 119 | (make-begin `(,ef* ... ,pred))] 120 | [(,relop ,[Triv -> x] ,[Triv -> y]) 121 | (guard (memq relop '(< <= = >= >))) 122 | `(,relop ,x ,y)] 123 | [,x (errorf who "invalid Pred ~s" x)])) 124 | 125 | (define (Tail t) 126 | (match t 127 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 128 | `(if ,test ,conseq ,altern)] 129 | [(begin ,[Effect -> ef*] ... ,[tail]) 130 | (make-begin `(,ef* ... ,tail))] 131 | [(,[Triv -> rator] ,[Var -> var*] ...) 132 | `(,rator ,var* ...)] 133 | [,x (errorf who "invalid Tail ~s" x)])) 134 | 135 | (define (Body b) 136 | (match b 137 | [(locals (,uvar* ...) 138 | (new-frames (,frame* ...) ,[Tail -> t])) 139 | `(locals (,uvar* ...) 140 | (new-frames (,frame* ...) ,t))] 141 | [,x (errorf who "invalid Body ~s" x)])) 142 | 143 | (lambda (x) 144 | (match x 145 | [(letrec ([,label* (lambda () ,[Body -> body*])] ...) 146 | ,[Body -> body]) 147 | `(letrec ([,label* (lambda () ,body*)] ...) ,body)] 148 | [,x (errorf who "invalid Program ~s" x)]))) 149 | ) 150 | -------------------------------------------------------------------------------- /Compiler/expose-basic-blocks.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A8 - Mar 6, 2015 4 | 5 | pass: expose-basic-blocks 6 | 7 | nothin' changed. 8 | 9 | Input Grammar: 10 | Program ::= (letrec ((Label (lambda () Tail)) *) Tail) ;; 11 | Tail ::= (if Pred Tail Tail) 12 | | (begin Effect * Tail) 13 | | (Triv) 14 | Pred ::= (true) 15 | | (false) 16 | | (if Pred Pred Pred) 17 | | (begin Effect * Pred) 18 | | (Relop Triv Triv) 19 | Effect ::= (nop) 20 | | (set! Loc Triv) ;; 21 | | (set! Loc (Binop Triv Triv)) ;; 22 | | (return-point Label Tail) 23 | | (if Pred Effect Effect) 24 | | (begin Effect * Effect) 25 | Triv ::= Loc ;; 26 | | Integer | Label 27 | Loc ::= Reg | Disp | Ind ;; 28 | 29 | Output Grammar: 30 | Program ::= (letrec ((Label (lambda () Tail)) *) Tail) ;; 31 | Tail ::= (if (Relop Triv Triv) (Label) (Label)) ;; mod 32 | | (begin Effect * Tail) 33 | | (Triv) 34 | Effect ::= (set! Loc Triv) ;; 35 | | (set! Loc (Binop Triv Triv)) ;; 36 | Triv ::= Loc ;; 37 | | Integer | Label 38 | Loc ::= Reg | Disp | Ind ;; 39 | 40 | |# 41 | 42 | (library (Compiler expose-basic-blocks) 43 | (export expose-basic-blocks) 44 | (import (chezscheme) 45 | (Framework helpers) 46 | (Framework match)) 47 | 48 | (define-who expose-basic-blocks 49 | 50 | (define (Tail x) 51 | (match x 52 | [(if ,pred ,[conseq cb*] ,[altern ab*]) 53 | (let ([clab (unique-label 'c)] [alab (unique-label 'a)]) 54 | (let-values ([(pred pb*) (Pred pred clab alab)]) 55 | (values pred 56 | `(,pb* ... 57 | [,clab (lambda () ,conseq)] 58 | ,cb* ... 59 | [,alab (lambda () ,altern)] 60 | ,ab* ...))))] 61 | [(begin ,effect* ... ,[tail tb*]) 62 | (let-values ([(x xb*) (Effect* effect* `(,tail))]) 63 | (values x `(,xb* ... ,tb* ...)))] 64 | [(,triv) (values `(,triv) '())] 65 | [,x (error who "invalid Tail ~s" x)])) 66 | 67 | (define (Pred x tlab flab) 68 | (match x 69 | [(true) (values `(,tlab) '())] 70 | [(false) (values `(,flab) '())] 71 | [(if ,pred ,[conseq cb*] ,[altern ab*]) 72 | (let ([clab (unique-label 'c)] [alab (unique-label 'a)]) 73 | (let-values ([(pred pb*) (Pred pred clab alab)]) 74 | (values pred 75 | `(,pb* ... 76 | [,clab (lambda () ,conseq)] 77 | ,cb* ... 78 | [,alab (lambda () ,altern)] 79 | ,ab* ...))))] 80 | [(begin ,effect* ... ,[pred pb*]) 81 | (let-values ([(x xb*) (Effect* effect* `(,pred))]) 82 | (values x `(,xb* ... ,pb* ...)))] 83 | [(,relop ,triv1 ,triv2) 84 | (values `(if (,relop ,triv1 ,triv2) (,tlab) (,flab)) '())] 85 | [,x (error who "invalid Pred ~s" x)])) 86 | 87 | (define (Effect* x* rest*) 88 | (match x* 89 | [() (values (make-begin rest*) '())] 90 | [(,x* ... ,x) (Effect x* x rest*)])) 91 | 92 | (define (Effect x* x rest*) 93 | (match x 94 | [(nop) (Effect* x* rest*)] 95 | [(set! ,lhs ,rhs) (Effect* x* `((set! ,lhs ,rhs) ,rest* ...))] 96 | [(if ,pred ,conseq ,altern) 97 | (let ([clab (unique-label 'c)] 98 | [alab (unique-label 'a)] 99 | [jlab (unique-label 'j)]) 100 | (let-values ([(conseq cb*) (Effect '() conseq `((,jlab)))] 101 | [(altern ab*) (Effect '() altern `((,jlab)))] 102 | [(pred pb*) (Pred pred clab alab)]) 103 | (let-values ([(x xb*) (Effect* x* `(,pred))]) 104 | (values x 105 | `(,xb* ... 106 | ,pb* ... 107 | [,clab (lambda () ,conseq)] 108 | ,cb* ... 109 | [,alab (lambda () ,altern)] 110 | ,ab* ... 111 | [,jlab (lambda () ,(make-begin rest*))])))))] 112 | [(begin ,effect* ...) (Effect* `(,x* ... ,effect* ...) rest*)] 113 | 114 | [(return-point ,rp-lab ,tail) ;; new 115 | (let*-values ([(tail tb*) (Tail tail)] 116 | [(ef eb*) (Effect* x* (cdr tail))]) 117 | (values ef 118 | `(,eb* ... 119 | ,tb* ... 120 | [,rp-lab (lambda () 121 | ,(make-begin rest*))])))] 122 | 123 | [,x (error who "invalid Effect ~s" x)])) 124 | 125 | (lambda (x) 126 | (match x 127 | [(letrec ([,label* (lambda () ,[Tail -> tail* b**])] ...) ,[Tail -> tail b*]) 128 | `(letrec ([,label* (lambda () ,tail*)] ... ,b** ... ... ,b* ...) ,tail)] 129 | [,x (error who "invalid Program ~s" x)]))) 130 | 131 | ) 132 | -------------------------------------------------------------------------------- /Compiler/expose-frame-var.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A8 - Mar 6, 2015 4 | 5 | pass: expose-frame-var 6 | 7 | This pass converts occurrences of the frame variables fv0, fv1, etc., into displacement mode operands, with rbp as the base register and an offset based on the frame variable's index. Since our words are 64 bits, i.e., 8 bytes, the offset for fvi should be 8i, e.g., 0, 8, 16, etc., for fv0, fv1, fv2, etc. 8 | 9 | Input Grammar: 10 | Program ::= (letrec ((Label (lambda () Tail)) *) Tail) ;; 11 | Tail ::= (if Pred Tail Tail) 12 | | (begin Effect * Tail) 13 | | (Triv) 14 | Pred ::= (true) 15 | | (false) 16 | | (if Pred Pred Pred) 17 | | (begin Effect * Pred) 18 | | (Relop Triv Triv) 19 | Effect ::= (nop) 20 | | (set! Loc Triv) ;; 21 | | (set! Loc (Binop Triv Triv)) ;; 22 | | (set! Loc (mref Triv Triv)) ;; a8 new 23 | | (return-point Label Tail) 24 | | (mset! Triv Triv Triv) ;; a8 new 25 | | (if Pred Effect Effect) 26 | | (begin Effect * Effect) 27 | Triv ::= Loc ;; 28 | | Integer | Label 29 | Loc ::= Reg | FVar 30 | 31 | Output Grammar: 32 | Program ::= (letrec ((Label (lambda () Tail)) *) Tail) ;; 33 | Tail ::= (if Pred Tail Tail) 34 | | (begin Effect * Tail) 35 | | (Triv) 36 | Pred ::= (true) 37 | | (false) 38 | | (if Pred Pred Pred) 39 | | (begin Effect * Pred) 40 | | (Relop Triv Triv) 41 | Effect ::= (nop) 42 | | (set! Loc Triv) ;; 43 | | (set! Loc (Binop Triv Triv)) ;; 44 | | (set! Loc (mref Triv Triv)) ;; a8 new 45 | | (return-point Label Tail) 46 | | (mset! Triv Triv Triv) ;; a8 new 47 | | (if Pred Effect Effect) 48 | | (begin Effect * Effect) 49 | Triv ::= Loc ;; 50 | | Integer | Label 51 | Loc ::= Reg | Disp ;; mod 52 | 53 | |# 54 | 55 | (library (Compiler expose-frame-var) 56 | (export expose-frame-var) 57 | (import (chezscheme) 58 | (Framework helpers) 59 | (Framework match)) 60 | 61 | ;;; expose-frame-var traverses the scheme source in the same grammar 62 | ;;; accepted by verify-scheme and changes frame-vars in the form 63 | ;;; fv0, fv1, etc. into explicit integer offsets from the register 64 | ;;; pointing to the frame-pointer register. To accomplish this, 65 | ;;; expose-frame-var makes use of make-disp-opnd which creates a 66 | ;;; displacement operand record expressing a register and fixed 67 | ;;; number displacment each displacement is the original frame var 68 | ;;; number multiplied by the word size (8 for 64-bit target machine) 69 | ;;; to get the byte offset. 70 | ;;; (i.e. fv0 => (make-disp-opnd frame-pointer-register 0) 71 | ;;; fv1 => (make-disp-opnd frame-pointer-register 8) 72 | ;;; fv2 => (make-disp-opnd frame-pointer-register 16) 73 | ;;; fv3 => (make-disp-opnd frame-pointer-register 24) 74 | ;;; ... well you get the idea.) 75 | ;;; 76 | ;;; Note: we use shift left by word-shift (3 for 64-bit target 77 | ;;; machine) to calculate the multiplication. 78 | 79 | (define-who expose-frame-var 80 | 81 | (define current-offset 0) 82 | 83 | (define (fpr? x) 84 | (eqv? x frame-pointer-register)) 85 | 86 | (define Triv 87 | (lambda (t) 88 | (if (frame-var? t) 89 | (make-disp-opnd frame-pointer-register 90 | (+ (ash (frame-var->index t) word-shift) 91 | current-offset)) 92 | t))) 93 | 94 | (define Pred 95 | (lambda (pr) 96 | (match pr 97 | [(true) '(true)] 98 | [(false) '(false)] 99 | [(if ,[test] ,[conseq] ,[altern]) 100 | `(if ,test ,conseq ,altern)] 101 | [(begin ,[Effect -> ef*] ... ,[test]) 102 | (make-begin `(,ef* ... ,test))] 103 | [(,relop ,[Triv -> tr1] ,[Triv -> tr2]) 104 | `(,relop ,tr1 ,tr2)] 105 | [,pr (error who "invalid Pred ~s" pr)]))) 106 | 107 | (define Effect 108 | (lambda (st) 109 | (match st 110 | [(mset! ,base ,offset ,t) `(mset! ,base ,offset ,t)] ;; a8 new 111 | [(set! ,var (mref ,base ,offset)) ;; a8 new 112 | `(set! ,var (mref ,base ,offset))] 113 | [(nop) '(nop)] 114 | [(begin ,[ef] ,[ef*] ...) 115 | (make-begin `(,ef ,ef* ...))] 116 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 117 | `(if ,test ,conseq ,altern)] 118 | [(set! ,fp (+ ,fp ,n)) (guard (fpr? fp)) 119 | (begin 120 | (set! current-offset (+ current-offset n)) 121 | `(set! ,fp (+ ,fp ,n)))] 122 | [(set! ,fp (- ,fp ,n)) (guard (fpr? fp)) 123 | (begin 124 | (set! current-offset (- current-offset n)) 125 | `(set! ,fp (- ,fp ,n)))] 126 | [(return-point ,label ,[Tail -> tail]) 127 | `(return-point ,label ,tail)] 128 | [(set! ,[Triv -> var] (,binop ,[Triv -> t1] ,[Triv -> t2])) 129 | `(set! ,var (,binop ,t1 ,t2))] 130 | [(set! ,[Triv -> var] ,[Triv -> t]) 131 | `(set! ,var ,t)] 132 | [,st (error who "invalid syntax for Effect ~s" st)]))) 133 | 134 | (define Tail 135 | (lambda (tail) 136 | (match tail 137 | [(,[Triv -> t]) `(,t)] 138 | [(begin ,[Effect -> ef*] ... ,[tail]) 139 | (make-begin `(,ef* ... ,tail))] 140 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 141 | `(if ,test ,conseq ,altern)] 142 | [,tail (error who "invalid syntax for Tail ~s" tail)]))) 143 | 144 | (lambda (program) 145 | (match program 146 | [(letrec ([,label* (lambda () ,[Tail -> tail*])] ...) ,[Tail -> tail]) 147 | `(letrec ([,label* (lambda () ,tail*)] ...) ,tail)] 148 | [,program (error who "invalid syntax for Program: ~s" program)]))) 149 | 150 | ) 151 | -------------------------------------------------------------------------------- /Compiler/expose-memory-operands.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A8 - Mar 6, 2015 4 | 5 | pass: expose-memory-operands 6 | 7 | This pass removes `mref` and `mset!` forms from `Effect`. Depending on the type of `offset`, the expression is converted to an `Index` or `Disp`. 8 | 9 | Output Grammar: 10 | Program ::= (letrec ((Label (lambda () Tail)) *) Tail) ;; 11 | Tail ::= (if Pred Tail Tail) 12 | | (begin Effect * Tail) 13 | | (Triv) 14 | Pred ::= (true) 15 | | (false) 16 | | (if Pred Pred Pred) 17 | | (begin Effect * Pred) 18 | | (Relop Triv Triv) 19 | Effect ::= (nop) 20 | | (set! Loc Triv) ;; 21 | | (set! Loc (Binop Triv Triv)) ;; 22 | | (return-point Label Tail) 23 | | (if Pred Effect Effect) 24 | | (begin Effect * Effect) 25 | Triv ::= Loc ;; 26 | | Integer | Label 27 | Loc ::= Reg | Disp | Ind ;; mod 28 | 29 | |# 30 | 31 | (library (Compiler expose-memory-operands) 32 | (export expose-memory-operands) 33 | (import (chezscheme) 34 | (Framework helpers) 35 | (Framework match)) 36 | 37 | (define-who expose-memory-operands 38 | 39 | (define (make-index-or-disp base offset) 40 | (if (register? offset) 41 | (make-index-opnd base offset) 42 | (make-disp-opnd base offset))) 43 | 44 | (define Pred 45 | (lambda (pr) 46 | (match pr 47 | [(true) '(true)] 48 | [(false) '(false)] 49 | [(if ,[test] ,[conseq] ,[altern]) 50 | `(if ,test ,conseq ,altern)] 51 | [(begin ,[Effect -> ef*] ... ,[test]) 52 | (make-begin `(,ef* ... ,test))] 53 | [(,relop ,tr1 ,tr2) 54 | `(,relop ,tr1 ,tr2)] 55 | [,pr (error who "invalid Pred ~s" pr)]))) 56 | 57 | (define Effect 58 | (lambda (st) 59 | (match st 60 | [(mset! ,base ,offset ,t) ;; a8 new 61 | `(set! ,(make-index-or-disp base offset) ,t)] 62 | [(set! ,var (mref ,base ,offset)) ;; a8 new 63 | `(set! ,var ,(make-index-or-disp base offset))] 64 | [(nop) '(nop)] 65 | [(begin ,[ef] ,[ef*] ...) 66 | (make-begin `(,ef ,ef* ...))] 67 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 68 | `(if ,test ,conseq ,altern)] 69 | [(return-point ,label ,[Tail -> tail]) 70 | `(return-point ,label ,tail)] 71 | [(set! ,var (,binop ,t1 ,t2)) 72 | `(set! ,var (,binop ,t1 ,t2))] 73 | [(set! ,var ,t) 74 | `(set! ,var ,t)] 75 | [,st (error who "invalid syntax for Effect ~s" st)]))) 76 | 77 | (define Tail 78 | (lambda (tail) 79 | (match tail 80 | [(begin ,[Effect -> ef*] ... ,[tail]) 81 | (make-begin `(,ef* ... ,tail))] 82 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 83 | `(if ,test ,conseq ,altern)] 84 | [(,t) `(,t)] 85 | [,tail (error who "invalid syntax for Tail ~s" tail)]))) 86 | 87 | (lambda (program) 88 | (match program 89 | [(letrec ([,label* (lambda () ,[Tail -> tail*])] ...) 90 | ,[Tail -> tail]) 91 | `(letrec ([,label* (lambda () ,tail*)] ...) ,tail)] 92 | [,program (error who "invalid syntax for Program: ~s" program)]))) 93 | 94 | ) 95 | 96 | -------------------------------------------------------------------------------- /Compiler/finalize-locations.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A8 - Mar 6, 2015 4 | 5 | pass: finalize-locations 6 | 7 | This pass replaces each occurrence of a uvar in the body of each locate form with the corresponding Loc. As it does so, it removes useless assignments, i.e., converts any assignment (set! x y) to (nop) if x and y resolve to the same location. 8 | 9 | Input Grammar: 10 | Program ::= (letrec ((Label (lambda () Body)) *) Body) 11 | Body ::= (locate ((UVar Loc) *) Tail) 12 | Tail ::= (if Pred Tail Tail) 13 | | (begin Effect * Tail) 14 | | (Triv) 15 | Pred ::= (true) 16 | | (false) 17 | | (if Pred Pred Pred) 18 | | (begin Effect * Pred) 19 | | (Relop Triv Triv) 20 | Effect ::= (nop) 21 | | (set! Var Triv) 22 | | (set! Var (Binop Triv Triv)) 23 | | (set! Var (mref Triv Triv)) ;; a8 new 24 | | (return-point Label Tail) 25 | | (mset! Triv Triv Triv) ;; a8 new 26 | | (if Pred Effect Effect) 27 | | (begin Effect * Effect) 28 | Triv ::= Var 29 | | Integer | Label 30 | Loc ::= Reg | FVar 31 | Var ::= UVar | Loc 32 | 33 | Output Grammar: 34 | Program ::= (letrec ((Label (lambda () Tail)) *) Tail) ;; mod 35 | Tail ::= (if Pred Tail Tail) 36 | | (begin Effect * Tail) 37 | | (Triv) 38 | Pred ::= (true) 39 | | (false) 40 | | (if Pred Pred Pred) 41 | | (begin Effect * Pred) 42 | | (Relop Triv Triv) 43 | Effect ::= (nop) 44 | | (set! Loc Triv) ;; mod 45 | | (set! Loc (Binop Triv Triv)) ;; mod 46 | | (set! Loc (mref Triv Triv)) ;; a8n, mod 47 | | (return-point Label Tail) 48 | | (mset! Triv Triv Triv) ;; a8n 49 | | (if Pred Effect Effect) 50 | | (begin Effect * Effect) 51 | Triv ::= Loc ;; mod 52 | | Integer | Label 53 | Loc ::= Reg | FVar 54 | 55 | |# 56 | 57 | (library (Compiler finalize-locations) 58 | (export finalize-locations) 59 | (import (chezscheme) 60 | (Framework helpers) 61 | (Framework match)) 62 | 63 | (define-who finalize-locations 64 | 65 | (define Var 66 | (lambda (env) 67 | (lambda (v) 68 | (if (uvar? v) (cdr (assq v env)) v)))) 69 | 70 | (define Triv 71 | (lambda (env) 72 | (lambda (t) 73 | (if (uvar? t) (cdr (assq t env)) t)))) 74 | 75 | (define Pred 76 | (lambda (env) 77 | (lambda (pr) 78 | (match pr 79 | [(true) '(true)] 80 | [(false) '(false)] 81 | [(if ,[test] ,[conseq] ,[altern]) `(if ,test ,conseq ,altern)] 82 | [(begin ,[(Effect env) -> ef*] ... ,[pr]) `(begin ,ef* ... ,pr)] 83 | [(,relop ,[(Triv env) -> x] ,[(Triv env) -> y]) `(,relop ,x ,y)] 84 | [,pr (error who "invalid Pred ~s" pr)])))) 85 | 86 | (define Effect 87 | (lambda (env) 88 | (lambda (ef) 89 | (match ef 90 | [(mset! ,[(Triv env) -> base] ;; a8 new 91 | ,[(Triv env) -> offset] 92 | ,[(Triv env) -> t]) 93 | `(mset! ,base ,offset ,t)] 94 | [(set! ,[(Var env) -> v] 95 | (mref ,[(Triv env) -> base] 96 | ,[(Triv env) -> offset])) ;; a8 new 97 | `(set! ,v (mref ,base ,offset))] 98 | [(nop) '(nop)] 99 | [(set! ,[(Var env) -> x] 100 | (,binop ,[(Triv env) -> y] ,[(Triv env) -> z])) 101 | `(set! ,x (,binop ,y ,z))] 102 | [(set! ,[(Var env) -> x] ,[(Triv env) -> y]) 103 | (if (eq? x y) '(nop) `(set! ,x ,y))] 104 | [(begin ,[ef] ,[ef*] ...) `(begin ,ef ,ef* ...)] 105 | [(if ,[(Pred env) -> test] ,[conseq] ,[altern]) 106 | `(if ,test ,conseq ,altern)] 107 | [(return-point ,label ,[(Tail env) -> tail]) 108 | `(return-point ,label ,tail)] 109 | [,ef (error who "invalid Effect ~s" ef)])))) 110 | 111 | (define Tail 112 | (lambda (env) 113 | (lambda (tail) 114 | (match tail 115 | [(begin ,[(Effect env) -> ef*] ... ,[tail]) `(begin ,ef* ... ,tail)] 116 | [(if ,[(Pred env) -> test] ,[conseq] ,[altern]) 117 | `(if ,test ,conseq ,altern)] 118 | [(,[(Triv env) -> t]) `(,t)] 119 | [,tail (error who "invalid Tail ~s" tail)])))) 120 | 121 | (define Body 122 | (lambda (bd) 123 | (match bd 124 | [(locate ([,uvar* ,loc*] ...) ,[(Tail (map cons uvar* loc*)) -> tail]) 125 | tail] 126 | [,bd (error who "invalid Body ~s" bd)]))) 127 | 128 | (lambda (x) 129 | (match x 130 | [(letrec ([,label* (lambda () ,[Body -> bd*])] ...) ,[Body -> bd]) 131 | `(letrec ([,label* (lambda () ,bd*)] ...) ,bd)] 132 | [,x (error who "invalid Program ~s" x)]))) 133 | 134 | ) 135 | -------------------------------------------------------------------------------- /Compiler/flatten-program.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A8 - Mar 6, 2015 4 | 5 | pass: flatten-program 6 | 7 | nothin' changed. 8 | 9 | Input Grammar: 10 | Program ::= (letrec ((Label (lambda () Tail)) *) Tail) 11 | Tail ::= (if (Relop Triv Triv) (Label) (Label)) 12 | | (begin Effect * Tail) 13 | | (Triv) 14 | Effect ::= (set! Loc Triv) 15 | | (set! Loc (Binop Triv Triv)) 16 | Triv ::= Loc 17 | | Integer | Label 18 | Loc ::= Reg | Disp | Ind ;; a8 new 19 | 20 | Output Grammar: 21 | Prog ::= (code Statement * Statement) ;; mod 22 | Statement ::= (set! Loc Triv) ;; mod 23 | | (set! Loc (Binop Triv Triv)) 24 | | (if (Relop Triv Triv) (jump Label)) ;; mod 25 | | (if (not (Relop Triv Triv)) (jump Label)) ;; mod 26 | | (jump Triv) ;; mod 27 | | Label ;; mod 28 | Triv ::= Loc 29 | | Integer | Label 30 | Loc ::= Reg | Disp | Ind 31 | 32 | |# 33 | 34 | (library (Compiler flatten-program) 35 | (export flatten-program) 36 | (import (chezscheme) 37 | (Framework helpers) 38 | (Framework match)) 39 | 40 | (define-who flatten-program 41 | (define Effect 42 | (lambda (ef) 43 | (match ef 44 | [(set! ,var ,rhs) `((set! ,var ,rhs))] 45 | [,ef (error who "invalid Effect ~s" ef)]))) 46 | 47 | (define Tail 48 | (lambda (tail next-label) 49 | (match tail 50 | [(,t) (if (eq? t next-label) '() `((jump ,t)))] 51 | [(if ,test (,tlab) (,flab)) 52 | (cond 53 | [(eq? flab next-label) `((if ,test (jump ,tlab)))] 54 | [(eq? tlab next-label) `((if (not ,test) (jump ,flab)))] 55 | [else `((if ,test (jump ,tlab)) (jump ,flab))])] 56 | [(begin ,[Effect -> ef-code**] ... ,[tail-code*]) 57 | `(,ef-code** ... ... ,tail-code* ...)] 58 | [,tail (error who "invalid Tail ~s" tail)]))) 59 | 60 | (lambda (x) 61 | (match x 62 | [(letrec ([,label* (lambda () ,tail*)] ...) ,tail) 63 | `(code 64 | ,@(let f ([tail tail] [label* label*] [tail* tail*]) 65 | (if (null? tail*) 66 | (Tail tail #f) 67 | `(,(Tail tail (car label*)) ... 68 | ,(car label*) 69 | ,(f (car tail*) (cdr label*) (cdr tail*)) ...))))] 70 | [,x (error who "invalid Program ~s" x)]))) 71 | 72 | ) 73 | -------------------------------------------------------------------------------- /Compiler/flatten-set!.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A8 - Mar 6, 2015 4 | 5 | pass: flatten-set! 6 | 7 | This pass rewrites set! expressions as necessary to push them inside if and begin expressions so that, in the output, the right-hand-side of each set! contains neither if nor begin expressions. 8 | 9 | Assignments are converted into a form that more closely resembles assembly instructions. 10 | 11 | input grammar changes: 12 | Tail ::= (alloc Triv) ;; + 13 | | (mref Triv Triv) ;; + 14 | 15 | Effect ::= (mset! Triv Triv Triv) ;; + 16 | 17 | Value ::= (alloc Triv) ;; + 18 | | (mref Triv Triv) ;; + 19 | 20 | 21 | output grammar: 22 | Program ::= (letrec ([Label (lambda (UVar *) Body)] *) Body) 23 | Body ::= (locals (UVar *) Tail) 24 | Tail ::= (if Pred Tail Tail) 25 | | (begin Effect * Tail) 26 | | (alloc Triv) ;; a8 new 27 | | (mref Triv Triv) ;; a8 new 28 | | (Binop Triv Triv) 29 | | (Triv Triv *) 30 | | Triv 31 | Pred ::= (true) 32 | | (false) 33 | | (if Pred Pred Pred) 34 | | (begin Effect * Pred) 35 | | (Relop Triv Triv) 36 | Effect ::= (nop) 37 | | (set! UVar (alloc Triv)) ;; a8n, mod 38 | | (set! UVar (mref Triv Triv)) ;; a8n, mod 39 | | (set! UVar Triv) ;; mod 40 | | (set! UVar (Binop Triv Triv)) ;; mod 41 | | (set! UVar (Triv Triv *)) ;; mod 42 | | (mset! Triv Triv Triv) ;; a8n, mod 43 | | (if Pred Effect Effect) 44 | | (begin Effect * Effect) 45 | | (Triv Triv *) ;; mod 46 | Triv ::= UVar | Integer | Label 47 | 48 | |# 49 | 50 | (library (Compiler flatten-set!) 51 | (export flatten-set!) 52 | (import (chezscheme) (Framework helpers) (Framework match)) 53 | 54 | (define-who flatten-set! 55 | 56 | (define (trivialize-set! lhs rhs) 57 | (match rhs 58 | [(alloc ,t) (guard (triv? t)) ;; a8 new 59 | `(set! ,lhs (alloc ,t))] 60 | [(mref ,t1 ,t2) ;; a8 new 61 | (guard (and (triv? t1) (triv? t2))) 62 | `(set! ,lhs (mref ,t1 ,t2))] 63 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 64 | `(if ,test ,conseq ,altern)] 65 | [(begin ,[Effect -> ef*] ... ,[rhs]) 66 | (make-begin `(,ef* ... ,rhs))] 67 | [(,binop ,[Triv -> x] ,[Triv -> y]) 68 | (guard (memq binop '(+ - * logand logor sra))) 69 | `(set! ,lhs (,binop ,x ,y))] 70 | [,tr (guard (triv? tr)) `(set! ,lhs ,tr)] 71 | [(,[Effect -> v] ,[Effect -> v*] ...) ;; (Triv Triv*) 72 | `(set! ,lhs (,v ,v* ...))] 73 | [,rhs (error who "invalid set! Rhs ~s" rhs)])) 74 | 75 | (define (triv? x) (or (uvar? x) (int64? x) (label? x))) 76 | 77 | (define (binop? x) (memq x '(+ - * logand logor sra))) 78 | 79 | (define (Triv t) (if (triv? t) t (error who "invalid Triv ~s" t))) 80 | 81 | (define (Effect ef) ;; + (mset! Triv Triv Triv) 82 | (match ef 83 | [(mset! ,t1 ,t2 ,t3) ;; a8 new 84 | (guard (and (triv? t1) (triv? t2) (triv? t3))) 85 | `(mset! ,t1 ,t2 ,t3)] 86 | [(nop) '(nop)] 87 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 88 | `(if ,test ,conseq ,altern)] 89 | [(begin ,[Effect -> ef*] ... ,[ef]) 90 | (make-begin `(,ef* ... ,ef))] 91 | [(set! ,var ,val) (trivialize-set! var val)] 92 | ;; since we dont have the Value matcher anymore, 93 | ;; Effect needs to handle the binop case 94 | [(,binop ,[v1] ,[v2]) (guard (binop? binop)) ;; (binop Triv Triv) 95 | `(,binop ,v1 ,v2)] 96 | [,t (guard (triv? t)) t] ;; Triv 97 | [(,[t] ,[t*] ...) `(,t ,t* ...)] ;; (Triv Triv*) 98 | [,ef (error who "invalid Effect ~s" ef)])) 99 | 100 | (define (Pred pr) 101 | (match pr 102 | [(true) '(true)] 103 | [(false) '(false)] 104 | [(if ,[test] ,[conseq] ,[altern]) 105 | `(if ,test ,conseq ,altern)] 106 | [(begin ,[Effect -> ef*] ... ,[pr]) 107 | (make-begin `(,ef* ... ,pr))] 108 | [(,relop ,[Triv -> x] ,[Triv -> y]) 109 | (guard (memq relop '(< <= = >= >))) 110 | `(,relop ,x ,y)] 111 | [,pr (error who "invalid Pred ~s" pr)])) 112 | 113 | (define (Tail tail) ;; (alloc Triv) | (mref Triv Triv) 114 | (match tail 115 | [(alloc ,t) (guard (triv? t)) 116 | `(alloc ,t)] ;; a8 new 117 | [(mref ,t1 ,t2) 118 | (guard (and (triv? t1) (triv? t2))) 119 | `(mref ,t1 ,t2)] ;; a8 new 120 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 121 | `(if ,test ,conseq ,altern)] 122 | [(begin ,[Effect -> ef*] ... ,[tail]) 123 | (make-begin `(,ef* ... ,tail))] 124 | [(,binop ,[Triv -> x] ,[Triv -> y]) 125 | (guard (memq binop '(+ - * logand logor sra))) 126 | `(,binop ,x ,y)] 127 | [(,[Triv -> rator] ,[Triv -> rand*] ...) `(,rator ,rand* ...)] 128 | [,tr (guard (triv? tr)) tr] 129 | [,tail (error who "invalid Tail ~s" tail)])) 130 | 131 | (define (Body bd) 132 | (match bd 133 | [(locals (,uvar* ...) ,[Tail -> tail]) 134 | `(locals (,uvar* ...) ,tail)] 135 | [,bd (error who "invalid Body ~s" bd)])) 136 | 137 | (lambda (x) 138 | (match x 139 | [(letrec ([,label* (lambda (,fml** ...) ,[Body -> bd*])] ...) 140 | ,[Body -> bd]) 141 | `(letrec ([,label* (lambda (,fml** ...) ,bd*)] ...) ,bd)] 142 | [,x (error who "invalid Program ~s" x)]))) 143 | 144 | ) 145 | -------------------------------------------------------------------------------- /Compiler/generate-x86-64.ss: -------------------------------------------------------------------------------- 1 | (library (Compiler generate-x86-64) 2 | (export generate-x86-64) 3 | (import (chezscheme) 4 | (Framework helpers) 5 | (Framework match)) 6 | 7 | (define-who generate-x86-64 8 | (define prim->opcode 9 | (lambda (prim) 10 | (cdr (assq prim 11 | '((+ . addq) (- . subq) (* . imulq) 12 | (logand . andq) (logor . orq) (sra . sarq)))))) 13 | (define relop->opcode 14 | (lambda (relop not?) 15 | (cdr (assq relop (if not? 16 | '((= . jne) (< . jge) (<= . jg) (> . jle) (>= . jl)) 17 | '((= . je) (< . jl) (<= . jle) (> . jg) (>= . jge))))))) 18 | (define Code 19 | (lambda (ef) 20 | (match ef 21 | [,lab (guard (label? lab)) (emit-label lab)] 22 | [(jump ,rand) (emit-jump 'jmp rand)] 23 | [(set! ,rand1 ,lab) 24 | (guard (label? lab)) 25 | (emit 'leaq lab rand1)] 26 | [(set! ,rand1 (,prim ,rand1 ,rand2)) 27 | (emit (prim->opcode prim) rand2 rand1)] 28 | [(set! ,rand1 ,rand2) (emit 'movq rand2 rand1)] 29 | [(if (not (,relop ,rand1 ,rand2)) (jump ,lab)) 30 | (emit 'cmpq rand2 rand1) 31 | (emit-jump (relop->opcode relop #t) lab)] 32 | [(if (,relop ,rand1 ,rand2) (jump ,lab)) 33 | (emit 'cmpq rand2 rand1) 34 | (emit-jump (relop->opcode relop #f) lab)] 35 | [,ef (error who "invalid Code syntax ~s" ef)]))) 36 | (lambda (x) 37 | (match x 38 | [(code ,code* ...) (emit-program (for-each Code code*))] 39 | [,x (error who "invalid Program syntax ~s" x)]))) 40 | 41 | ) 42 | -------------------------------------------------------------------------------- /Compiler/introduce-procedure-primitives.ss: -------------------------------------------------------------------------------- 1 | #| 2 | A12 - Apr 09, 2015 3 | 4 | pass: introduce-procedure-primitives 5 | 6 | This pass completes closure conversion by introducing concrete procedure-manipulation primitives and eliminating the bind-free and closures forms. 7 | - (make-procedure code size) allocates a new procedure (closure) with code as its code pointer and size free-variable slots. 8 | - (procedure-code proc) extracts the code pointer from proc. 9 | - (procedure-ref proc i) extracts the value from the ith free-variable slot of proc. 10 | - replaces each reference to a free variable 11 | - index: the ordering of free vars in the `bind-free` form 12 | - (procedure-set! proc i val) stores val in the ith free-variable slot of proc. 13 | 14 | - Each closures form is expanded into calls to make-procedure and procedure-set!, with one call to make-procedure for each closure and as many calls to procedure-set! as are necessary to fill each of the closures 15 | - The procedure-set! indices to use are determined by the ordering of free variables in the closures binding. 16 | - Procedure calls are rewritten with procedure-code used to extract the pointer to the code to be invoked. 17 | 18 | Input: 19 | Prog ::= Expr 20 | Expr ::= (quote Immediate) 21 | | (let ([UVar Expr]*) Expr) 22 | | (letrec ((Label (lambda (UVar *) 23 | (bind-free (UVar *) Expr))) *) 24 | (closures ((UVar Label UVar *) *) Expr)) 25 | | (if Expr Expr Expr) 26 | | (begin Expr * Expr) 27 | | (ValPrim Expr *) 28 | | (EffectPrim Expr *) 29 | | (PredPrim Expr *) 30 | | (Expr Expr *) 31 | | UVar 32 | | Label 33 | Immediate ::= fixnum | () | #t | #f 34 | 35 | Output: 36 | Prog ::= Expr 37 | Expr ::= (quote Immediate) 38 | | (let ([UVar Expr]*) Expr) 39 | | (letrec ((Label (lambda (UVar *) Expr)) *) Expr) ;; mod 40 | | (if Expr Expr Expr) 41 | | (begin Expr * Expr) 42 | | (ValPrim Expr *) 43 | | (EffectPrim Expr *) 44 | | (PredPrim Expr *) 45 | | (Expr Expr *) 46 | | UVar 47 | | Label 48 | Immediate ::= fixnum | () | #t | #f 49 | 50 | |# 51 | 52 | (library (Compiler introduce-procedure-primitives) 53 | (export introduce-procedure-primitives) 54 | (import 55 | (chezscheme) 56 | (Framework match) 57 | (Framework helpers) 58 | (Compiler utils) 59 | (Compiler common)) 60 | 61 | (define-who introduce-procedure-primitives 62 | 63 | (define (index x ls) 64 | (let loop ([x x] [ls ls] [acc 0]) 65 | (cond 66 | [(null? ls) #f] 67 | [(eq? x (car ls)) acc] 68 | [else (loop x (cdr ls) (add1 acc))]))) 69 | 70 | (define (immediate? imm) 71 | (or (memq imm '(#t #f ())) 72 | (and (integer? imm) 73 | (exact? imm) 74 | (fixnum-range? imm)))) 75 | 76 | ;; (procedure-ref proc i) 77 | ;; extracts the value from the ith free-variable slot of proc. 78 | (define (make-ref x ls) 79 | (cond 80 | [(index x (cdr ls)) => 81 | (lambda (i) 82 | `(procedure-ref ,(car ls) (quote ,i)))] ;; (car ls) === cp.* 83 | [else x])) 84 | 85 | ;; (procedure-set! proc i val) 86 | ;; stores val in the ith free-variable slot of proc. 87 | (define (make-set! x free) 88 | (let loop ([x x] [ls free]) 89 | (cond 90 | [(null? ls) '()] 91 | [else (cons `(procedure-set! ,x (quote ,(index (car ls) free)) ,(car ls)) 92 | (loop x (cdr ls)))]))) 93 | 94 | (define (Expr free-ls) 95 | (lambda (expr) 96 | (match expr 97 | [(quote ,i) (guard (immediate? i)) 98 | `(quote ,i)] 99 | [(let ([,uvar* ,[exp*]] ...) ,[exp]) 100 | `(let ([,uvar* ,exp*] ...) ,exp)] 101 | [(letrec ((,label* ,[Lambda -> lam*]) ...) ,[(Closure free-ls) -> expr]) 102 | `(letrec ([,label* ,lam*] ...) ,expr)] 103 | [(if ,[test] ,[then] ,[else]) 104 | `(if ,test ,then ,else)] 105 | [(begin ,[exp*] ... ,[exp]) 106 | `(begin ,exp* ... ,exp)] 107 | [(,prim ,[exp*] ...) (guard (or (prim? prim) (label? prim))) ;; oh 108 | `(,prim ,exp* ...)] 109 | [(,[rator] ,[rator] ,[rand*] ...) 110 | `((procedure-code ,rator) ,rator ,rand* ...)] 111 | [,uvar (guard (uvar? uvar)) (make-ref uvar free-ls)] 112 | [,el (errorf who "Invalid Expr ~s" el)]))) 113 | 114 | ;; Lambda doesn't need to carry a free-list 115 | (define Lambda 116 | (lambda (lam) 117 | (match lam 118 | [(lambda (,cp ,arg* ...) 119 | (bind-free (,cp ,freev* ...) 120 | ,[(Expr `(,cp ,@freev*)) -> exp])) 121 | `(lambda (,cp ,arg* ...) ,exp)] 122 | [,el (errorf who "Invalid Lambda ~s" el)]))) 123 | 124 | (define (Closure free-ls) 125 | (lambda (cls) 126 | (match cls 127 | [(closures ([,uvar* ,label* ,[(Expr free-ls) -> freev*] ...] ...) 128 | ,[(Expr free-ls) -> exp]) 129 | (let ([len* (map length freev*)] 130 | [pset!* (map make-set! uvar* freev*)]) 131 | `(let ([,uvar* (make-procedure ,label* (quote ,len*))] ...) 132 | (begin 133 | ,pset!* ... ... ;; oh. found you. 134 | ,exp)))] 135 | [,el (errorf who "Invalid Closure ~s" el)]))) 136 | 137 | (lambda (prog) 138 | ((Expr '(?!hukarz*^)) prog))) 139 | ) 140 | -------------------------------------------------------------------------------- /Compiler/lift-letrec.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A12 - Apr 12, 2015 4 | modified `common.ss` to support closure & first-class procedures: 5 | - primitives += make-procedure procedure-code procedure-ref procedure-set! procedure? 6 | 7 | A11 - Apr 03, 2015 8 | 9 | pass: lift-letrec 10 | 11 | This pass simply moves all letrec bindings from where they appear into a letrec expression wrapped around the outermost expression, removing all of the internal letrec expressions in the process. 12 | 13 | 14 | Input: 15 | Prog ::= Expr 16 | Expr ::= (quote Immediate) 17 | | (let ([UVar Expr] *) Expr) 18 | | (letrec ((Label (lambda (UVar *) Expr)) *) Expr) 19 | | (if Expr Expr Expr) 20 | | (begin Expr * Expr) 21 | | (ValPrim Expr *) 22 | | (EffectPrim Expr *) 23 | | (PredPrim Expr *) 24 | | (Expr Expr *) 25 | | UVar 26 | | Label 27 | Immediate ::= fixnum | () | #t | #f 28 | 29 | Output: 30 | Prog ::= (letrec ((Label (lambda (UVar *) Expr)) *) Expr) ;; mod 31 | Expr ::= (quote Immediate) 32 | | (let ([UVar Expr] *) Expr) 33 | | (if Expr Expr Expr) 34 | | (begin Expr * Expr) 35 | | (ValPrim Expr *) 36 | | (EffectPrim Expr *) 37 | | (PredPrim Expr *) 38 | | (Expr Expr *) 39 | | UVar 40 | | Label 41 | Immediate ::= fixnum | () | #t | #f 42 | 43 | |# 44 | 45 | 46 | (library (Compiler lift-letrec) 47 | (export lift-letrec) 48 | (import 49 | (chezscheme) 50 | (Framework helpers) 51 | (Framework match) 52 | (Compiler common)) 53 | 54 | (define-who lift-letrec 55 | 56 | (define foldl 57 | (lambda (f n ls) 58 | (cond 59 | [(null? ls) n] 60 | [else (foldl f (f n (car ls)) (cdr ls))]))) 61 | 62 | (define top-letrecs '()) 63 | 64 | (define (update-top-letrecs bind*) 65 | (set! top-letrecs 66 | (foldl (lambda (x y) (cons y x)) top-letrecs bind*))) 67 | 68 | (define (Immediate imm) 69 | (match imm 70 | [,x (guard (memq imm '(#t #f ()))) x] 71 | [,n (guard (and (integer? imm) 72 | (exact? imm) 73 | (fixnum-range? imm))) 74 | n] 75 | [,el (errorf who "invalid Immediate ~s" el)])) 76 | 77 | (define (Expr expr) 78 | (match expr 79 | [(quote ,[Immediate -> x]) `(quote ,x)] 80 | [(let ([,uvar ,[bind-e]] ...) ,[body-e]) 81 | `(let ([,uvar ,bind-e] ...) ,body-e)] 82 | [(letrec ([,label* (lambda (,uvar* ...) ,[body*])] ...) ,[body]) 83 | (begin 84 | (update-top-letrecs 85 | `([,label* (lambda (,uvar* ...) ,body*)] ...)) 86 | body)] 87 | [(if ,[test] ,[then] ,[else]) 88 | `(if ,test ,then ,else)] 89 | [(begin ,[e*] ... ,[e]) 90 | `(begin ,e* ... ,e)] 91 | [(,prim ,[e*] ...) (guard (prim? prim)) 92 | `(,prim ,e* ...)] 93 | [(,[rator] ,[rand*] ...) 94 | `(,rator ,rand* ...)] 95 | [,uvar (guard (uvar? uvar)) uvar] 96 | [,lab (guard (label? lab)) lab] 97 | [,el (errorf who "invalid Expr ~s" el)])) 98 | 99 | (lambda (prog) 100 | (set! top-letrecs '()) ;; hmm... should not need to manually reset this. 101 | (let ([new-expr (Expr prog)]) 102 | `(letrec ,top-letrecs ,new-expr)))) 103 | 104 | ) 105 | -------------------------------------------------------------------------------- /Compiler/optimize-direct-call.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A13 - Apr 17, 2015 4 | 5 | pass: optimize-direct-call 6 | 7 | all anonymous functions calls (possibly created by a macro expander) become let bindings 8 | - e.g. ((lambda (x) x) 3) -> (let ([x 3]) x) 9 | 10 | why? 11 | - avoids an unecessary heap allocation, an indirect jump, and, when there are free variables in the body, some additional indirect memory references. If the expression is evaluated frequently, the savings from this nearly trivial optimization can be significant 12 | 13 | Input & Output Grammar: 14 | Prog ::= Expr 15 | Expr ::= (quote Immediate) 16 | | (let ([UVar Expr] *) Expr) 17 | | (letrec ([UVar Lamb] *) Expr) 18 | | (if Expr Expr Expr) 19 | | (begin Expr * Expr) 20 | | (ValPrim Expr *) 21 | | (EffectPrim Expr *) 22 | | (PredPrim Expr *) 23 | | (Expr Expr *) 24 | | Lamb 25 | | UVar 26 | Lamb ::= (lambda (UVar *) Expr) 27 | Immediate ::= fixnum | () | #t | #f 28 | 29 | |# 30 | 31 | (library (Compiler optimize-direct-call) 32 | (export optimize-direct-call) 33 | (import 34 | (chezscheme) 35 | (Framework match) 36 | (Framework helpers) 37 | (Compiler utils) 38 | (Compiler common)) 39 | 40 | (define-who optimize-direct-call 41 | 42 | (define (optimize expr) 43 | (match expr 44 | [(lambda (,uvar* ...) ,[exp]) 45 | `(lambda (,uvar* ...) ,exp)] 46 | [((lambda (,uvar* ...) ,[exp]) ,[rand*] ...) 47 | (if (= (length rand*) (length uvar*)) ;; lengths match? 48 | `(let ([,uvar* ,rand*] ...) ,exp) 49 | `((lambda (,uvar* ...) ,exp) ,rand* ...))] 50 | [(quote ,i) (guard (immediate? i)) 51 | `(quote ,i)] 52 | [(let ([,uvar* ,[exp*]] ...) ,[exp]) 53 | `(let ([,uvar* ,exp*] ...) ,exp)] 54 | [(letrec ([,uvar* ,[lamb*]] ...) ,[exp]) 55 | `(letrec ([,uvar* ,lamb*] ...) ,exp)] 56 | [(if ,[test] ,[then] ,[else]) 57 | `(if ,test ,then ,else)] 58 | [(begin ,[exp*] ... ,[exp]) 59 | `(begin ,exp* ... ,exp)] 60 | [(,prim ,[exp*] ...) (guard (prim? prim)) 61 | `(,prim ,exp* ...)] 62 | [(,[rator] ,[rand*] ...) 63 | `(,rator ,rand* ...)] 64 | [,uvar (guard (uvar? uvar)) uvar] 65 | [,el (errorf who "Invalid Expr ~s" el)])) 66 | 67 | (lambda (prog) 68 | (optimize prog))) 69 | ) 70 | 71 | 72 | 73 | -------------------------------------------------------------------------------- /Compiler/optimize-jumps.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A11 - Apr 03, 2015 4 | 5 | pass: optimize-jumps 6 | 7 | This pass removes redundant jumps (function calls) from the code. 8 | 9 | how it works: 10 | 1. find all redundant stuffs (`[label (lambda () (jump))]`), then add relations (label -> jump) to a graph 11 | 2. remove all the bindings as above; for circular (mutual) references, add a dummy binding to the program (e.g., `[f$1 (lambda () (f$1))]`) 12 | 3. replace all old labels in the body with the new labels (meaningful ones) 13 | 14 | Input & Output: 15 | Program ::= (letrec ((Label (lambda () Tail)) *) Tail) ;; 16 | Tail ::= (if (Relop Triv Triv) (Label) (Label)) ;; 17 | | (begin Effect * Tail) 18 | | (Triv) 19 | Effect ::= (set! Loc Triv) ;; 20 | | (set! Loc (Binop Triv Triv)) ;; 21 | Triv ::= Loc ;; 22 | | Integer | Label 23 | Loc ::= Reg | Disp | Ind ;; 24 | 25 | 26 | |# 27 | 28 | 29 | (library (Compiler optimize-jumps) 30 | (export optimize-jumps) 31 | (import 32 | (chezscheme) 33 | (Framework helpers) 34 | (Framework match) 35 | (Compiler common) 36 | (Compiler utils)) 37 | 38 | (define-who optimize-jumps 39 | 40 | (define (get-new-def*-and-jump-table defs*) 41 | (let loop ([defs* defs*] [jump-table '()] [acc '()]) 42 | (cond 43 | [(null? defs*) (values (reverse acc) (reverse jump-table))] 44 | [(null? (car defs*)) (loop (cdr defs*) jump-table acc)] 45 | [(label? (caar (cddadr (car defs*)))) ;; i know, i know... but it works. 46 | (loop (cdr defs*) 47 | (graphq-add (caar defs*) `(,(caar (cddadr (car defs*)))) jump-table) 48 | acc)] 49 | [else (loop (cdr defs*) jump-table (cons (car defs*) acc))]))) 50 | 51 | (define (resolve-jt-and-new-defs old-labels jump-table) 52 | (let loop ([labels old-labels] [acc '()] [optional-new-defs '()]) 53 | (cond 54 | [(null? labels) (values (reverse acc) (reverse optional-new-defs))] 55 | [(null? (graphq-dfs (car labels) jump-table)) ;; oops, circular references 56 | (loop (cdr labels) 57 | acc 58 | (cons `[,(car labels) (lambda () (,(car labels)))] optional-new-defs))] 59 | [else (loop (cdr labels) 60 | (cons `(,(car labels) . ,(car (graphq-dfs (car labels) jump-table))) acc) 61 | optional-new-defs)]))) 62 | 63 | (define replace-label 64 | (lambda (j-pairs) 65 | (lambda (label) 66 | (cond 67 | [(assq label j-pairs) => cdr] 68 | [else label])))) 69 | 70 | (define Tail 71 | (lambda (j-pairs) 72 | (lambda (tail) 73 | (match tail 74 | [(if (,relop ,[(Triv j-pairs) -> triv1] ,[(Triv j-pairs) -> triv2]) 75 | (,label1) (,label2)) 76 | `(if (,relop ,triv1 ,triv2) 77 | (,((replace-label j-pairs) label1)) 78 | (,((replace-label j-pairs) label2)))] 79 | [(begin ,[(Effect j-pairs) -> ef*] ... ,[tail]) 80 | `(begin ,ef* ... ,tail)] 81 | [(,[(Triv j-pairs) -> triv]) `(,triv)] 82 | [,el (errorf who "Invalid Tail ~s" el)])))) 83 | 84 | (define Effect 85 | (lambda (j-pairs) 86 | (lambda (effect) 87 | (match effect 88 | [(set! ,loc (,binop ,[(Triv j-pairs) -> triv1] ,[(Triv j-pairs) -> triv2])) 89 | `(set! ,loc (,binop ,triv1 ,triv2))] 90 | [(set! ,loc ,[(Triv j-pairs) -> triv]) 91 | `(set! ,loc ,triv)] 92 | [,el (errorf who "Invalid Effect ~s" el)])))) 93 | 94 | (define Triv 95 | (lambda (j-pairs) 96 | (lambda (triv) 97 | (match triv 98 | [,int (guard (integer? int)) int] 99 | [,lab (guard (label? lab)) ((replace-label j-pairs) lab)] 100 | [,el el])))) ;; loc 101 | 102 | (lambda (prog) 103 | (match prog 104 | [(letrec (,def* ...) ,tail) ;; def: [,label* (lambda () ,tail*)] 105 | (let-values ([(new-def jump-table) (get-new-def*-and-jump-table def*)]) ;; generate new defs (without redundant jumps), and a graph for relations 106 | (let-values ([(j-pairs new-defs-for-circular) ;; reduce the graph to an easy assoc. list, also gets dummy defs for mutual references 107 | (resolve-jt-and-new-defs (map car jump-table) jump-table)]) 108 | (match `(letrec ,(append new-def new-defs-for-circular) ,tail) 109 | [(letrec ([,f-label* (lambda () ,[(Tail j-pairs) -> f-tail*])] ...) 110 | ,[(Tail j-pairs) -> f-tail]) 111 | `(letrec ([,f-label* (lambda () ,f-tail*)] ...) ,f-tail)])))]))) 112 | ) 113 | 114 | -------------------------------------------------------------------------------- /Compiler/optimize-known-call.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A13 - Apr 17, 2015 4 | 5 | pass: optimize-known-call 6 | 7 | indirect call 8 | - rather than calling the closed procedure directly, the code calls indirect through the closure 9 | - suitable for anonymous calls, calls in which the call site does not know exactly which procedure is being invoked 10 | 11 | This pass therefore converts calls to closures-bound variables into direct calls to the corresponding closed procedures. If f.n is a closures-bound variable, and f$n is the label of the corresponding closed procedure, then 12 | 13 | (f.n e1 ...) -> 14 | (f$n e1 ...) 15 | 16 | Input & Output: 17 | Prog ::= Expr 18 | Expr ::= (quote Immediate) 19 | | (let ([UVar Expr] *) Expr) 20 | | (letrec ((Label (lambda (UVar *) 21 | (bind-free (UVar *) Expr))) *) 22 | (closures ((UVar Label UVar *) *) Expr)) 23 | | (if Expr Expr Expr) 24 | | (begin Expr * Expr) 25 | | (ValPrim Expr *) 26 | | (EffectPrim Expr *) 27 | | (PredPrim Expr *) 28 | | (Expr Expr *) 29 | | UVar 30 | | Label 31 | Immediate ::= fixnum | () | #t | #f 32 | 33 | |# 34 | 35 | (library (Compiler optimize-known-call) 36 | (export optimize-known-call) 37 | (import 38 | (chezscheme) 39 | (Framework match) 40 | (Framework helpers) 41 | (Compiler utils) 42 | (Compiler common)) 43 | 44 | (define-who optimize-known-call 45 | 46 | (define (lookup x table) 47 | (cond 48 | [(assq x table) => cadr] 49 | [else #f])) 50 | 51 | (define (Expr table) 52 | (lambda (expr) 53 | (match expr 54 | [(quote ,i) (guard (immediate? i)) `(quote ,i)] 55 | [(let ([,uvar* ,[expr*]] ...) ,[expr]) 56 | `(let ([,uvar* ,expr*] ...) ,expr)] 57 | [(letrec ([,label* (lambda (,arg* ...) 58 | (bind-free (,uvar* ...) ,[expr*]))] ...) 59 | (closures ([,cvar* ,clabel* ,cvar** ...] ...) ,[expr])) 60 | (let* ([binds `([,cvar* ,clabel*] ...)] 61 | [table (append binds table)] 62 | [expr* (map (Expr table) expr*)] ;; hmm. any chance of getting new bindings here? 63 | [expr ((Expr table) expr)]) 64 | `(letrec ([,label* (lambda (,arg* ...) 65 | (bind-free (,uvar* ...) ,expr*))] ...) 66 | (closures ([,cvar* ,clabel* ,cvar** ...] ...) ,expr)))] 67 | [(if ,[test] ,[then] ,[else]) 68 | `(if ,test ,then ,else)] 69 | [(begin ,[expr*] ... ,[expr]) 70 | `(begin ,expr* ... ,expr)] 71 | [(,prim ,[expr*] ...) (guard (prim? prim)) 72 | `(,prim ,expr* ...)] 73 | [(,[rator] ,[rand*] ...) 74 | (let ([rator (or (lookup rator table) rator)]) 75 | `(,rator ,rand* ...))] 76 | [,uvar (guard (uvar? uvar)) uvar] 77 | [,label (guard (label? label)) label] 78 | [,el (errorf who "Invalid Expr ~s" el)]))) 79 | 80 | (lambda (prog) 81 | ((Expr '()) prog))) 82 | ) 83 | 84 | 85 | 86 | 87 | 88 | 89 | -------------------------------------------------------------------------------- /Compiler/optimize-source.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A15 - May 3, 2015 4 | 5 | Challenge B: optimize-source 6 | 7 | Implemented a simplified version of: 8 | - Constant folding 9 | - Dead-code elimination 10 | 11 | Input & Output: 12 | Prog ::= Expr 13 | Expr ::= (quote Immediate) 14 | | (let ([UVar Expr] *) Expr) 15 | | (letrec ((Label (lambda (UVar *) Expr)) *) Expr) 16 | | (if Expr Expr Expr) 17 | | (begin Expr * Expr) 18 | | (ValPrim Expr *) 19 | | (EffectPrim Expr *) 20 | | (PredPrim Expr *) 21 | | (Expr Expr *) 22 | | UVar 23 | | Label 24 | Immediate ::= fixnum | () | #t | #f 25 | 26 | |# 27 | 28 | (library (Compiler optimize-source) 29 | (export optimize-source) 30 | (import 31 | (chezscheme) 32 | (Framework match) 33 | (Framework helpers) 34 | (Compiler utils) 35 | (Compiler common) 36 | (Compiler pmunit)) 37 | 38 | (define-who optimize-source 39 | 40 | (define (constant? x) 41 | (or (memq x '(#t #f ())) 42 | (and (and (integer? x) (exact? x)) 43 | (or (fixnum-range? x) 44 | (errorf who "integer ~s is out of fixnum range" x))))) 45 | 46 | (define (valid-num? x) 47 | (and (and (integer? x) (exact? x)) 48 | (or (fixnum-range? x) 49 | (errorf who "integer ~s is out of fixnum range" x)))) 50 | 51 | (define (trivial-binding? binding) 52 | (match binding 53 | [(,lhs ,rhs) 54 | (cond 55 | [(constant? rhs) `(,lhs . ,rhs)] 56 | [(symbol? rhs) `(,lhs . ,rhs)] 57 | [else '()])])) 58 | 59 | (define (replace-vars exp env) 60 | (match exp 61 | [() '()] 62 | [,x (if (assq x env) 63 | (cdr (assq x env)) 64 | x)] 65 | [(,[a] . ,[d]) `(,a . ,d)])) 66 | 67 | (define (datum? x) 68 | (or (constant? x) 69 | (if (pair? x) 70 | (and (datum? (car x)) (datum? (cdr x))) 71 | (and (vector? x) (andmap datum? (vector->list x)))))) 72 | 73 | (define foldable-prims 74 | `((+ . ,valid-num?) (- . ,valid-num?) (* . ,valid-num?) 75 | (<= . ,valid-num?) (< . ,valid-num?) (= . ,valid-num?) (>= . ,valid-num?) (> . ,valid-num?) 76 | (boolean? . ,boolean?) (fixnum? . ,fixnum?) (null? . ,null?) (pair? . ,pair?) (vector? . ,vector?))) 77 | 78 | (define (Expr x) 79 | ;; an env lookup is the right way to do it. however, given limited time, this is a simplified approach to do the Constant folding and Dead-code elimination part. 80 | (match x 81 | [(quote ,i) (guard (immediate? i)) 82 | `(quote ,i)] 83 | [(let ([,uvar* ,[expr*]] ...) ,[expr]) 84 | `(let ([,uvar* ,expr*] ...) ,expr)] 85 | [(letrec ([,label* (lambda (,uvar* ...) ,[expr*])] ...) ,[expr]) 86 | `(letrec ([,label* (lambda (,uvar* ...) ,expr*)] ...) ,expr)] 87 | [(if ,[test] ,[then] ,[else]) 88 | (cond 89 | [(equal? test ''#t) then] 90 | [(equal? test ''#f) else] 91 | [else `(if ,test ,then ,else)])] 92 | [(begin ,[expr*] ... ,[expr]) 93 | `(begin ,expr* ... ,expr)] 94 | [(,prim ,[expr*] ...) (guard (prim? prim)) 95 | (let ([check (assq prim foldable-prims)]) 96 | (if check 97 | (if (andmap (lambda (x) 98 | (if (pair? x) ;; safety check 99 | ((cdr check) (cadr x)) ;; cuz everything is quoted here 100 | #f)) 101 | expr*) 102 | `(quote ,(eval `(,prim ,expr* ...))) 103 | `(,prim ,expr* ...)) 104 | `(,prim ,expr* ...)))] 105 | [(,[rator] ,[rand*] ...) 106 | `(,rator ,rand* ...)] 107 | [,uvar (guard (uvar? uvar)) uvar] 108 | [,label (guard (label? label)) label] 109 | [,el (errorf who "Invalid Expr ~s" el)])) 110 | 111 | (lambda (prog) 112 | (Expr prog)) 113 | 114 | ;; (lambda (prog) prog) 115 | 116 | ;; (define (Expr env) 117 | ;; ;; env contains values for the copy-propagated values 118 | ;; ;; returns 3 values: the new expression, a list of the variables referenced in the new expression, and a flag indicating whether the new expression is useless if its value isn't needed 119 | ;; (lambda (x) 120 | ;; (match x 121 | ;; [(quote ,i) (guard (immediate? i)) 122 | ;; (values `(quote ,i) '() #t)] 123 | ;; [(let ([,uvar* ,expr*] ...) ,expr) 124 | ;; (let* ([this-env (map trivial-binding? `([,uvar* ,expr*] ...))] 125 | ;; [new-env (append this-env env)] 126 | ;; ))] 127 | ;; [(letrec ([,label* (lambda (,uvar* ...) ,[expr*])] ...) ,[expr]) 128 | ;; ] 129 | ;; [(if ,[test] ,[then] ,[else]) 130 | ;; ] 131 | ;; [(begin ,[expr*] ... ,[expr]) 132 | ;; ] 133 | ;; [(,prim ,[expr*] ...) (guard (prim? prim)) 134 | ;; (let ([check (assq prim foldable-prims)]) 135 | ;; (if check 136 | ;; (if (andmap (cdr check) expr*) ;; cool, fold it 137 | ;; (values (eval `(,prim ,expr* ...)) 138 | ;; '() 139 | ;; #t) 140 | ;; (values `(,prim ,expr* ...) 141 | ;; (filter symbol? expr*) 142 | ;; #t)) 143 | ;; (values `(,prim ,expr* ...) 144 | ;; (filter symbol? expr*) 145 | ;; #f))) ;; side effects 146 | ;; ] 147 | ;; [(,[rator] ,[rand*] ...) 148 | ;; ] 149 | ;; [,uvar (guard (uvar? uvar)) 150 | ;; ] 151 | ;; [,label (guard (label? label)) 152 | ;; ] 153 | ;; [,el (errorf who "Invalid Expr ~s" el)]))) 154 | 155 | 156 | ) 157 | ) 158 | -------------------------------------------------------------------------------- /Compiler/pmunit.ss: -------------------------------------------------------------------------------- 1 | (library (Compiler pmunit) 2 | (export pmdeb check-equal? pmt) 3 | (import (chezscheme)) 4 | 5 | (define-syntax pmdeb 6 | (syntax-rules () 7 | [(_ x) (printf "~s: ~s\n" 'x x)] 8 | [(_ x1 x2 ...) 9 | (begin 10 | (pmdeb x1) 11 | (pmdeb x2 ...))])) 12 | 13 | (define-syntax check-equal? 14 | (syntax-rules () 15 | [(_ e v) 16 | (if (equal? e v) 17 | #t 18 | (begin 19 | (printf 20 | "\n----------------\nFAIL\nactual: ~s \nexpected: ~s\nexp: ~s\n----------------\n" 21 | e v 'e) 22 | #f))])) 23 | 24 | (define-syntax check-equal?-with-num 25 | (syntax-rules () 26 | [(_ n e v) 27 | (if (equal? e v) 28 | #t 29 | (begin 30 | (printf 31 | "\n----------------\n#~s FAIL\nactual: ~s \nexpected: ~s\nexp: ~s\n----------------\n" 32 | n e v 'e) 33 | #f))])) 34 | 35 | (define-syntax pmt 36 | (syntax-rules () 37 | [(_ e1 ...) (pmt-aux 1 #t e1 ...)])) 38 | 39 | (define-syntax pmt-aux 40 | (syntax-rules () 41 | [(_ n b) (if b 42 | (printf "cool\n") 43 | (printf "not cool\n"))] 44 | [(_ n b (e v) e2 ...) 45 | (if b 46 | (pmt-aux (add1 n) (check-equal?-with-num n e v) e2 ...) 47 | (begin 48 | (check-equal?-with-num n e v) 49 | (pmt-aux (add1 n) #f e2 ...)))])) 50 | 51 | ) 52 | -------------------------------------------------------------------------------- /Compiler/pre-assign-frame.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A8 - Mar 6, 2015 4 | 5 | pass: pre-assign-frame 6 | 7 | This pass finds frame homes for the variables listed in the spills list. It differs from assign-frame only in the structure of the input and output Body forms. Like assign-frame, it eliminates the spills form but leaves behind the other forms. It also adds the locate form, which is not present in its input. 8 | 9 | Input Grammar: 10 | Program ::= (letrec ((Label (lambda () Body)) *) Body) 11 | Body ::= (locals (UVar *) 12 | (new-frames (Frame *) 13 | (spills (UVar *) 14 | (frame-conflict ((UVar Var *) *) 15 | (call-live (UFVar *) Tail))))) 16 | Tail ::= (if Pred Tail Tail) 17 | | (begin Effect * Tail) 18 | | (Triv Var *) ;; Note 'Var' not 'Loc'. 19 | Pred ::= (true) 20 | | (false) 21 | | (if Pred Pred Pred) 22 | | (begin Effect * Pred) 23 | | (Relop Triv Triv) 24 | Effect ::= (nop) 25 | | (set! Var Triv) 26 | | (set! Var (Binop Triv Triv)) 27 | | (set! Var (mref Triv Triv)) ;; a8 new 28 | | (return-point Label Tail) 29 | | (mset! Triv Triv Triv) ;; a8 new 30 | | (if Pred Effect Effect) 31 | | (begin Effect * Effect) 32 | Triv ::= Var 33 | | Integer | Label 34 | Loc ::= Reg | FVar 35 | Var ::= UVar | Loc 36 | Frame ::= (Uvar *) 37 | UFVar ::= UVar | FVar 38 | 39 | Output Grammar: 40 | Program ::= (letrec ((Label (lambda () Body)) *) Body) 41 | Body ::= (locals (UVar *) ;; mod 42 | (new-frames (Frame *) 43 | (locate ((UVar FVar) *) 44 | (frame-conflict ((UVar Var *) *) 45 | (call-live (UFVar *) Tail))))) 46 | Tail ::= (if Pred Tail Tail) 47 | | (begin Effect * Tail) 48 | | (Triv Var *) ;; Note 'Var' not 'Loc'. 49 | Pred ::= (true) 50 | | (false) 51 | | (if Pred Pred Pred) 52 | | (begin Effect * Pred) 53 | | (Relop Triv Triv) 54 | Effect ::= (nop) 55 | | (set! Var Triv) 56 | | (set! Var (Binop Triv Triv)) 57 | | (set! Var (mref Triv Triv)) ;; a8 new 58 | | (return-point Label Tail) 59 | | (mset! Triv Triv Triv) ;; a8 new 60 | | (if Pred Effect Effect) 61 | | (begin Effect * Effect) 62 | Triv ::= Var 63 | | Integer | Label 64 | Loc ::= Reg | FVar 65 | Var ::= UVar | Loc 66 | Frame ::= (Uvar *) 67 | UFVar ::= UVar | FVar 68 | 69 | |# 70 | 71 | (library (Compiler pre-assign-frame) 72 | (export pre-assign-frame) 73 | (import 74 | (chezscheme) 75 | (Framework match) 76 | (Framework helpers)) 77 | 78 | (define-who pre-assign-frame 79 | 80 | (define find-used 81 | (lambda (conflict* home*) 82 | (cond 83 | [(null? conflict*) '()] 84 | [(frame-var? (car conflict*)) 85 | (set-cons (car conflict*) (find-used (cdr conflict*) home*))] 86 | [(assq (car conflict*) home*) => 87 | (lambda (x) (set-cons (cadr x) (find-used (cdr conflict*) home*)))] 88 | [else (find-used (cdr conflict*) home*)]))) 89 | 90 | (define find-frame-var 91 | (lambda (used*) 92 | (let f ([index 0]) 93 | (let ([fv (index->frame-var index)]) 94 | (if (memq fv used*) (f (+ index 1)) fv))))) 95 | 96 | (define find-homes 97 | (lambda (var* ct home*) 98 | (if (null? var*) 99 | home* 100 | (let ([var (car var*)] [var* (cdr var*)]) 101 | (let ([conflict* (cdr (assq var ct))]) 102 | (let ([home (find-frame-var (find-used conflict* home*))]) 103 | (find-homes var* ct `((,var ,home) . ,home*)))))))) 104 | 105 | (define Body 106 | (lambda (body) 107 | (match body 108 | [(locals (,local* ...) 109 | (new-frames (,frame* ...) 110 | (spills (,spill* ...) 111 | (frame-conflict ,ct 112 | (call-live (,call-live* ...) 113 | ,tail))))) 114 | (let ([home* (find-homes spill* ct '())]) 115 | `(locals (,local* ...) 116 | (new-frames (,frame* ...) 117 | (locate (,home* ...) 118 | (frame-conflict ,ct 119 | (call-live (,call-live* ...) 120 | ,tail))))))] 121 | [,body (error who "invalid Body ~s" body)]))) 122 | 123 | (lambda (x) 124 | (match x 125 | [(letrec ([,label* (lambda () ,[Body -> body*])] ...) ,[Body -> body]) 126 | `(letrec ([,label* (lambda () ,body*)] ...) ,body)] 127 | [,x (error who "invalid Program ~s" x)]))) 128 | 129 | ) 130 | -------------------------------------------------------------------------------- /Compiler/remove-anonymous-lambda.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A13 - Apr 17, 2015 4 | 5 | pass: remove-anonymous-lambda 6 | 7 | This pass introduces a unique name for each lambda expression that does not appear as the right-hand side of a let or letrec expression. 8 | (lambda (formal ...) body) -> 9 | (letrec ([anon.n (lambda (formal ...) body)]) 10 | anon.n) 11 | 12 | Although optimize-direct-call, which runs before this pass, eliminates anonymous lambda expressions that appear in operator position, we do not rely on this here since optimize-direct-call is an optimization pass and might not be enabled 13 | 14 | Input Grammar: 15 | Prog ::= Expr 16 | Expr ::= (quote Immediate) 17 | | (let ([UVar Expr] *) Expr) 18 | | (letrec ([UVar Lamb] *) Expr) 19 | | (if Expr Expr Expr) 20 | | (begin Expr * Expr) 21 | | (ValPrim Expr *) 22 | | (EffectPrim Expr *) 23 | | (PredPrim Expr *) 24 | | (Expr Expr *) 25 | | Lamb 26 | | UVar 27 | Lamb ::= (lambda (UVar *) Expr) 28 | Immediate ::= fixnum | () | #t | #f 29 | 30 | Output Grammar: 31 | Prog ::= Expr 32 | Expr ::= (quote Immediate) 33 | | (let ([UVar LambdaOrExpr] *) Expr) ;; mod 34 | | (letrec ([UVar Lamb] *) Expr) 35 | | (if Expr Expr Expr) 36 | | (begin Expr * Expr) 37 | | (ValPrim Expr *) 38 | | (EffectPrim Expr *) 39 | | (PredPrim Expr *) 40 | | (Expr Expr *) 41 | | UVar 42 | Lamb ::= (lambda (UVar *) Expr) 43 | LambdaOrExpr ::= Lamb | Expr 44 | Immediate ::= fixnum | () | #t | #f 45 | 46 | |# 47 | 48 | (library (Compiler remove-anonymous-lambda) 49 | (export remove-anonymous-lambda) 50 | (import 51 | (chezscheme) 52 | (Framework match) 53 | (Framework helpers) 54 | (Compiler utils) 55 | (Compiler common)) 56 | 57 | (define-who remove-anonymous-lambda 58 | 59 | (define (remove expr) 60 | (match expr 61 | [(lambda (,uvar* ...) ,[exp]) 62 | (let ([anon (unique-name 'anon)]) 63 | `(letrec ([,anon (lambda (,uvar* ...) ,exp)]) 64 | ,anon))] 65 | [(quote ,i) (guard (immediate? i)) 66 | `(quote ,i)] 67 | [(let ([,name* (lambda (,uvar* ...) ,[exp*])] ...) ,[exp]) ;; catch early 68 | `(let ([,name* (lambda (,uvar* ...) ,exp*)] ...) ,exp)] 69 | [(let ([,uvar* ,[exp*]] ...) ,[exp]) ;; exp*: non-lambda case 70 | `(let ([,uvar* ,exp*] ...) ,exp)] 71 | [(letrec ([,name* (lambda (,uvar* ...) ,[exp*])] ...) ,[exp]) 72 | `(letrec ([,name* (lambda (,uvar* ...) ,exp*)] ...) ,exp)] 73 | [(if ,[test] ,[then] ,[else]) 74 | `(if ,test ,then ,else)] 75 | [(begin ,[exp*] ... ,[exp]) 76 | `(begin ,exp* ... ,exp)] 77 | [(,prim ,[exp*] ...) (guard (prim? prim)) 78 | `(,prim ,exp* ...)] 79 | [(,[rator] ,[rand*] ...) 80 | `(,rator ,rand* ...)] 81 | [,uvar (guard (uvar? uvar)) uvar] 82 | [,el (errorf who "Invalid Expr ~s" el)])) 83 | 84 | (lambda (prog) 85 | (remove prog))) 86 | ) 87 | 88 | 89 | 90 | 91 | -------------------------------------------------------------------------------- /Compiler/remove-complex-opera*.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A8 - Mar 6, 2015 4 | 5 | pass: remove-complex-opera* 6 | 7 | This pass removes nested primitive calls from within procedure calls and other primitive calls, making the argument values "trivial". 8 | 9 | The subexpressions of primitive calls and procedure calls are now Triv expressions rather than Value expressions. In order to carry this out, each nontrivial Value must be assigned outside of the call to a fresh unique variable. 10 | 11 | The set of new unique variables introduced during this process must be added to the locals list enclosing the body. 12 | 13 | input grammar changes: 14 | Tail ::= (alloc Value) ;; a8n 15 | | (mref Value Value) ;; a8n 16 | 17 | Effect ::= (mset! Value Value Value) ;; a8n 18 | 19 | Value ::= (alloc Value) ;; a8n 20 | | (mref Value Value) ;; a8n 21 | 22 | output grammar: 23 | Program ::= (letrec ([Label (lambda (UVar *) Body)] *) Body) 24 | Body ::= (locals (UVar *) Tail) 25 | Tail ::= (if Pred Tail Tail) 26 | | (begin Effect * Tail) 27 | | (alloc Triv) ;; a8n, mod 28 | | (mref Triv Triv) ;; a8n, mod 29 | | (Binop Triv Triv) ;; mod 30 | | (Triv Triv *) ;; mod 31 | | Triv 32 | Pred ::= (true) 33 | | (false) 34 | | (if Pred Pred Pred) 35 | | (begin Effect * Pred) 36 | | (Relop Triv Triv) ;; mod 37 | Effect ::= (nop) 38 | | (set! UVar Value) 39 | | (mset! Triv Triv Triv) ;; a8n, mod 40 | | (if Pred Effect Effect) 41 | | (begin Effect * Effect) 42 | | (Triv Triv *) ;; mod 43 | Value ::= (if Pred Value Value) 44 | | (begin Effect * Value) 45 | | (alloc Triv) ;; a8n, mod 46 | | (mref Triv Triv) ;; a8n, mod 47 | | (Binop Triv Triv) ;; mod 48 | | (Triv Triv *) ;; mod 49 | | Triv 50 | Triv ::= UVar | Integer | Label 51 | 52 | |# 53 | 54 | (library (Compiler remove-complex-opera*) 55 | (export remove-complex-opera*) 56 | (import (chezscheme) (Framework helpers) (Framework match)) 57 | 58 | (define-who remove-complex-opera* 59 | 60 | (define (Body bd) 61 | 62 | (define new-local* '()) 63 | 64 | (define (new-t) 65 | (let ([t (unique-name 't)]) 66 | (set! new-local* (cons t new-local*)) 67 | t)) 68 | 69 | (define (trivialize-call expr*) 70 | (let-values ([(call set*) (break-down-expr* expr*)]) 71 | (make-begin `(,@set* ,call)))) 72 | 73 | (define (break-down-expr* expr*) 74 | (match expr* 75 | [() (values '() '())] 76 | [(,s . ,[rest* set*]) 77 | (guard (simple? s)) ;; now captures alloc, mref, mset 78 | (values `(,s ,rest* ...) set*)] 79 | [(,[Value -> expr] . ,[rest* set*]) 80 | (let ([t (new-t)]) 81 | (values `(,t ,rest* ...) `((set! ,t ,expr) ,set* ...)))] 82 | [,expr* (errorf who "invalid Expr ~s" expr*)])) 83 | 84 | (define (simple? x) ;; 85 | (or (uvar? x) (label? x) (and (integer? x) (exact? x)) 86 | (memq x '(+ - * logand logor sra)) (memq x '(= < <= > >=)) 87 | 88 | (ormap (lambda (s) (eq? s x)) '(alloc mref mset!)) ;; a8n 89 | )) 90 | 91 | (define (triv? x) (or (uvar? x) (int64? x) (label? x))) 92 | 93 | (define (Value val) ;; + (alloc Value) | (mref Value Value) 94 | (match val 95 | [(alloc ,v) (trivialize-call `(alloc ,v))] ;; a8n 96 | [(mref ,v1 ,v2) (trivialize-call `(mref ,v1 ,v2))] ;; a8n 97 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 98 | `(if ,test ,conseq ,altern)] 99 | [(begin ,[Effect -> ef*] ... ,[val]) 100 | (make-begin `(,ef* ... ,val))] 101 | [(,binop ,x ,y) 102 | (guard (memq binop '(+ - * logand logor sra))) 103 | (trivialize-call `(,binop ,x ,y))] 104 | [,tr (guard (triv? tr)) tr] 105 | [(,rator ,rand* ...) (trivialize-call `(,rator ,rand* ...))] 106 | [,val (errorf who "invalid Value ~s" val)])) 107 | 108 | (define (Effect ef) ;; + (mset! Value Value Value) 109 | (match ef 110 | [(mset! ,v1 ,v2 ,v3) ;; a8 new 111 | (trivialize-call `(mset! ,v1 ,v2 ,v3))] 112 | [(nop) '(nop)] 113 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 114 | `(if ,test ,conseq ,altern)] 115 | [(begin ,[ef*] ... ,[ef]) 116 | (make-begin `(,ef* ... ,ef))] 117 | [(set! ,var ,[Value -> val]) `(set! ,var ,val)] 118 | [(,rator ,rand* ...) (trivialize-call `(,rator ,rand* ...))] 119 | [,ef (errorf who "invalid Effect ~s" ef)])) 120 | 121 | (define (Pred pr) 122 | (match pr 123 | [(true) '(true)] 124 | [(false) '(false)] 125 | [(if ,[test] ,[conseq] ,[altern]) `(if ,test ,conseq ,altern)] 126 | [(begin ,[Effect -> ef*] ... ,[pr]) (make-begin `(,ef* ... ,pr))] 127 | [(,relop ,x ,y) 128 | (guard (memq relop '(< <= = >= >))) 129 | (trivialize-call `(,relop ,x ,y))] 130 | [,pr (errorf who "invalid Pred ~s" pr)])) 131 | 132 | (define (Tail tail) ;; + (alloc Value) | (mref Value Value) 133 | (match tail 134 | [(alloc ,v) (trivialize-call `(alloc ,v))] 135 | [(mref ,v1 ,v2) (trivialize-call `(mref ,v1 ,v2))] 136 | [(if ,[Pred -> test] ,[conseq] ,[altern]) 137 | `(if ,test ,conseq ,altern)] 138 | [(begin ,[Effect -> ef*] ... ,[tail]) (make-begin `(,ef* ... ,tail))] 139 | [(,binop ,x ,y) 140 | (guard (memq binop '(+ - * logand logor sra))) 141 | (trivialize-call `(,binop ,x ,y))] 142 | [(,rator ,rand* ...) (trivialize-call `(,rator ,rand* ...))] 143 | [,tr (guard (triv? tr)) tr] 144 | [,tail (errorf who "invalid Tail ~s" tail)])) 145 | 146 | (match bd 147 | [(locals (,local* ...) ,[Tail -> tail]) 148 | `(locals (,local* ... ,new-local* ...) ,tail)] 149 | [,bd (errorf who "invalid Body ~s" bd)])) 150 | 151 | (lambda (x) 152 | (match x 153 | [(letrec ([,label* (lambda (,fml** ...) ,[Body -> bd*])] ...) 154 | ,[Body -> bd]) 155 | `(letrec ([,label* (lambda (,fml** ...) ,bd*)] ...) ,bd)] 156 | [,x (errorf who "invalid Program ~s" x)]))) 157 | 158 | ) 159 | -------------------------------------------------------------------------------- /Compiler/remove-let.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A9 - Mar 28, 2015 4 | 5 | pass: remove-let 6 | 7 | This pass replaces each let expression in the input program with set! expressions, i.e., performs a conversion like the following: 8 | 9 | (let ([x e] ...) body) (begin (set! x e) ... new-body) 10 | 11 | where new-body is the result of recursively processing body. 12 | 13 | Input: 14 | Prog ::= (letrec ((Label (lambda (UVar *) Body)) *) Body) 15 | Body ::= (locals (UVar *) Tail) 16 | Tail ::= (let ([UVar Value] *) Tail) 17 | | (if Pred Tail Tail) 18 | | (begin Effect * Tail) 19 | | (alloc Value) 20 | | (mref Value Value) 21 | | (Binop Value Value) 22 | | (Value Value *) 23 | | Triv 24 | Pred ::= (let ([UVar Value] *) Pred) 25 | | (true) 26 | | (false) 27 | | (if Pred Pred Pred) 28 | | (begin Effect * Pred) 29 | | (Relop Value Value) 30 | Effect ::= (let ([UVar Value]*) Effect) 31 | | (nop) 32 | | (mset! Value Value Value) 33 | | (if Pred Effect Effect) 34 | | (begin Effect * Effect) 35 | | (Value Value *) 36 | Value ::= (let ([UVar Value] *) Value) 37 | | (if Pred Value Value) 38 | | (begin Effect * Value) 39 | | (alloc Value) 40 | | (mref Value Value) 41 | | (Binop Value Value) 42 | | (Value Value *) 43 | | Triv 44 | Triv ::= UVar | Integer | Label 45 | 46 | Output: UIL 47 | Prog ::= (letrec ([Label (lambda (UVar *) Body)] *) Body) 48 | Body ::= (locals (UVar *) Tail) 49 | Tail ::= (if Pred Tail Tail) 50 | | (begin Effect * Tail) 51 | | (alloc Value) 52 | | (mref Value Value) 53 | | (Binop Value Value) 54 | | (Value Value *) 55 | | Triv 56 | Pred ::= (true) 57 | | (false) 58 | | (if Pred Pred Pred) 59 | | (begin Effect * Pred) 60 | | (Relop Value Value) 61 | Effect ::= (nop) 62 | | (set! UVar Value) 63 | | (mset! Value Value Value) 64 | | (if Pred Effect Effect) 65 | | (begin Effect * Effect) 66 | | (Value Value *) 67 | Value ::= (if Pred Value Value) 68 | | (begin Effect * Value) 69 | | (alloc Value) 70 | | (mref Value Value) 71 | | (Binop Value Value) 72 | | (Value Value *) 73 | | Triv 74 | Triv ::= UVar | Integer | Label 75 | 76 | |# 77 | 78 | (library (Compiler remove-let) 79 | (export remove-let) 80 | (import 81 | (chezscheme) 82 | (Framework match) 83 | (Framework helpers) 84 | (Compiler utils) 85 | (Compiler common)) 86 | 87 | (define-who remove-let 88 | 89 | (define (Body body) 90 | 91 | (define (Value value) 92 | (match value 93 | [(let ([,uvar* ,[Value -> value*]] ...) ,[v]) 94 | (make-begin `((set! ,uvar* ,value*) ... ,v))] ;; 95 | [(if ,[Pred -> test] ,[then] ,[else]) `(if ,test ,then ,else)] 96 | [(begin ,[Effect -> ef*] ... ,[v]) 97 | (make-begin `(,ef* ... ,v))] ;; 98 | [(alloc ,[v]) `(alloc ,v)] 99 | [(,binop ,[v1] ,[v2]) (guard (binop? binop)) 100 | `(,binop ,v1 ,v2)] 101 | [(,[rator] ,[rand*] ...) 102 | `(,rator ,rand* ...)] 103 | [,t (guard (triv? t)) t] 104 | [,else (errorf who "invalid Value ~s" else)])) 105 | 106 | (define (Effect effect) 107 | (match effect 108 | [(let ([,uvar* ,[Value -> value*]] ...) ,[e]) 109 | (make-begin `((set! ,uvar* ,value*) ... ,e))] ;; 110 | [(nop) '(nop)] 111 | [(mset! ,[Value -> v1] ,[Value -> v2] ,[Value -> v3]) 112 | `(mset! ,v1 ,v2 ,v3)] 113 | [(if ,[Pred -> test] ,[then] ,[else]) `(if ,test ,then ,else)] 114 | [(begin ,[ef*] ... ,[ef]) 115 | (make-begin `(,ef* ... ,ef))] ;; 116 | [(,[Value -> rator] ,[Value -> rand*] ...) 117 | `(,rator ,rand* ...)] 118 | [,else (errorf who "invalid Effect ~s" else)])) 119 | 120 | (define (Pred pred) 121 | (match pred 122 | [(let ([,uvar* ,[Value -> value*]] ...) ,[p]) 123 | (make-begin `((set! ,uvar* ,value*) ... ,p))] ;; 124 | [(true) '(true)] 125 | [(false) '(false)] 126 | [(if ,[test] ,[then] ,[else]) `(if ,test ,then ,else)] 127 | [(begin ,[Effect -> ef*] ... ,[p]) 128 | (make-begin `(,ef* ... ,p))] ;; 129 | [(,relop ,[Value -> v1] ,[Value -> v2]) (guard (relop? relop)) 130 | `(,relop ,v1 ,v2)] 131 | [,else (errorf who "invalid Pred ~s" else)])) 132 | 133 | (define (Tail tail) 134 | (match tail 135 | [(let ([,uvar* ,[Value -> value*]] ...) ,[t]) 136 | (make-begin `((set! ,uvar* ,value*) ... ,t))] ;; 137 | [(if ,[Pred -> test] ,[then] ,[else]) 138 | `(if ,test ,then ,else)] 139 | [(begin ,[Effect -> ef*] ... ,[t]) 140 | (make-begin `(,ef* ... ,t))] ;; 141 | [(alloc ,[Value -> v]) `(alloc ,v)] 142 | [(,binop ,[Value -> v1] ,[Value -> v2]) (guard (binop? binop)) 143 | `(,binop ,v1 ,v2)] 144 | [(,[Value -> rator] ,[Value -> rand*] ...) 145 | `(,rator ,rand* ...)] 146 | [,t (guard (triv? t)) t] 147 | [,else (errorf who "invalid Tail ~s" else)])) 148 | 149 | (match body 150 | [(locals (,uvar* ...) ,[Tail -> tail]) 151 | `(locals (,uvar* ...) ,tail)] 152 | [,else (errorf who "invalid Body ~s" else)])) 153 | 154 | (lambda (exp) 155 | (match exp 156 | [(letrec ([,label* (lambda (,uvar* ...) ,[Body -> b*])] ...) ,[Body -> b]) 157 | `(letrec ([,label* (lambda (,uvar* ...) ,b*)] ...) ,b)] 158 | [,el (errorf who "invalid Program ~s" el)])))) 159 | 160 | -------------------------------------------------------------------------------- /Compiler/sanitize-binding-forms.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A13 - Apr 17, 2015 4 | 5 | pass: sanitize-binding-forms 6 | 7 | This pass processes the `let` forms such that lambda expressions appear only as the right-hand side of a letrec binding and never as the right-hand side of a let binding 8 | 9 | This transformation would not be sound if 10 | - variables were not uniquely named, because the lifted letrec bindings could improperly capture free references in the letrec and let right-hand sides 11 | - in the presence of call/cc and assignments, which could be used to expose the fact that only one location is created for each generated letrec binding rather than one for each time a continuation of a let right-hand side is invoked. 12 | 13 | 14 | We partition the bindings of each let expression into the set that bind lambda expressions and the set that do not. We lift those that bind lambda expressions out and place them in a letrec expression wrapped around what remains of the let expression. and 15 | - it should avoid producing let and letrec expressions that bind no variables -- just suppress them 16 | - let and letrec expressions in the input of this pass might as well be eliminated if they do not bind any variables 17 | 18 | Input: 19 | Prog ::= Expr 20 | Expr ::= (quote Immediate) 21 | | (let ([UVar LambdaOrExpr] *) Expr) 22 | | (letrec ([UVar Lamb] *) Expr) 23 | | (if Expr Expr Expr) 24 | | (begin Expr * Expr) 25 | | (ValPrim Expr *) 26 | | (EffectPrim Expr *) 27 | | (PredPrim Expr *) 28 | | (Expr Expr *) 29 | | UVar 30 | Lamb ::= (lambda (UVar *) Expr) 31 | LambdaOrExpr ::= Lamb | Expr 32 | Immediate ::= fixnum | () | #t | #f 33 | 34 | Output: 35 | Prog ::= Expr 36 | Expr ::= (quote Immediate) 37 | | (let ([UVar Expr] *) Expr) ;; mod 38 | | (letrec ([UVar (lambda (UVar *) Expr)] *) Expr) ;; mod 39 | | (if Expr Expr Expr) 40 | | (begin Expr * Expr) 41 | | (ValPrim Expr *) 42 | | (EffectPrim Expr *) 43 | | (PredPrim Expr *) 44 | | (Expr Expr *) 45 | | UVar 46 | Immediate ::= fixnum | () | #t | #f 47 | 48 | |# 49 | 50 | (library (Compiler sanitize-binding-forms) 51 | (export sanitize-binding-forms) 52 | (import 53 | (chezscheme) 54 | (Framework match) 55 | (Framework helpers) 56 | (Compiler utils) 57 | (Compiler common)) 58 | 59 | (define-who sanitize-binding-forms 60 | 61 | (define (partition names binds body) 62 | (let loop ([names names] 63 | [binds binds] 64 | [letrec-s (hset-init)] 65 | [let-s (hset-init)]) 66 | (cond 67 | [(null? names) 68 | (let ([new-let (hset->list let-s)] 69 | [new-letrec (hset->list letrec-s)]) 70 | (cond 71 | [(and (null? new-let) (null? new-letrec)) body] ;; no binding 72 | [(null? new-letrec) `(let ,new-let ,body)] ;; let only 73 | [(null? new-let) `(letrec ,new-letrec ,body)] ;; letrec only 74 | [else `(let ,new-let (letrec ,new-letrec ,body))]))] ;; both 75 | [(not (pair? (car binds))) ;; '() or foo: bind through let 76 | (loop (cdr names) (cdr binds) letrec-s (hset-push `[,(car names) ,(car binds)] let-s))] 77 | [(eq? 'lambda (caar binds)) ;; lambda: bind through letrec 78 | (loop (cdr names) (cdr binds) (hset-push `[,(car names) ,(car binds)] letrec-s) let-s)] 79 | [else ;; an exp: bind through let 80 | (loop (cdr names) (cdr binds) letrec-s (hset-push `[,(car names) ,(car binds)] let-s))]))) 81 | 82 | (define (Expr expr) 83 | (match expr 84 | [(quote ,i) (guard (immediate? i)) `(quote ,i)] 85 | [(let () ,[expr]) expr] ;; dummy case 86 | [(letrec () ,[expr]) expr] ;; dummy case 87 | [(lambda (,uvar* ...) ,[expr]) `(lambda (,uvar* ...) ,expr)] ;; cata on the body 88 | [(let ([,uvar* ,[expr*]] ...) ,[expr]) 89 | (partition uvar* expr* expr)] 90 | [(letrec ([,name* (lambda (,uvar* ...) ,[expr*])] ...) ,[expr]) 91 | `(letrec ([,name* (lambda (,uvar* ...) ,expr*)] ...) ,expr)] 92 | [(if ,[test] ,[then] ,[else]) 93 | `(if ,test ,then ,else)] 94 | [(begin ,[expr*] ... ,[expr]) 95 | (make-begin `(,expr* ... ,expr))] ;; for nested stuffs 96 | [(,prim ,[expr*] ...) (guard (prim? prim)) 97 | `(,prim ,expr* ...)] 98 | [(,[rator] ,[rand*] ...) 99 | `(,rator ,rand* ...)] 100 | [,uvar (guard (uvar? uvar)) uvar] 101 | [,el (errorf who "Invalid Expr ~s" el)])) 102 | 103 | (lambda (prog) 104 | (Expr prog))) 105 | ) 106 | 107 | 108 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /Compiler/uncover-assigned.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A14 - Apr 18, 2014 4 | 5 | pass: uncover-assigned 6 | 7 | Since the same variable can be accessed by more than one procedure, we need to place the values of each that is assigned in some location shared by the procedures, so that the effect of an assignment by one procedure can be observed by the others. Identifying the set of assigned variables is the first step in this process and is the job of uncover-assigned. 8 | 9 | This pass locates all assigned variables and records each within the lambda, let, or letrec form that binds it. An assigned variable is one that appears somewhere within its scope on the left-hand side of a set! expression. To record this information, the body of each lambda, let, and letrec expression is wrapped in an assigned form listing the assigned variables bound by the expression. The assigned form is inserted even if the list of assigned variables is empty. 10 | 11 | Input: 12 | Prog ::= Expr 13 | Expr ::= (quote Immediate) 14 | | (let ([UVar Expr] *) Body) 15 | | (letrec ([UVar Expr] *) Body) 16 | | (lambda (UVar *) Body) 17 | | (if Expr Expr Expr) 18 | | (begin Expr * Expr) 19 | | (set! UVar Expr) 20 | | (ValPrim Expr *) 21 | | (EffectPrim Expr *) 22 | | (PredPrim Expr *) 23 | | (Expr Expr *) 24 | | UVar 25 | Body ::= Expr 26 | Datum ::= Immediate | (Datum *) | #(Datum *) 27 | Immediate ::= fixnum | () | #t | #f 28 | 29 | Output: 30 | Prog ::= Expr 31 | Expr ::= (quote Immediate) 32 | | (let ([UVar Expr] *) Body) 33 | | (letrec ([UVar Expr] *) Body) 34 | | (lambda (UVar *) Body) 35 | | (if Expr Expr Expr) 36 | | (begin Expr * Expr) 37 | | (set! UVar Expr) 38 | | (ValPrim Expr *) 39 | | (EffectPrim Expr *) 40 | | (PredPrim Expr *) 41 | | (Expr Expr *) 42 | | UVar 43 | Body ::= (assigned (UVar *) Expr) ;; mod 44 | Datum ::= Immediate | (Datum *) | #(Datum *) 45 | Immediate ::= fixnum | () | #t | #f 46 | 47 | |# 48 | 49 | (library (Compiler uncover-assigned) 50 | (export uncover-assigned) 51 | (import 52 | (chezscheme) 53 | (Framework match) 54 | (Framework helpers) 55 | (Compiler utils) 56 | (Compiler common)) 57 | 58 | (define-who uncover-assigned 59 | (define (Expr expr) 60 | (match expr 61 | [(quote ,d) (guard (immediate-with-d? d)) ;; matchs Immediate + Datum 62 | (values `(quote ,d) '())] ;; nothing 63 | [(let ([,uvar* ,[exp* av*]] ...) ,[exp av]) 64 | (let ([set (hintersection uvar* av)]) ;; (I uvar* av) 65 | (values 66 | `(let ([,uvar* ,exp*] ...) 67 | (assigned ,set ,exp)) 68 | (hunion (apply hunion av*) (hdifference av uvar*))))] ;; (U (U av* ...) (- av uvar*)) 69 | [(letrec ([,uvar* ,[exp* av*]] ...) ,[exp av]) 70 | (let ([set (hintersection uvar* (hunion av (apply hunion av*)))]) 71 | ;; (I uvar* (U av (U av* ...)) 72 | (values 73 | `(letrec ([,uvar* ,exp*] ...) 74 | (assigned ,set ,exp)) 75 | (hdifference (hunion av (apply hunion av*)) uvar*)))] ;; (- (U av (U av* ...)) uvar*) 76 | [(lambda (,uvar* ...) ,[exp av]) 77 | (let ([set (hintersection uvar* av)]) ;; (I uvar* av) 78 | (values 79 | `(lambda (,uvar* ...) 80 | (assigned ,set ,exp)) 81 | av))] ;; av 82 | [(if ,[test av1] ,[then av2] ,[else av3]) 83 | (values 84 | `(if ,test ,then ,else) 85 | (hunion av1 av2 av3))] ;; (U av1 av2 av3) 86 | [(begin ,[exp* av*] ... ,[exp av]) 87 | (values 88 | `(begin ,exp* ... ,exp) 89 | (hunion av (apply hunion av*)))] ;; (U av (U av* ...)) 90 | [(set! ,uvar ,[exp av]) 91 | (values 92 | `(set! ,uvar ,exp) 93 | (hunion `(,uvar) av))] ;; (U (uvar) av) 94 | [(,prim ,[exp* av*] ...) (guard (prim? prim)) 95 | (values 96 | `(,prim ,exp* ...) 97 | (apply hunion av*))] ;; (U av* ...) 98 | [(,[rator av] ,[rand* av*] ...) 99 | (values 100 | `(,rator ,rand* ...) 101 | (hunion av (apply hunion av*)))] ;; (U av (U av* ...)) 102 | [,uvar (guard (uvar? uvar)) (values uvar '())] ;; nothing 103 | [,el (errorf who "Invalid Expr ~s" el)])) 104 | 105 | (lambda (prog) 106 | (let-values ([(exp _) (Expr prog)]) 107 | exp))) 108 | ) 109 | 110 | -------------------------------------------------------------------------------- /Compiler/uncover-free.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A12 - Apr 09, 2015 4 | 5 | pass: uncover-free 6 | 7 | This pass annotates each lambda expression with a list of its free variables. It does so via a new form, free, wrapped around each lambda body. If the formals and free variables of a lambda expression are combined, they account for all of the free variables of the lambda body. The set of free variables and the set of formals are disjoint. 8 | 9 | Input: 10 | Prog ::= Expr 11 | Expr ::= (quote Immediate) 12 | | (let ([UVar Expr]*) Expr) 13 | | (letrec ((UVar (lambda (UVar *) Expr)) *) Expr) 14 | | (if Expr Expr Expr) 15 | | (begin Expr * Expr) 16 | | (ValPrim Expr *) 17 | | (EffectPrim Expr *) 18 | | (PredPrim Expr *) 19 | | (Expr Expr *) 20 | | UVar 21 | Immediate ::= fixnum | () | #t | #f 22 | 23 | Output: 24 | Prog ::= Expr 25 | Expr ::= (quote Immediate) 26 | | (let ([UVar Expr]*) Expr) 27 | | (letrec ((UVar (lambda (UVar *) (free (UVar *) Expr))) *) Expr) 28 | | (if Expr Expr Expr) 29 | | (begin Expr * Expr) 30 | | (ValPrim Expr *) 31 | | (EffectPrim Expr *) 32 | | (PredPrim Expr *) 33 | | (Expr Expr *) 34 | | UVar 35 | Immediate ::= fixnum | () | #t | #f 36 | 37 | |# 38 | 39 | (library (Compiler uncover-free) 40 | (export uncover-free) 41 | (import 42 | (chezscheme) 43 | (Framework match) 44 | (Framework helpers) 45 | (Compiler utils) 46 | (Compiler common)) 47 | 48 | (define-who uncover-free 49 | 50 | (define (immediate? imm) 51 | (or (memq imm '(#t #f ())) 52 | (and (integer? imm) 53 | (exact? imm) 54 | (fixnum-range? imm)))) 55 | 56 | (define (Expr expr) 57 | (match expr 58 | [(quote ,i) (guard (immediate? i)) 59 | (values `(quote ,i) '())] 60 | [(let ([,uvar* ,[Expr -> exp* free*]] ...) ,[Expr -> exp free]) 61 | ;; (+ (+ free*) (- free uvar*)) 62 | (values `(let ([,uvar* ,exp*] ...) ,exp) 63 | (union (apply union free*) 64 | (difference free uvar*)))] 65 | [(letrec ([,uvar* ,[Lambda -> lam* flam*]] ...) ,[Expr -> exp free]) 66 | ;; (- (+ (+ flam*) free) uvar*) 67 | (values `(letrec ([,uvar* ,lam*] ...) ,exp) 68 | (difference (union (apply union flam*) free) uvar*))] 69 | [(if ,[Expr -> test ftest] 70 | ,[Expr -> then fthen] 71 | ,[Expr -> else felse]) 72 | ;; (+ ftest fthen felse) 73 | (values `(if ,test ,then ,else) 74 | (union ftest fthen felse))] 75 | [(begin ,[Expr -> exp* free*] ... ,[Expr -> exp free]) 76 | ;; (+ (+ free*) free) 77 | (values `(begin ,exp* ... ,exp) 78 | (union (apply union free*) free))] 79 | [(,prim ,[Expr -> exp* free*] ...) (guard (prim? prim)) 80 | ;; (+ free*) 81 | (values `(,prim ,exp* ...) 82 | (apply union free*))] 83 | [(,[Expr -> rator frator] ,[Expr -> rand* frand*] ...) 84 | ;; (+ frator frand*) 85 | (values `(,rator ,rand* ...) 86 | (apply union `(,frator ,@frand*)))] 87 | [,uvar (guard (uvar? uvar)) 88 | ;; assume everybody is free: `(,uvar) 89 | (values uvar `(,uvar))] 90 | [,el (errorf who "Invalid Expr ~s" el)])) 91 | 92 | (define (Lambda lam) 93 | (match lam 94 | [(lambda (,uvar* ...) ,[Expr -> exp free]) 95 | ;; (- free uvar*) 96 | (let ([free-ls (difference free uvar*)]) 97 | (values `(lambda (,uvar* ...) (free ,free-ls ,exp)) 98 | free-ls))] 99 | [,el (errorf who "Invalid Lambda ~s" el)])) 100 | 101 | (lambda (prog) 102 | (match prog 103 | [,[Expr -> x free] 104 | ;; free doesn't matter here 105 | x]))) 106 | 107 | ) 108 | -------------------------------------------------------------------------------- /Compiler/uncover-locals.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | A9 - Mar 28, 2015 4 | 5 | pass: uncover-locals 6 | 7 | This pass scans through each lambda or letrec body to find all variables bound by let expressions within the body and records these variables in a locals form wrapped around the body. 8 | 9 | Input: 10 | Prog ::= (letrec ((Label (lambda (UVar *) Tail)) *) Tail) 11 | Tail ::= (let ([UVar Value]*) Tail) 12 | | (if Pred Tail Tail) 13 | | (begin Effect * Tail) 14 | | (alloc Value) 15 | | (mref Value Value) 16 | | (Binop Value Value) 17 | | (Value Value *) 18 | | Triv 19 | Pred ::= (let ([UVar Value]*) Pred) 20 | | (true) 21 | | (false) 22 | | (if Pred Pred Pred) 23 | | (begin Effect * Pred) 24 | | (Relop Value Value) 25 | Effect ::= (let ([UVar Value]*) Effect) 26 | | (nop) 27 | | (mset! Value Value Value) 28 | | (if Pred Effect Effect) 29 | | (begin Effect * Effect) 30 | | (Value Value *) 31 | Value ::= (let ([UVar Value]*) Value) 32 | | (if Pred Value Value) 33 | | (begin Effect * Value) 34 | | (alloc Value) 35 | | (mref Value Value) 36 | | (Binop Value Value) 37 | | (Value Value *) 38 | | Triv 39 | Triv ::= UVar | Integer | Label 40 | 41 | 42 | Output: 43 | Prog ::= (letrec ((Label (lambda (UVar *) Body)) *) Body) ;; mod 44 | Body ::= (locals (UVar *) Tail) ;; mod 45 | Tail ::= (let ([UVar Value] *) Tail) 46 | | (if Pred Tail Tail) 47 | | (begin Effect * Tail) 48 | | (alloc Value) 49 | | (mref Value Value) 50 | | (Binop Value Value) 51 | | (Value Value *) 52 | | Triv 53 | Pred ::= (let ([UVar Value] *) Pred) 54 | | (true) 55 | | (false) 56 | | (if Pred Pred Pred) 57 | | (begin Effect * Pred) 58 | | (Relop Value Value) 59 | Effect ::= (let ([UVar Value]*) Effect) 60 | | (nop) 61 | | (mset! Value Value Value) 62 | | (if Pred Effect Effect) 63 | | (begin Effect * Effect) 64 | | (Value Value *) 65 | Value ::= (let ([UVar Value] *) Value) 66 | | (if Pred Value Value) 67 | | (begin Effect * Value) 68 | | (alloc Value) 69 | | (mref Value Value) 70 | | (Binop Value Value) 71 | | (Value Value *) 72 | | Triv 73 | Triv ::= UVar | Integer | Label 74 | 75 | |# 76 | 77 | (library (Compiler uncover-locals) 78 | (export uncover-locals) 79 | (import 80 | (chezscheme) 81 | (Framework match) 82 | (Framework helpers) 83 | (Compiler utils) 84 | (Compiler common)) 85 | 86 | (define-who uncover-locals 87 | 88 | (define (Body body) 89 | 90 | (define (Value value) 91 | (match value 92 | [(let ([,uvar* ,[Value -> value*]] ...) ,[v]) 93 | (apply hset-union (list->hset uvar*) v value*)] 94 | [(if ,[Pred -> test] ,[then] ,[else]) (hset-union test then else)] 95 | [(begin ,[Effect -> ef*] ... ,[v]) (apply hset-union v ef*)] 96 | [(alloc ,[v]) v] 97 | [(,binop ,[v1] ,[v2]) (guard (binop? binop)) 98 | (hset-union v1 v2)] 99 | [(,[rator] ,[rand*] ...) 100 | (apply hset-union rator rand*)] 101 | [,t (guard (triv? t)) (hset-init)] 102 | [,else (errorf who "invalid Value ~s" else)])) 103 | 104 | (define (Effect effect) 105 | (match effect 106 | [(let ([,uvar* ,[Value -> value*]] ...) ,[e]) 107 | (apply hset-union (list->hset uvar*) e value*)] 108 | [(nop) (hset-init)] 109 | [(mset! ,[Value -> v1] ,[Value -> v2] ,[Value -> v3]) 110 | (hset-union v1 v2 v3)] 111 | [(if ,[Pred -> test] ,[then] ,[else]) (hset-union test then else)] 112 | [(begin ,[ef*] ... ,[ef]) (apply hset-union ef ef*)] 113 | [(,[Value -> rator] ,[Value -> rand*] ...) 114 | (apply hset-union rator rand*)] 115 | [,else (errorf who "invalid Effect ~s" else)])) 116 | 117 | (define (Pred pred) 118 | (match pred 119 | [(let ([,uvar* ,[Value -> value*]] ...) ,[p]) 120 | (apply hset-union (list->hset uvar*) p value*)] 121 | [(true) (hset-init)] 122 | [(false) (hset-init)] 123 | [(if ,[test] ,[then] ,[else]) (hset-union test then else)] 124 | [(begin ,[Effect -> ef*] ... ,[p]) (apply hset-union p ef*)] 125 | [(,relop ,[Value -> v1] ,[Value -> v2]) (guard (relop? relop)) 126 | (hset-union v1 v2)] 127 | [,else (errorf who "invalid Pred ~s" else)])) 128 | 129 | (define (Tail tail) 130 | (match tail 131 | [(let ([,uvar* ,[Value -> value*]] ...) ,[t]) 132 | (apply hset-union (list->hset uvar*) t value*)] 133 | [(if ,[Pred -> test] ,[then] ,[else]) (hset-union test then else)] 134 | [(begin ,[Effect -> ef*] ... ,[t]) (apply hset-union t ef*)] 135 | [(alloc ,[Value -> v]) v] 136 | [(,binop ,[Value -> v1] ,[Value -> v2]) (guard (binop? binop)) 137 | (hset-union v1 v2)] 138 | [(,[Value -> rator] ,[Value -> rand*] ...) 139 | (apply hset-union rator rand*)] 140 | [,t (guard (triv? t)) (hset-init)] 141 | [,else (errorf who "invalid Tail ~s" else)])) 142 | 143 | `(locals ,(hset->list (Tail body)) ,body)) 144 | 145 | (lambda (exp) 146 | (match exp 147 | [(letrec ([,label* (lambda (,uvar* ...) ,[Body -> tail*])] ...) ,[Body -> tail]) 148 | `(letrec ([,label* (lambda (,uvar* ...) ,tail*)] ...) ,tail)] 149 | [,el (errorf who "invalid Program ~s" el)]))) 150 | 151 | ) 152 | -------------------------------------------------------------------------------- /CompilerHs/VerifyScheme.hs: -------------------------------------------------------------------------------- 1 | module CompilerHs.VerifyScheme (verifyScheme) where 2 | 3 | import FrameworkHs.GenGrammars.L01VerifyScheme 4 | 5 | import Control.Arrow (first, second) 6 | import Control.Monad.Reader 7 | import Control.Monad.Writer 8 | 9 | import FrameworkHs.Prims 10 | import FrameworkHs.Helpers 11 | 12 | type Env = [UVar] 13 | 14 | -- | Verify that the program is valid. We try to catch as many errors 15 | -- as possible in this pass, so that we do not encounter errors from 16 | -- the middle of the compiler. 17 | verifyScheme :: P423Config -> Prog -> Prog 18 | verifyScheme c p@(Expr e) = runPassM c $ do 19 | (((), uvs), labels) <- runWriterT $ runWriterT $ flip runReaderT ([], []) $ vExpr e 20 | 21 | allDistinct "uvar" uvs 22 | allDistinct "label" labels 23 | 24 | return p 25 | 26 | -------------------------------------------------------------------------------- 27 | -- Helpers: 28 | 29 | type VerifyM = ReaderT ([UVar], [Label]) 30 | (WriterT [UVar] 31 | (WriterT [Label] PassM)) 32 | 33 | 34 | failure = passFailureM "verifyScheme" 35 | 36 | verifyFailure = lift . lift . lift . failure 37 | 38 | vExpr :: Expr -> VerifyM () 39 | vExpr e = case e of 40 | Quote imm -> case imm of 41 | Fixnum i -> flip assert (show i ++ " is out of range.") $ isFixnum $ fromIntegral i 42 | _ -> return () 43 | Let binds e -> vLetBinds binds $ vExpr e 44 | Letrec binds e -> vLetrecBinds binds $ vExpr e 45 | If p c a -> vExpr p >> vExpr c >> vExpr a 46 | Begin effs e -> mapM vExpr effs >> vExpr e 47 | App1 vprim args -> let argsl = length args 48 | arity = valPrimArity vprim 49 | in flip assert ("Wrong number of args to primitive " ++ 50 | show vprim ++ ". Expects " ++ show arity ++ 51 | ", given " ++ show argsl ++ ".") 52 | $ argsl == arity 53 | 54 | App2 eprim args -> let argsl = length args 55 | arity = effectPrimArity eprim 56 | in flip assert ("Wrong number of args to primitive " ++ 57 | show eprim ++ ". Expects " ++ show arity ++ 58 | ", given " ++ show argsl ++ ".") 59 | $ argsl == arity 60 | App3 pprim args -> let argsl = length args 61 | arity = predPrimArity pprim 62 | in flip assert ("Wrong number of args to primitive " ++ 63 | show pprim ++ ". Expects " ++ show arity ++ 64 | ", given " ++ show argsl ++ ".") 65 | $ argsl == arity 66 | App4 fun args -> vExpr fun >> mapM_ vExpr args 67 | UVar uv -> asks (elem uv . fst) >>= flip assert ("Not in scope: " ++ show uv) 68 | Label label -> asks (elem label . snd) >>= flip assert ("Not in scope: " ++ show label) 69 | 70 | -- A uvar is visible only in the bindings which follow it, and the tail of the 71 | -- let 72 | vLetBinds :: [(UVar, Expr)] -> VerifyM a -> VerifyM a 73 | vLetBinds [] m = m 74 | vLetBinds ((uv, expr):rest) m = do 75 | lift $ tell [uv] 76 | vExpr expr 77 | local (first (uv :)) $ do 78 | vLetBinds rest m 79 | 80 | -- A label is visible through the whole letrec 81 | vLetrecBinds :: [(Label, [UVar], Expr)] -> VerifyM a -> VerifyM a 82 | vLetrecBinds binds m = do 83 | let (labels, formals, exprs) = unzip3 binds 84 | lambdas = zip formals exprs 85 | lift $ lift $ tell labels 86 | local (second (labels ++)) $ do 87 | mapM_ vLambda lambdas 88 | m 89 | 90 | vLambda :: ([UVar], Expr) -> VerifyM () 91 | vLambda (formals, e) = do 92 | tell formals 93 | local (first $ const formals) $ vExpr e 94 | 95 | assert :: Bool -> String -> VerifyM () 96 | assert False msg = verifyFailure msg 97 | assert True _ = return () 98 | 99 | allDistinct :: (LooseEq a, Eq a, Show a) => String -> [a] -> PassM () 100 | allDistinct name xs = case xs of 101 | [] -> return () 102 | [x] -> return () 103 | (x:xs') -> 104 | if x `looseElem` xs' 105 | then failure ("duplicate " ++ name ++ ": " ++ show x) 106 | else allDistinct name xs' 107 | 108 | looseElem :: (LooseEq a) => a -> [a] -> Bool 109 | looseElem e [] = False 110 | looseElem e (x:xs) | e .= x = True 111 | looseElem e (x:xs) = looseElem e xs 112 | 113 | 114 | -------------------------------------------------------------------------------- /Framework/fmts.pretty: -------------------------------------------------------------------------------- 1 | (pretty-format 'define-who '(_ x #f ...)) 2 | (pretty-format 'trace-define-who '(_ x #f ...)) 3 | (pretty-format 'match '(_ x #f [bracket e 0 ...] ...)) 4 | (pretty-format 'code '(_ #f e ...)) 5 | (pretty-format 'locals '(_ (var ...) #f e)) 6 | (pretty-format 'ulocals '(_ (var ...) #f e)) 7 | (pretty-format 'spills '(_ (var ...) #f e)) 8 | (pretty-format 'locate '(_ ([bracket var loc] 0 ...) #f e)) 9 | (pretty-format 'register-conflict '(_ ([bracket fill 0 x ...] 0 ...) #f e)) 10 | (pretty-format 'frame-conflict '(_ ([bracket fill 0 x ...] 0 ...) #f e)) 11 | (pretty-format 'new-frames '(_ ((var ...) 0 ...) #f e)) 12 | (pretty-format 'return-point '(_ rplab #f e)) 13 | (pretty-format 'call-live '(_ (var ...) #f e)) 14 | (pretty-format 'free '(_ x #f e)) 15 | (pretty-format 'closures '(_ ([bracket x ...] 0 ...) #f e ...)) 16 | (pretty-format 'bind-free '(_ x #f e)) 17 | (pretty-format 'well-known '(_ x #f e)) 18 | (pretty-format 'assigned '(_ x #f e)) 19 | -------------------------------------------------------------------------------- /Framework/nanopass.chezscheme.sls: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2000-2013 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell 2 | ;;; See the accompanying file Copyright for detatils 3 | 4 | (library-group 5 | (include "nanopass/implementation-helpers.chezscheme.sls") 6 | (include "nanopass/helpers.ss") 7 | (include "nanopass/nano-syntax-dispatch.ss") 8 | (include "nanopass/syntaxconvert.ss") 9 | (include "nanopass/records.ss") 10 | (include "nanopass/unparser.ss") 11 | (include "nanopass/meta-syntax-dispatch.ss") 12 | (include "nanopass/meta-parser.ss") 13 | (include "nanopass/parser.ss") 14 | (include "nanopass/language-helpers.ss") 15 | (include "nanopass/language.ss") 16 | (include "nanopass/pass.ss") 17 | (include "nanopass/language-node-counter.ss") 18 | (include "nanopass.ss")) 19 | -------------------------------------------------------------------------------- /Framework/nanopass.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2000-2013 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell 2 | ;;; See the accompanying file Copyright for detatils 3 | 4 | (library (Framework nanopass) 5 | (export define-language define-parser trace-define-parser trace-define-pass 6 | echo-define-pass define-pass with-output-language nanopass-case 7 | language->s-expression extends entry terminals nongenerative-id 8 | #;define-nanopass-record-types diff-languages define-language-node-counter 9 | prune-language define-pruned-language) 10 | (import 11 | (Framework nanopass language) 12 | (Framework nanopass parser) 13 | (Framework nanopass language-node-counter) 14 | (Framework nanopass pass) 15 | (Framework nanopass helpers) 16 | (Framework nanopass records))) 17 | -------------------------------------------------------------------------------- /Framework/nanopass/implementation-helpers.vicare.sls: -------------------------------------------------------------------------------- 1 | (library (nanopass implementation-helpers) 2 | (export 3 | ;; formatting 4 | format printf pretty-print 5 | 6 | ;; listy stuff 7 | iota make-list list-head 8 | 9 | ;; gensym stuff (related to nongenerative languages) 10 | gensym regensym 11 | 12 | ;; source-information stuff 13 | syntax->source-information 14 | source-information-source-file 15 | source-information-byte-offset-start 16 | source-information-char-offset-start 17 | source-information-byte-offset-end 18 | source-information-char-offset-end 19 | source-information-position-line 20 | source-information-position-column 21 | source-information-type 22 | provide-full-source-information 23 | 24 | ;; library export stuff (needed for when used inside module to 25 | ;; auto-indirect export things) 26 | indirect-export 27 | 28 | ;; compile-time environment helpers 29 | #;define-property make-compile-time-value 30 | 31 | ;; code organization helpers 32 | module 33 | 34 | ;; useful for warning and error items 35 | warningf errorf 36 | 37 | ;; used to get the best performance from hashtables 38 | eq-hashtable-set! eq-hashtable-ref 39 | 40 | ;; debugging support 41 | trace-lambda trace-define-syntax trace-let trace-define 42 | 43 | ;; needed to know what code to generate 44 | optimize-level 45 | 46 | ;; the base record, so that we can use gensym syntax 47 | define-nanopass-record 48 | 49 | ;; failure token so that we can know when parsing fails with a gensym 50 | np-parse-fail-token 51 | 52 | ;; handy syntactic stuff 53 | with-implicit 54 | 55 | ;; apparently not neeaded (or no longer needed) 56 | ; scheme-version= scheme-version< scheme-version> scheme-version>= 57 | ; scheme-version<= with-scheme-version gensym? errorf with-output-to-string 58 | ; with-input-from-string 59 | ) 60 | (import 61 | (vicare) 62 | (rename 63 | (only (vicare system $compiler) $optimize-level) 64 | ($optimize-level optimize-level))) 65 | 66 | (define-syntax with-implicit 67 | (syntax-rules () 68 | [(_ (id name ...) body bodies ...) 69 | (with-syntax ([name (datum->syntax #'id 'name)] ...) body bodies ...)])) 70 | 71 | ; the base language 72 | (define-syntax define-nanopass-record 73 | (lambda (x) 74 | (syntax-case x () 75 | [(k) (with-implicit (k nanopass-record nanopass-record? nanopass-record-tag) 76 | #'(define-record-type (nanopass-record make-nanopass-record nanopass-record?) 77 | (nongenerative #{nanopass-record d47f8omgluol6otrw1yvu5-0}) 78 | (fields (immutable tag nanopass-record-tag))))]))) 79 | 80 | ;; another gensym listed into this library 81 | (define np-parse-fail-token '#{np-parse-fail-token dlkcd4b37swscag1dvmuiz-13}) 82 | 83 | (define-syntax eq-hashtable-set! (identifier-syntax hashtable-set!)) 84 | (define-syntax eq-hashtable-ref (identifier-syntax hashtable-ref)) 85 | 86 | (define list-head 87 | (lambda (orig-ls orig-n) 88 | (let f ([ls orig-ls] [n orig-n]) 89 | (cond 90 | [(fxzero? n) '()] 91 | [(null? ls) (error 'list-head "index out of range" orig-ls orig-n)] 92 | [else (cons (car ls) (f (cdr ls) (fx- n 1)))])))) 93 | 94 | (define iota 95 | (lambda (n) 96 | (let loop ([n n] [ls '()]) 97 | (if (fxzero? n) 98 | ls 99 | (let ([n (- n 1)]) 100 | (loop n (cons n ls))))))) 101 | 102 | (define regensym 103 | (case-lambda 104 | [(gs extra) 105 | (unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs)) 106 | (unless (string? extra) (errorf 'regensym "~s is not a string" extra)) 107 | (let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))] 108 | [unique-name (gensym->unique-string gs)]) 109 | (with-input-from-string (format "#{~a ~a~a}" pretty-name unique-name extra) read))] 110 | [(gs extra0 extra1) 111 | (unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs)) 112 | (unless (string? extra0) (errorf 'regensym "~s is not a string" extra0)) 113 | (unless (string? extra1) (errorf 'regensym "~s is not a string" extra1)) 114 | (with-output-to-string (lambda () (format "~s" gs))) 115 | (let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))] 116 | [unique-name (gensym->unique-string gs)]) 117 | (with-input-from-string (format "#{~a~a ~a~a}" pretty-name extra0 unique-name extra1) read))])) 118 | 119 | (define provide-full-source-information 120 | (make-parameter #f (lambda (x) (and x #t)))) 121 | 122 | (define-record-type source-information 123 | (nongenerative) 124 | (sealed #t) 125 | (fields source-file byte-offset-start char-offset-start byte-offset-end 126 | char-offset-end position-line position-column type) 127 | (protocol 128 | (lambda (new) 129 | (lambda (a type) 130 | (let ([sp (annotation-textual-position a)]) 131 | (new 132 | (source-position-port-id sp) (source-position-byte sp) 133 | (source-position-character sp) #f #f (source-position-line sp) 134 | (source-position-column sp) type)))))) 135 | 136 | (define syntax->source-information 137 | (lambda (stx) 138 | (let loop ([stx stx] [type 'at]) 139 | (cond 140 | [(syntax-object? stx) 141 | (let ([e (syntax-object-expression stx)]) 142 | (and (annotation? e) (make-source-information e type)))] 143 | [(pair? stx) (or (loop (car stx) 'near) (loop (cdr stx) 'near))] 144 | [else #f])))) 145 | 146 | (define-syntax warningf 147 | (syntax-rules () 148 | [(_ who fmt args ...) (warning who (format fmt args ...))])) 149 | 150 | (define-syntax errorf 151 | (syntax-rules () 152 | [(_ who fmt args ...) (error who (format fmt args ...))])) 153 | 154 | (define-syntax indirect-export 155 | (syntax-rules () 156 | [(_ id indirect-id ...) (define t (if #f #f))]))) 157 | -------------------------------------------------------------------------------- /Framework/nanopass/language-helpers.ss: -------------------------------------------------------------------------------- 1 | (library (Framework nanopass language-helpers) 2 | (export prune-language-helper) 3 | (import (rnrs) (Framework nanopass records)) 4 | 5 | (define tspec->ts-syntax 6 | (lambda (tspec) 7 | (with-syntax ([(meta-vars ...) (tspec-meta-vars tspec)] 8 | [type (tspec-type tspec)]) 9 | #'(type (meta-vars ...))))) 10 | 11 | (define ntspec->nts-syntax 12 | (lambda (ntspec) 13 | (with-syntax ([(meta-vars ...) (ntspec-meta-vars ntspec)] 14 | [name (ntspec-name ntspec)] 15 | [(prods ...) (map alt-syn (ntspec-alts ntspec))]) 16 | #'(name (meta-vars ...) prods ...)))) 17 | 18 | (define prune-language-helper 19 | (lambda (l) 20 | (let ([entry (language-entry-ntspec l)]) 21 | (let ([nt* (list (nonterm-id->ntspec 'prune-language entry (language-ntspecs l)))]) 22 | (let loop ([nt* nt*] [ts '()] [nts '()]) 23 | (if (null? nt*) 24 | (with-syntax ([(ts ...) (map tspec->ts-syntax ts)] 25 | [(nts ...) (map ntspec->nts-syntax nts)]) 26 | #'((ts ...) (nts ...))) 27 | (let ([nt (car nt*)] [nt* (cdr nt*)]) 28 | (let ([nts (cons nt nts)]) 29 | (let inner-loop ([prod* (ntspec-alts nt)] [nt* nt*] [ts ts]) 30 | (if (null? prod*) 31 | (loop nt* ts nts) 32 | (let ([prod (car prod*)]) 33 | (cond 34 | [(terminal-alt? prod) 35 | (inner-loop (cdr prod*) nt* 36 | (let ([tspec (terminal-alt-tspec prod)]) 37 | (if (memq tspec ts) ts (cons tspec ts))))] 38 | [(nonterminal-alt? prod) 39 | (inner-loop (cdr prod*) 40 | (let ([ntspec (nonterminal-alt-ntspec prod)]) 41 | (if (or (memq ntspec nt*) (memq ntspec nts)) nt* (cons ntspec nt*))) 42 | ts)] 43 | [(pair-alt? prod) 44 | (let inner-inner-loop ([flds (pair-alt-field-names prod)] [nt* nt*] [ts ts]) 45 | (if (null? flds) 46 | (inner-loop (cdr prod*) nt* ts) 47 | (let ([fld (car flds)]) 48 | (cond 49 | [(meta-name->tspec fld (language-tspecs l)) => 50 | (lambda (tspec) 51 | (inner-inner-loop (cdr flds) nt* 52 | (if (memq tspec ts) ts (cons tspec ts))))] 53 | [(meta-name->ntspec fld (language-ntspecs l)) => 54 | (lambda (ntspec) 55 | (inner-inner-loop (cdr flds) 56 | (if (or (memq ntspec nt*) (memq ntspec nts)) nt* (cons ntspec nt*)) 57 | ts))]))))]))))))))))))) 58 | 59 | 60 | -------------------------------------------------------------------------------- /Framework/nanopass/language-node-counter.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2000-2013 Andrew W. Keep 2 | ;;; See the accompanying file Copyright for detatils 3 | 4 | (library (Framework nanopass language-node-counter) 5 | (export define-language-node-counter) 6 | (import (rnrs) (Framework nanopass records)) 7 | 8 | (define-syntax define-language-node-counter 9 | (lambda (x) 10 | (define build-counter-proc 11 | (lambda (proc-name l) 12 | (lambda (ntspec) 13 | (let loop ([alt* (ntspec-alts ntspec)] [term* '()] [nonterm* '()] [pair* '()]) 14 | (if (null? alt*) 15 | #`(lambda (x) 16 | (cond 17 | #,@term* 18 | #,@pair* 19 | #,@nonterm* 20 | [else (error '#,proc-name "unrecognized term" x)])) 21 | (let ([alt (car alt*)] [alt* (cdr alt*)]) 22 | (cond 23 | [(terminal-alt? alt) 24 | (loop alt* 25 | (cons #`[(#,(tspec-pred (terminal-alt-tspec alt)) x) 1] term*) 26 | nonterm* pair*)] 27 | [(nonterminal-alt? alt) 28 | (let ([ntspec (nonterminal-alt-ntspec alt)]) 29 | (loop alt* term* 30 | (cons #`[(#,(ntspec-all-pred ntspec) x) 31 | (#,(ntspec-unparse-name ntspec) x)] 32 | nonterm*) 33 | pair*))] 34 | [(pair-alt? alt) 35 | (let inner-loop ([fld* (pair-alt-field-names alt)] 36 | [lvl* (pair-alt-field-levels alt)] 37 | [maybe?* (pair-alt-field-maybes alt)] 38 | [acc* (pair-alt-accessors alt)] 39 | [rec* '()]) 40 | (if (null? fld*) 41 | (loop alt* term* nonterm* 42 | (cons #`[(#,(pair-alt-pred alt) x) (+ 1 #,@rec*)] pair*)) 43 | (inner-loop (cdr fld*) (cdr lvl*) (cdr maybe?*) (cdr acc*) 44 | (cons 45 | (let ([fld (car fld*)] [maybe? (car maybe?*)] [acc (car acc*)]) 46 | (let ([spec (find-spec fld l)]) 47 | (if (ntspec? spec) 48 | #`(let ([x (#,acc x)]) 49 | #,(let loop ([lvl (car lvl*)] [outer-most? #t]) 50 | (if (fx=? lvl 0) 51 | (if maybe? 52 | (if outer-most? 53 | #`(if x (#,(ntspec-unparse-name spec) x) 0) 54 | #`(+ a (if x (#,(ntspec-unparse-name spec) x) 0))) 55 | (if outer-most? 56 | #`(#,(ntspec-unparse-name spec) x) 57 | #`(+ a (#,(ntspec-unparse-name spec) x)))) 58 | (if outer-most? 59 | #`(fold-left 60 | (lambda (a x) #,(loop (- lvl 1) #f)) 61 | 0 x) 62 | #`(fold-left 63 | (lambda (a x) #,(loop (- lvl 1) #f)) 64 | a x))))) 65 | 0))) 66 | rec*))))] 67 | [else (syntax-violation 'define-language-node-counter 68 | "unrecognized alt ~s" alt)]))))))) 69 | (syntax-case x () 70 | [(_ name lang) 71 | (and (identifier? #'name) (identifier? #'lang)) 72 | (lambda (r) 73 | (let ([l-pair (r #'lang)]) 74 | (unless l-pair (syntax-violation 'define-language-node-counter "Unknown language" x #'lang)) 75 | (let ([l (car l-pair)]) 76 | (let ([ntspecs (language-ntspecs l)] [tspecs (language-tspecs l)]) 77 | (with-syntax ([(ntspec? ...) (map ntspec-pred ntspecs)] 78 | [(proc-name ...) (map ntspec-unparse-name ntspecs)] ; reuse these names internally 79 | [(tspec? ...) (map tspec-pred tspecs)] 80 | [(proc ...) (map (build-counter-proc #'name l) ntspecs)]) 81 | #'(define name 82 | (lambda (x) 83 | (define proc-name proc) ... 84 | (cond 85 | [(ntspec? x) (proc-name x)] ... 86 | [(tspec? x) 1] ... 87 | [else (error 'name "unrecognized language record" x)]))))))))])))) 88 | -------------------------------------------------------------------------------- /Framework/nanopass/meta-syntax-dispatch.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2000-2013 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell 2 | ;;; See the accompanying file Copyright for detatils 3 | 4 | (library (Framework nanopass meta-syntax-dispatch) 5 | (export meta-syntax-dispatch) 6 | (import (rnrs) 7 | (Framework nanopass helpers) 8 | (Framework nanopass records)) 9 | 10 | ;; (fields->patterns '(e0 e1 e2)) => (any any any) 11 | ;; (fields->patterns '(e0 ...)) => ((each+ any () ())) 12 | ;; (fields->patterns '(e0 ... e1)) => ((each+ any (any) ())) 13 | ;; (fields->patterns '(e0 ... e1 e2)) => ((each+ any (any any) ())) 14 | ;; (fields->patterns '(([x e0] ...) e1 e2 ...)) => 15 | ;; ((each+ (any any) () ())) any (each+ (any) () ())) 16 | 17 | ;;; syntax-dispatch expects an expression and a pattern. If the expression 18 | ;;; matches the pattern a list of the matching expressions for each 19 | ;;; "any" is returned. Otherwise, #f is returned. 20 | 21 | ;;; The expression is matched with the pattern as follows: 22 | 23 | ;;; p in pattern: matches: 24 | ;;; () empty list 25 | ;;; any anything 26 | ;;; (p1 . p2) pair (list) 27 | ;;; each-any any proper list 28 | ;;; #(each p) (p*) 29 | ;;; #(each+ p1 (p2_1 ...p2_n) p3) (p1* (p2_n ... p2_1) . p3) 30 | 31 | (define match-each 32 | (lambda (e p) 33 | (syntax-case e () 34 | [(a dots . d) 35 | (and (not (ellipsis? #'a)) (not (unquote? #'a)) (ellipsis? #'dots)) 36 | (let ([first (match #'a p '())]) 37 | (and first 38 | (let ([rest (match-each #'d p)]) 39 | (and rest (cons (map make-nano-dots first) rest)))))] 40 | [(a . d) 41 | (and (not (ellipsis? #'a)) (not (unquote? #'a))) 42 | (let ([first (match #'a p '())]) 43 | (and first 44 | (let ([rest (match-each #'d p)]) 45 | (and rest (cons first rest)))))] 46 | [() '()] 47 | [else #f]))) 48 | 49 | (define match-each+ 50 | (lambda (e x-pat y-pat z-pat r) 51 | (let f ([e e]) 52 | (syntax-case e () 53 | [(a dots . d) 54 | (and (not (ellipsis? #'a)) (not (unquote? #'a)) (ellipsis? #'dots)) 55 | (let-values ([(xr* y-pat r) (f #'d)]) 56 | (if r 57 | (if (null? y-pat) 58 | (let ([xr (match #'a x-pat '())]) 59 | (if xr 60 | (values (cons (map make-nano-dots xr) xr*) y-pat r) 61 | (values #f #f #f))) 62 | (values '() (cdr y-pat) (match #'a (car y-pat) r))) 63 | (values #f #f #f)))] 64 | [(a . d) 65 | (and (not (ellipsis? #'a)) (not (unquote? #'a))) 66 | (let-values ([(xr* y-pat r) (f #'d)]) 67 | (if r 68 | (if (null? y-pat) 69 | (let ([xr (match #'a x-pat '())]) 70 | (if xr 71 | (values (cons xr xr*) y-pat r) 72 | (values #f #f #f))) 73 | (values '() (cdr y-pat) (match #'a (car y-pat) r))) 74 | (values #f #f #f)))] 75 | [_ (values '() y-pat (match e z-pat r))])))) 76 | 77 | (define match-each-any 78 | (lambda (e) 79 | (syntax-case e () 80 | [(a dots . d) 81 | (and (not (ellipsis? #'a)) (not (unquote? #'a)) (ellipsis? #'dots)) 82 | (let ([l (match-each-any #'d)]) 83 | (and l (cons (make-nano-dots #'a) l)))] 84 | [(a . d) 85 | (and (not (ellipsis? #'a)) (not (unquote? #'a))) 86 | (let ([l (match-each-any #'d)]) 87 | (and l (cons #'a l)))] 88 | [() '()] 89 | [_ #f]))) 90 | 91 | (define match-empty 92 | (lambda (p r) 93 | (cond 94 | [(null? p) r] 95 | [(eq? p 'any) (cons '() r)] 96 | [(pair? p) (match-empty (car p) (match-empty (cdr p) r))] 97 | [(eq? p 'each-any) (cons '() r)] 98 | [else 99 | (case (vector-ref p 0) 100 | [(each) (match-empty (vector-ref p 1) r)] 101 | [(each+) (match-empty 102 | (vector-ref p 1) 103 | (match-empty 104 | (reverse (vector-ref p 2)) 105 | (match-empty (vector-ref p 3) r)))])]))) 106 | 107 | (define match* 108 | (lambda (e p r) 109 | (cond 110 | [(null? p) (syntax-case e () [() r] [_ #f])] 111 | [(pair? p) 112 | (syntax-case e () 113 | [(a . d) (match #'a (car p) (match #'d (cdr p) r))] 114 | [_ #f])] 115 | [(eq? p 'each-any) 116 | (let ([l (match-each-any e)]) (and l (cons l r)))] 117 | [else 118 | (case (vector-ref p 0) 119 | [(each) 120 | (syntax-case e () 121 | [() (match-empty (vector-ref p 1) r)] 122 | [_ (let ([r* (match-each e (vector-ref p 1))]) 123 | (and r* (combine r* r)))])] 124 | [(each+) 125 | (let-values ([(xr* y-pat r) 126 | (match-each+ e (vector-ref p 1) (vector-ref p 2) 127 | (vector-ref p 3) r)]) 128 | (and r (null? y-pat) 129 | (if (null? xr*) 130 | (match-empty (vector-ref p 1) r) 131 | (combine xr* r))))])]))) 132 | 133 | (define match 134 | (lambda (e p r) 135 | (cond 136 | [(not r) #f] 137 | [(eq? p 'any) 138 | (and (not (ellipsis? e)) 139 | (not (unquote? e)) ; avoid matching unquote 140 | (cons e r))] 141 | [else (match* e p r)]))) 142 | 143 | (define meta-syntax-dispatch 144 | (lambda (e p) 145 | (match e p '())))) 146 | -------------------------------------------------------------------------------- /Framework/nanopass/nano-syntax-dispatch.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2000-2013 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell 2 | ;;; See the accompanying file Copyright for detatils 3 | 4 | (library (Framework nanopass nano-syntax-dispatch) 5 | (export nano-syntax-dispatch) 6 | (import (rnrs) (Framework nanopass helpers)) 7 | (define match-each 8 | (lambda (e p) 9 | (cond 10 | [(pair? e) 11 | (let ((first (match (car e) p '()))) 12 | (and first 13 | (let ((rest (match-each (cdr e) p))) 14 | (and rest (cons first rest)))))] 15 | [(null? e) '()] 16 | [else #f]))) 17 | 18 | (define match-each+ 19 | (lambda (e x-pat y-pat z-pat r) 20 | (let f ([e e]) 21 | (cond 22 | [(pair? e) 23 | (let-values ([(xr* y-pat r) (f (cdr e))]) 24 | (if r 25 | (if (null? y-pat) 26 | (let ([xr (match (car e) x-pat '())]) 27 | (if xr 28 | (values (cons xr xr*) y-pat r) 29 | (values #f #f #f))) 30 | (values '() (cdr y-pat) (match (car e) (car y-pat) r))) 31 | (values #f #f #f)))] 32 | [else (values '() y-pat (match e z-pat r))])))) 33 | 34 | (define match-each-any 35 | (lambda (e) 36 | (cond 37 | [(pair? e) 38 | (let ([l (match-each-any (cdr e))]) 39 | (and l (cons (car e) l)))] 40 | [(null? e) '()] 41 | [else #f]))) 42 | 43 | (define match-empty 44 | (lambda (p r) 45 | (cond 46 | [(null? p) r] 47 | [(eq? p 'any) (cons '() r)] 48 | [(pair? p) (match-empty (car p) (match-empty (cdr p) r))] 49 | [(eq? p 'each-any) (cons '() r)] 50 | [else 51 | (case (vector-ref p 0) 52 | [(each) (match-empty (vector-ref p 1) r)] 53 | [(each+) (match-empty 54 | (vector-ref p 1) 55 | (match-empty 56 | (reverse (vector-ref p 2)) 57 | (match-empty (vector-ref p 3) r)))])]))) 58 | 59 | (define match* 60 | (lambda (e p r) 61 | (cond 62 | [(null? p) (and (null? e) r)] 63 | [(pair? p) 64 | (and (pair? e) (match (car e) (car p) (match (cdr e) (cdr p) r)))] 65 | [(eq? p 'each-any) (let ([l (match-each-any e)]) (and l (cons l r)))] 66 | [else 67 | (case (vector-ref p 0) 68 | [(each) 69 | (if (null? e) 70 | (match-empty (vector-ref p 1) r) 71 | (let ((r* (match-each e (vector-ref p 1)))) 72 | (and r* (combine r* r))))] 73 | [(each+) 74 | (let-values ([(xr* y-pat r) 75 | (match-each+ e (vector-ref p 1) (vector-ref p 2) 76 | (vector-ref p 3) r)]) 77 | (and r (null? y-pat) 78 | (if (null? xr*) 79 | (match-empty (vector-ref p 1) r) 80 | (combine xr* r))))])]))) 81 | 82 | (define match 83 | (lambda (e p r) 84 | (cond 85 | [(not r) #f] 86 | [(eq? p 'any) (cons e r)] 87 | [else (match* e p r)]))) 88 | 89 | (define nano-syntax-dispatch 90 | (lambda (e p) 91 | (cond 92 | [(eq? p 'any) (list e)] 93 | [else (match* e p '())])))) 94 | -------------------------------------------------------------------------------- /Framework/nanopass/syntaxconvert.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2000-2013 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell 2 | ;;; See the accompanying file Copyright for detatils 3 | 4 | (library (Framework nanopass syntaxconvert) 5 | (export convert-pattern) 6 | (import (rnrs) (Framework nanopass helpers)) 7 | 8 | (define convert-pattern 9 | ; accepts pattern & keys 10 | ; returns syntax-dispatch pattern & ids 11 | (lambda (pattern) 12 | (define cvt* 13 | (lambda (p* n flds lvls maybes) 14 | (if (null? p*) 15 | (values '() flds lvls maybes) 16 | (let-values ([(y flds lvls maybes) (cvt* (cdr p*) n flds lvls maybes)]) 17 | (let-values ([(x flds lvls maybes) (cvt (car p*) n flds lvls maybes)]) 18 | (values (cons x y) flds lvls maybes)))))) 19 | (define cvt 20 | (lambda (p n flds lvls maybes) 21 | (if (identifier? p) 22 | (values 'any (cons p flds) (cons n lvls) (cons #f maybes)) 23 | (syntax-case p () 24 | [(x dots) 25 | (ellipsis? (syntax dots)) 26 | (let-values ([(p flds lvls maybes) (cvt (syntax x) (fx+ n 1) flds lvls maybes)]) 27 | (values (if (eq? p 'any) 'each-any (vector 'each p)) flds lvls maybes))] 28 | [(x dots y ... . z) 29 | (ellipsis? (syntax dots)) 30 | (let-values ([(z flds lvls maybes) (cvt (syntax z) n flds lvls maybes)]) 31 | (let-values ([(y flds lvls maybes) (cvt* (syntax (y ...)) n flds lvls maybes)]) 32 | (let-values ([(x flds lvls maybes) (cvt (syntax x) (fx+ n 1) flds lvls maybes)]) 33 | (values `#(each+ ,x ,(reverse y) ,z) flds lvls maybes))))] 34 | [(maybe x) 35 | (and (identifier? #'x) (eq? (datum maybe) 'maybe)) 36 | (values 'any (cons #'x flds) (cons n lvls) (cons #t maybes))] 37 | [(x . y) 38 | (let-values ([(y flds lvls maybes) (cvt (syntax y) n flds lvls maybes)]) 39 | (let-values ([(x flds lvls maybes) (cvt (syntax x) n flds lvls maybes)]) 40 | (values (cons x y) flds lvls maybes)))] 41 | [() (values '() flds lvls maybes)] 42 | [oth (syntax-violation 'cvt "unable to find match" #'oth)])))) 43 | (cvt pattern 0 '() '() '())))) 44 | 45 | 46 | -------------------------------------------------------------------------------- /Framework/prims.ss: -------------------------------------------------------------------------------- 1 | ;; This library exposes two categories of primitives for dealing with 2 | ;; language terminals in grammars (i.e. primitive things like Int and UVar). 3 | ;; 4 | ;; (1) predicates: isFoo function returns #t if its input is a Foo 5 | ;; (2) checkers: the Foo function checks that the input is a valid 6 | ;; Foo, returning #f if everything is ok, and an error string otherwise. 7 | 8 | (library (Framework prims) 9 | (export 10 | UVar FVar Label Reg Relop Binop Disp Ind Int64 Int32 UInt6 Integer 11 | isUVar isFVar isLabel isReg isRelop isBinop isDisp isInd 12 | isInt64 isInt32 isUInt6 invalid-expr 13 | ValPrim PredPrim EffectPrim 14 | checkValPrim checkPredPrim checkEffectPrim 15 | isImmediate Immediate 16 | isDatum Datum) 17 | (import (chezscheme) 18 | (Framework match) 19 | (Framework helpers)) 20 | 21 | ;; Return a string representing an error message: 22 | (define invalid-expr 23 | (lambda (t e) 24 | (format "Invalid ~a: ~a\n" t e))) 25 | 26 | ;; Check if a list of characters represents a valid positive number: 27 | (define Index 28 | (lambda (ls) 29 | (and (not (null? ls)) 30 | (list? ls) 31 | (or (null? (cdr ls)) (not (eq? (car ls) #\0))) ;; No leading zeros. 32 | (for-all char-numeric? ls)))) 33 | 34 | ;; An immediate is used in the Scheme front-end for quoted constants. 35 | (define isImmediate 36 | (lambda (x) 37 | (or (fixnum? x) 38 | (eq? x #t) (eq? x #f) 39 | (eq? x '())))) 40 | 41 | ;; A datum is a structured, complex constant 42 | (define isDatum 43 | (lambda (x) 44 | (cond 45 | [(isImmediate x) #t] 46 | [(pair? x) (and (isDatum (car x)) (isDatum (cdr x)))] 47 | [(vector? x) (isDatum (vector->list x))] 48 | [else #f]))) 49 | 50 | ;; This is very slow... TODO: operate directly on the strings: 51 | (define isUVar 52 | (lambda (x) 53 | (and (symbol? x) 54 | ;; TODO: use substring and string->number: 55 | (let ((ls (string->list (symbol->string x)))) 56 | (let ([suffix (memq #\. ls)]) 57 | (and suffix 58 | (Index (cdr suffix)))))))) 59 | 60 | (define isFVar 61 | (lambda (x) 62 | (and (symbol? x) 63 | (let ((ls (string->list (symbol->string x)))) 64 | (match ls 65 | ((#\f #\v . ,ind) (Index ind)) 66 | (,e #f)))))) 67 | 68 | (define isLabel 69 | (lambda (x) 70 | (and (symbol? x) 71 | (let ls ((ls (string->list (symbol->string x)))) 72 | (let suf ([suffix (memq #\$ ls)]) 73 | (and suffix 74 | (Index (cdr suffix)))))))) 75 | 76 | (define relops '(< <= = >= >)) 77 | (define binops '(* - + logand logor sra)) 78 | 79 | (define isReg 80 | (lambda (x) 81 | (and (memq x registers) #t))) 82 | 83 | (define isRelop 84 | (lambda (x) 85 | (and (memq x relops) #t))) 86 | 87 | (define isBinop 88 | (lambda (x) 89 | (and (memq x binops) #t))) 90 | 91 | ;; Returns the arity if it is a value-primitive, otherwise #f. 92 | (define checkValPrim 93 | (lambda (x) 94 | (let ((pr (assq x value-prims))) 95 | (if pr (cdr pr) #f)))) 96 | 97 | ;; Returns the arity if it is a predicate-primitive, otherwise #f. 98 | (define checkPredPrim 99 | (lambda (x) 100 | (let ((pr (assq x pred-prims))) 101 | (if pr (cdr pr) #f)))) 102 | 103 | ;; Returns the arity if it is an effect-primitive, otherwise #f. 104 | (define checkEffectPrim 105 | (lambda (x) 106 | (let ((pr (assq x effect-prims))) 107 | (if pr (cdr pr) #f)))) 108 | 109 | (define value-prims 110 | '((* . 2) (+ . 2) (- . 2) (car . 1) (cdr . 1) (cons . 2) 111 | (make-vector . 1) (vector-length . 1) (vector-ref . 2) 112 | (void . 0))) 113 | (define pred-prims 114 | '((< . 2) (<= . 2) (= . 2) (>= . 2) (> . 2) (boolean? . 1) 115 | (eq? . 2) (fixnum? . 1) (null? . 1) (pair? . 1) 116 | (vector? . 1))) 117 | (define effect-prims 118 | '((set-car! . 2) (set-cdr! . 2) (vector-set! . 3))) 119 | 120 | ;; It looks like Kyle wanted to switch these to sexps and didn't finish: 121 | ; (define isDisp 122 | ; (lambda (x) 123 | ; (match x 124 | ; [(disp ,[isReg -> reg] ,[isInt64 -> ind]) 125 | ; (and reg ind)] 126 | ; [,_ #f]))) 127 | 128 | (define isDisp disp-opnd?) 129 | 130 | (define isInd index-opnd?) 131 | 132 | (define isInt64 int64?) 133 | 134 | (define isInt32 int32?) 135 | 136 | (define isUInt6 uint6?) 137 | 138 | ;; Terminals -- the contract is that these functions return #f if 139 | ;; NOTHING IS WRONG (i.e. the datum passes). Otherwise, they return 140 | ;; an error message. 141 | (define UVar (lambda (x) (if (isUVar x) #f (invalid-expr 'UVar x)))) 142 | (define FVar (lambda (x) (if (isFVar x) #f (invalid-expr 'FVar x)))) 143 | (define Label (lambda (x) (if (isLabel x) #f (invalid-expr 'Label x)))) 144 | (define Reg (lambda (x) (if (isReg x) #f (invalid-expr 'Reg x)))) 145 | (define Relop (lambda (x) (if (isRelop x) #f (invalid-expr 'Relop x)))) 146 | (define Binop (lambda (x) (if (isBinop x) #f (invalid-expr 'Binop x)))) 147 | (define Disp (lambda (x) (if (isDisp x) #f (invalid-expr 'Disp x)))) 148 | (define Ind (lambda (x) (if (isInd x) #f (invalid-expr 'Ind x)))) 149 | (define Int64 (lambda (x) (if (isInt64 x) #f (invalid-expr 'Int64 x)))) 150 | (define Int32 (lambda (x) (if (isInt32 x) #f (invalid-expr 'Int32 x)))) 151 | (define UInt6 (lambda (x) (if (isUInt6 x) #f (invalid-expr 'UInt6 x)))) 152 | (define Integer (lambda (x) (if (integer? x) #f (invalid-expr 'Integer x)))) 153 | 154 | (define ValPrim (lambda (x) (if (checkValPrim x) #f (invalid-expr 'ValPrim x)))) 155 | (define EffectPrim (lambda (x) (if (checkEffectPrim x) #f (invalid-expr 'EffectPrim x)))) 156 | (define PredPrim (lambda (x) (if (checkPredPrim x) #f (invalid-expr 'PredPrim x)))) 157 | 158 | (define Immediate (lambda (x) (if (isImmediate x) #f (invalid-expr 'Immediate x)))) 159 | (define Datum (lambda (x) (if (isDatum x) #f (invalid-expr 'Datum x)))) 160 | ) 161 | -------------------------------------------------------------------------------- /FrameworkHs/ParseL01.hs: -------------------------------------------------------------------------------- 1 | 2 | module FrameworkHs.ParseL01 where 3 | 4 | import Data.IntMap (toList, (!), Key) 5 | import Control.Applicative ((<$>), (<*>)) 6 | import Debug.Trace (trace) 7 | import FrameworkHs.GenGrammars.L01VerifyScheme 8 | import FrameworkHs.SExpReader.LispData 9 | import FrameworkHs.Prims 10 | import FrameworkHs.Helpers (parseListWithFinal, parseInt32, parseInt64, parseLabel, parseUVar, 11 | parseFailureM, PassM, orPassM, isInt64, 12 | parseValPrim, parseEffectPrim, parsePredPrim) 13 | 14 | 15 | parseProg :: LispVal -> PassM Prog 16 | parseProg l = Expr <$> parseExpr l 17 | 18 | parseBinds :: LispVal -> PassM [(UVar,Expr)] 19 | parseBinds (List ls) = mapM fn ls 20 | where 21 | fn (List [lhs,rhs]) = 22 | do uv <- parseUVar lhs 23 | rhs' <- parseExpr rhs 24 | return (uv,rhs') 25 | 26 | parseLetrecBinds :: LispVal -> PassM [(UVar, Expr)] 27 | parseLetrecBinds (List ls) = mapM fn ls 28 | where 29 | fn (List [name, body]) = do 30 | name' <- parseUVar name 31 | body' <- parseExpr body 32 | return (name', body') 33 | 34 | parseExpr :: LispVal -> PassM Expr 35 | 36 | parseExpr (List [Symbol "begin"]) = parseFailureM "empty begin form" 37 | 38 | parseExpr (List (Symbol "begin" : rst)) = do 39 | es' <- mapM parseExpr (init rst) 40 | v' <- parseExpr (last rst) 41 | return$ Begin es' v' 42 | 43 | parseExpr (List [Symbol "letrec",binds,bod]) = do 44 | binds' <- parseLetrecBinds binds 45 | bod' <- parseExpr bod 46 | return $ Letrec binds' bod' 47 | 48 | parseExpr (List [Symbol "if",p,v1,v2]) = do 49 | p' <- parseExpr p 50 | v1' <- parseExpr v1 51 | v2' <- parseExpr v2 52 | return$ If p' v1' v2' 53 | 54 | parseExpr (List [Symbol "set!",uv,e]) = do 55 | uv' <- parseUVar uv 56 | e' <- parseExpr e 57 | return$ Set uv' e' 58 | 59 | parseExpr (List [Symbol "lambda", List formals, bod]) = do 60 | formals' <- mapM parseUVar formals 61 | bod' <- parseExpr bod 62 | return $ Lambda formals' bod' 63 | 64 | parseExpr (List [(Symbol "let"),binds,bod]) = do 65 | binds' <- parseBinds binds 66 | bod' <- parseExpr bod 67 | return (Let binds' bod') 68 | 69 | parseExpr (List [Symbol "quote",d]) = 70 | Quote <$> parseDatum d 71 | 72 | parseExpr (List (op:rst)) = do 73 | firstItem <- (fmap App1 $ parseValPrim op) `orPassM` 74 | (fmap App2 $ parseEffectPrim op) `orPassM` 75 | (fmap App3 $ parsePredPrim op) `orPassM` 76 | (fmap App4 $ parseExpr op) 77 | exprs <- mapM parseExpr rst 78 | return $ firstItem exprs 79 | 80 | parseExpr sym@(Symbol _) = 81 | (UVar <$> parseUVar sym) 82 | 83 | parseDatum :: LispVal -> PassM Datum 84 | parseDatum (IntNumber i) | isInt64 i = 85 | return . ImmediateDatum . Fixnum $ fromInteger i 86 | parseDatum (Boolean True) = return $ ImmediateDatum HashT 87 | parseDatum (Boolean False) = return $ ImmediateDatum HashF 88 | parseDatum (List [s1, Symbol ".", s2]) = 89 | PairDatum <$> parseDatum s1 <*> parseDatum s2 90 | parseDatum (List sexps) = do 91 | sexps' <- mapM parseDatum sexps 92 | return $ foldr PairDatum (ImmediateDatum NullList) sexps' 93 | parseDatum (Vector n m) = 94 | VectorDatum <$> mapM parseDatum (tabulate (m!) $ fromInteger n) 95 | parseDatum sexp = parseFailureM $ "Parse error: invalid datum " ++ show sexp 96 | 97 | tabulate :: (Int -> a) -> Int -> [a] 98 | tabulate f n = t 0 99 | where 100 | --t :: Int -> [a] 101 | t i = if i == 0 then [] else f i : t (i + 1) 102 | -------------------------------------------------------------------------------- /FrameworkHs/Prims.hs: -------------------------------------------------------------------------------- 1 | 2 | module FrameworkHs.Prims 3 | ( UVar (..) 4 | , FVar (..) 5 | , Label (..) 6 | , Reg (..), numRegisters, allRegisters 7 | , Relop (..) 8 | , Binop (..) 9 | , Disp (..) 10 | , Ind (..) 11 | , LooseEq(..) 12 | , PredPrim(..), EffectPrim (..), ValPrim(..) 13 | , valPrimArity, effectPrimArity, predPrimArity 14 | , Immediate(..) 15 | , Datum(..) 16 | ) 17 | where 18 | 19 | import Prelude as P hiding (LT, EQ, GT) 20 | import Data.Int 21 | import Data.Symbol 22 | 23 | -------------------------------------------------------------------------------- 24 | -- Terminal Type Definitions --------------------------------------------------- 25 | 26 | data UVar = UV String Integer deriving (Read, Show, Eq, Ord) 27 | data Label = L String Integer deriving (Read, Show, Eq, Ord) 28 | data FVar = FV Integer deriving (Read, Show, Eq, Ord) 29 | 30 | data UVar' = UV' Symbol Integer deriving (Show, Eq, Ord) 31 | data Label' = L' Symbol Integer deriving (Show, Eq, Ord) 32 | 33 | -- | use a loose equality test that only test the suffix of a uvar or label 34 | -- rather than testing the Symbol and the Integer for equality. 35 | class LooseEq a where 36 | (.=) :: a -> a -> Bool 37 | 38 | instance LooseEq UVar where 39 | (UV var1 suffix1) .= (UV var2 suffix2) = suffix1 P.== suffix2 40 | 41 | instance LooseEq Label where 42 | (L var1 suffix1) .= (L var2 suffix2) = suffix1 P.== suffix2 43 | 44 | instance LooseEq UVar' where 45 | (UV' var1 suffix1) .= (UV' var2 suffix2) = suffix1 P.== suffix2 46 | 47 | instance LooseEq Label' where 48 | (L' var1 suffix1) .= (L' var2 suffix2) = suffix1 P.== suffix2 49 | 50 | 51 | data Reg = RAX | RCX | RDX | RBX | RBP | RSI | RDI | R8 | R9 52 | | R10 | R11 | R12 | R13 | R14 | R15 53 | deriving (Read,Show,Eq,Ord, Bounded, Enum) 54 | 55 | allRegisters :: [Reg] 56 | allRegisters = [minBound .. maxBound] 57 | 58 | numRegisters :: Int 59 | numRegisters = 1 + fromEnum (maxBound :: Reg) - fromEnum (minBound :: Reg) 60 | 61 | -- Low Level machine primitives: 62 | ---------------------------------------- 63 | 64 | data Relop = LT | LTE | EQ | GT | GTE deriving (Read,Show,Eq,Ord) 65 | data Binop = MUL | ADD | SUB | LOGAND | LOGOR | SRA deriving (Read,Show,Eq,Ord) 66 | 67 | data Disp = D Reg Integer deriving (Read,Show,Eq, Ord) 68 | data Ind = I Reg Reg deriving (Read,Show,Eq, Ord) 69 | 70 | 71 | -- High-level Scheme primitives: 72 | ---------------------------------------- 73 | 74 | data PredPrim = Lt | Lte | Eq | Gte | Gt 75 | | BooleanP | EqP | FixnumP | NullP | PairP | VectorP | ProcedureP 76 | deriving (Read, Show, Eq, Ord) 77 | 78 | data EffectPrim = SetCar | SetCdr | VectorSet | ProcedureSet 79 | deriving (Read, Show, Eq, Ord) 80 | 81 | data ValPrim = Times | Plus | Minus | Car | Cdr | Cons 82 | | MakeVector | VectorLength | VectorRef | Void 83 | | MakeProcedure | ProcedureCode | ProcedureRef 84 | deriving (Read, Show, Eq, Ord) 85 | 86 | valPrimArity :: ValPrim -> Int 87 | valPrimArity vp = 88 | case vp of 89 | Times -> 2 ; Plus -> 2 ; Minus -> 2 ; Car -> 1 ; Cdr -> 1 ; Cons -> 2 90 | MakeVector -> 1 ; VectorLength -> 1 ; VectorRef -> 2 ; Void -> 0 ; MakeProcedure -> 2 91 | ProcedureCode -> 1 ; ProcedureRef -> 2 92 | 93 | predPrimArity :: PredPrim -> Int 94 | predPrimArity pp = 95 | case pp of 96 | Lt -> 2 ; Lte -> 2 ; Eq -> 2 ; Gte -> 2 ; Gt -> 2 97 | BooleanP -> 1 ; EqP -> 2 ; FixnumP -> 1 ; NullP -> 1 ; PairP -> 1 ; VectorP -> 1 98 | ProcedureP -> 1 99 | 100 | effectPrimArity :: EffectPrim -> Int 101 | effectPrimArity ep = 102 | case ep of 103 | SetCar -> 2 ; SetCdr -> 2 ; VectorSet -> 3 ; ProcedureSet -> 3 104 | 105 | data Immediate = Fixnum Int64 | NullList | HashT | HashF 106 | deriving (Read, Show, Eq, Ord) 107 | 108 | data Datum = PairDatum Datum Datum 109 | | VectorDatum [Datum] 110 | | ImmediateDatum Immediate 111 | deriving (Read, Show, Eq, Ord) 112 | -------------------------------------------------------------------------------- /GrammarCompiler/common/aux.ss: -------------------------------------------------------------------------------- 1 | (library (GrammarCompiler common aux) 2 | (export builtin-tags 3 | builtin-types 4 | compose 5 | haskell-upcase-name 6 | scheme->haskell/string 7 | scheme->filename/string 8 | numbered-names 9 | number-symbol 10 | capitalize-string 11 | char-haskell? 12 | char-filename? 13 | terminal? 14 | non-terminal? 15 | string-filter 16 | to-string) 17 | (import (chezscheme)) 18 | 19 | (define-syntax compose 20 | (syntax-rules () 21 | ((_ f) f) 22 | ((_ f f* ...) 23 | (lambda (x) 24 | ((compose f* ...) 25 | (f x)))))) 26 | 27 | (define builtin-tags 28 | (lambda () 29 | '(true false))) 30 | 31 | (define builtin-types 32 | (lambda () 33 | '(True False Num))) 34 | 35 | (define split 36 | (lambda (c ls) 37 | (cond 38 | ((null? ls) '(())) 39 | ((eq? (car ls) c) 40 | (let ((res (split c (cdr ls)))) 41 | (cons '() res))) 42 | (else 43 | (let ((res (split c (cdr ls)))) 44 | (let ((a (car res)) 45 | (d (cdr res))) 46 | (cons (cons (car ls) a) d))))))) 47 | 48 | (define haskell-upcase-name 49 | (lambda (s) 50 | (string->symbol 51 | (capitalize-string 52 | (scheme->haskell/string 53 | (symbol->string s)))))) 54 | 55 | (define scheme->filename/string 56 | (lambda (s) 57 | (string-filter 58 | char-filename? s))) 59 | 60 | (define scheme->haskell/string 61 | (lambda (s) 62 | (let ((ls (string->list s))) 63 | (let ((ls* (map 64 | (lambda (ls) 65 | (list->string 66 | (filter 67 | char-haskell? ls))) 68 | (split #\- ls)))) 69 | (apply string-append 70 | (car ls*) 71 | (map string-titlecase (cdr ls*))))))) 72 | 73 | (define numbered-names 74 | (lambda (ls) 75 | (let loop ((ls ls) (seen '())) 76 | (cond 77 | ((null? ls) '()) 78 | (else 79 | (let ((s (downcase-prefix (car ls)))) 80 | (let-values (((p rest) 81 | (partition (lambda (p) (string=? (car p) s)) seen))) 82 | (cond 83 | ((null? p) 84 | (cons 85 | (string->symbol s) 86 | (loop (cdr ls) 87 | (cons `(,s . 1) rest)))) 88 | (else 89 | (let* ((p (car p)) 90 | (n (cdr p)) 91 | (n^ (add1 n))) 92 | (cons 93 | (number-symbol s n^) 94 | (loop (cdr ls) 95 | (cons `(,s . ,n^) rest))))))))))))) 96 | 97 | (define number-symbol 98 | (lambda (str n) 99 | (string->symbol 100 | (string-append 101 | str (number->string n))))) 102 | 103 | (define downcase-prefix 104 | (lambda (s) 105 | (string 106 | (char-downcase 107 | (string-ref (symbol->string s) 0))))) 108 | 109 | (define capitalize-string 110 | (lambda (s) 111 | (let ((ls (string->list s))) 112 | (list->string 113 | (cons (char-upcase (car ls)) 114 | (cdr ls)))))) 115 | 116 | (define string-filter 117 | (lambda (p s) 118 | (list->string 119 | (filter p (string->list s))))) 120 | 121 | (define char-haskell? 122 | (lambda (c) 123 | (or (eq? c #\') 124 | (char-alphabetic? c) 125 | (char-numeric? c)))) 126 | 127 | (define char-filename? 128 | (lambda (c) 129 | (or (char-alphabetic? c) 130 | (char-numeric? c) 131 | (eq? c #\-)))) 132 | 133 | (define to-string 134 | (lambda (x) 135 | (format "~a" x))) 136 | 137 | (define terminal? 138 | (lambda (s) 139 | (or (null? s) 140 | (and (symbol? s) 141 | (char-lower-case? 142 | (string-ref (symbol->string s) 0)))))) 143 | 144 | (define non-terminal? 145 | (lambda (s) 146 | (and (symbol? s) 147 | (char-upper-case? 148 | (string-ref (symbol->string s) 0))))) 149 | 150 | ) 151 | -------------------------------------------------------------------------------- /GrammarCompiler/common/desugar-directives.ss: -------------------------------------------------------------------------------- 1 | (library (GrammarCompiler common desugar-directives) 2 | (export desugar-directives) 3 | (import (chezscheme) 4 | (GrammarCompiler common match) 5 | (GrammarCompiler common aux)) 6 | 7 | (define desugar-directives 8 | (lambda (x) 9 | (match x 10 | ((p423-grammars ,init . ,rest) 11 | (let ((gs (process-rest init rest))) 12 | `(p423-grammars . ,gs)))))) 13 | 14 | (define process-rest 15 | (lambda (prev gs) 16 | (scan-left increment-grammar prev gs))) 17 | 18 | (define increment-grammar 19 | (lambda (prev g) 20 | 21 | (define Stage1 22 | (lambda (ds) 23 | (match ds 24 | (() '(() () ())) 25 | (((%remove . ,r*) . ,rest) 26 | (cons (map process-remove r*) 27 | (Stage2 rest))) 28 | (,else (cons '() (Stage2 else)))))) 29 | 30 | (define Stage2 31 | (lambda (ds) 32 | (match ds 33 | (() '(() ())) 34 | (((%rename . ,r*) . ,rest) 35 | (cons (map process-rename r*) 36 | (Stage3 rest))) 37 | (,else (cons '() (Stage3 else)))))) 38 | 39 | (define Stage3 40 | (lambda (ds) 41 | (match ds 42 | (() '(())) 43 | (((%add . ,a*)) 44 | (list (map process-add a*))) 45 | (,else 46 | (errorf 'increment-grammar "Badly ordered directives: ~a" else))))) 47 | 48 | (define process-remove 49 | (lambda (r) 50 | (match r 51 | ((,NT . ,sub*) r) 52 | (,NT `(,r))))) 53 | 54 | (define process-rename 55 | (lambda (r) 56 | (match r 57 | ((,NT1 -> ,NT2) `(,NT1 . ,NT2)) 58 | (,else (errorf 'process-rename "bad rename directive: ~a" else))))) 59 | 60 | (define process-add 61 | (lambda (a) 62 | (match a 63 | ((,NT . ,sub*) a) 64 | (,else 65 | (errorf 'process-add "bad add directive: ~a" else))))) 66 | 67 | (let ((name (car g)) (ds (cdr g))) 68 | (let ((ds (Stage1 ds))) 69 | (let ((rem (car ds)) (ren (cadr ds)) (add (caddr ds))) 70 | (match prev 71 | ((,old-name (start ,st) . ,[(compose (Remove rem) (Rename ren) (Add add) merge-alists) -> types]) 72 | (let ((result `(,name (start ,st) . ,types))) 73 | (pretty-print result) 74 | result)) 75 | (,e (errorf 'increment-grammar "invalid: ~a" e)))))))) 76 | 77 | (define Remove 78 | (lambda (r*) 79 | (lambda (g) 80 | 81 | (define Terminals 82 | (lambda (ts) 83 | (if 84 | (null? ts) '() 85 | (let ((t (car ts))) 86 | (cond 87 | ((assq (car t) r*) => 88 | (lambda (p) 89 | (Terminals (cdr ts)))) 90 | (else 91 | (cons t (Terminals (cdr ts))))))))) 92 | 93 | (define Types 94 | (lambda (ts) 95 | (if 96 | (null? ts) '() 97 | (let ((t (car ts))) 98 | (cond 99 | ((assq (car t) r*) => 100 | (lambda (p) 101 | (let ((type (car p)) (rem-subs (cdr p))) 102 | (cond 103 | ((null? rem-subs) 104 | (Types (cdr ts))) 105 | (else 106 | (let ((new-subs 107 | (remp 108 | (lambda (s) 109 | (if (list? s) 110 | (memq (car s) rem-subs) 111 | (memq s rem-subs))) 112 | (cdr t)))) 113 | (cond 114 | ((null? new-subs) 115 | (Types (cdr ts))) 116 | (else 117 | (cons 118 | (cons type new-subs) 119 | (Types (cdr ts))))))))))) 120 | (else 121 | (cons t (Types (cdr ts))))))))) 122 | 123 | (Types g)))) 124 | 125 | (define Rename 126 | (lambda (r*) 127 | (lambda (g) 128 | 129 | (define Types 130 | (lambda (ts) 131 | (cond 132 | ((null? ts) '()) 133 | ((pair? (car ts)) 134 | (cons (Types (car ts)) 135 | (Types (cdr ts)))) 136 | ((assq (car ts) r*) => 137 | (lambda (p) 138 | (cons (cdr p) 139 | (Types (cdr ts))))) 140 | (else (cons (car ts) 141 | (Types (cdr ts))))))) 142 | 143 | (Types g)))) 144 | 145 | (define Add 146 | (lambda (a*) 147 | (lambda (g) 148 | (append g a*)))) 149 | 150 | (define scan-left 151 | (lambda (f q ls) 152 | (let ((res (cond 153 | ((null? ls) '()) 154 | (else 155 | (let ((q (f q (car ls)))) 156 | (scan-left f q (cdr ls))))))) 157 | (cons q res)))) 158 | 159 | (define trans2-map 160 | (lambda (f ls) 161 | (let ((ls (map f ls))) 162 | (map (lambda (ls) (apply append ls)) 163 | (list (map car ls) (map cdr ls)))))) 164 | 165 | (define merge-alists 166 | (lambda (als*) 167 | (if 168 | (null? als*) '() 169 | (let ((first (car als*)) (rest (cdr als*))) 170 | (let-values (((these others) 171 | (partition (lambda (ls) (eq? (car ls) (car first))) rest))) 172 | (cons 173 | (cons (car first) 174 | (apply append (cdr first) (map cdr these))) 175 | (merge-alists others))))))) 176 | 177 | ) 178 | -------------------------------------------------------------------------------- /GrammarCompiler/haskell/derive-parsing.ss: -------------------------------------------------------------------------------- 1 | ;(library (GrammarCompiler haskell derive-parsing) 2 | ; (export derive-parsing) 3 | (import (chezscheme) 4 | (GrammarCompiler common aux) 5 | (GrammarCompiler common match)) 6 | 7 | (define derive-parsing 8 | (lambda (x) 9 | (match x 10 | ((module ,name ,[Type -> t*] ...) 11 | `(module ,name . ,t*))))) 12 | 13 | (define Type 14 | (lambda (x) 15 | (match x 16 | ((data ,name . ,s*) 17 | (let ((s* (map (Sub name) s*))) 18 | `(data ,name . ,s*)))))) 19 | 20 | (define Sub 21 | (lambda (n) 22 | (lambda (x) 23 | (match x 24 | (((,name . ,ts) 25 | ,lhs 26 | (print ,p)) 27 | (let-values (((e fs m w) (gen-parsing p ts))) 28 | (let ((pf (parse-function n))) 29 | (let ((all-of-it `(,pf ,n ,e ,m ,lhs . ,w))) 30 | `((,name . ,ts) 31 | ,lhs 32 | (print ,p) 33 | (parse ,all-of-it)))))))))) 34 | 35 | ;(data Tail 36 | ; ((app Triv) 37 | ; (t) 38 | ; (print (ppSexp (list (string app) (pp t)))) 39 | ; (app Triv)) 40 | ; ((begin (list Effect) Tail) 41 | ; (l t) 42 | ; (print 43 | ; (ppSexp 44 | ; (cons (string begin) (append (map pp l) (list (pp t)))))) 45 | ; (begin Effect * Tail))) 46 | 47 | ;parseTail :: LispVal -> Maybe Tail 48 | ;parseTail (List ((Symbol begin) : l)) = 49 | ; do (l,t) <- parseListWithFinal parseEffect parseTail l 50 | ; return (Begin l t) 51 | ; 52 | ;(parseTail 53 | ; ((List (cons (Symbol begin) l)) 54 | ; (((tuple l t) . (parseListWithFinal parseEffect parseTail l)) 55 | ; (Begin l t)))) 56 | 57 | (define parse 58 | (lambda (x n) 59 | 60 | (define List (lambda (x n) (values x n '()))) 61 | 62 | (match x 63 | (,t (guard (terminal? t)) 64 | (values `(Symbol ,t) n '())) 65 | (,nt (guard (non-terminal? nt)) 66 | (let ((f (parse-function nt)) 67 | (v (make-var 'x n))) 68 | (values v n `((,v . (,f ,v)))))) 69 | ((,ls *) 70 | (let ((v (make-var 'ls n))) 71 | (let-values (((f _ m) (List ls (add1 n)))) 72 | (values v n `((,v . (parseList ,f ,v)) . ,m))))) 73 | ((,ls * ,last) 74 | (let ((v1 (make-var 'ls n))) 75 | (let-values (((f n m) (List ls (add1 n)))) 76 | (let ((v2 (make-var 'x n))) 77 | (let-values (((last n m^) (parse last (add1 n)))) 78 | (values `(,v1 ,v2) n `(,@m . ,m^))))))) 79 | ((,a . ,d) 80 | (let ((v1 (make-var 'x n))) 81 | (let-values (((a n m) (parse a (add1 n)))) 82 | (let ((v2 (make-var 'x n))) 83 | (let-values (((d n m^) (parse d (add1 n)))) 84 | (values `(,v1 . ,v2) n `(,@m . ,m^))))))) 85 | (() (values '() n '()))))) 86 | 87 | (define map-vals 88 | (lambda (f ls fs) 89 | (cond 90 | ((null? ls) (values '() fs '() '())) 91 | (else 92 | (let-values (((a fs m w) (f (car ls)))) 93 | (let-values (((d fs m^ w^) (map-vals f (cdr ls) fs))) 94 | (values `(,a . ,d) fs `(,@m . ,m^) `(,@w . ,w^)))))))) 95 | 96 | (define parse-function 97 | (lambda (s) 98 | (string->symbol 99 | (string-append 100 | "parse" 101 | (symbol->string s))))) 102 | 103 | (define make-var 104 | (lambda (s n) 105 | (string->symbol 106 | (string-append 107 | (symbol->string s) 108 | (number->string n))))) 109 | 110 | ;) 111 | -------------------------------------------------------------------------------- /GrammarCompiler/haskell/derive-printing.ss: -------------------------------------------------------------------------------- 1 | (library (GrammarCompiler haskell derive-printing) 2 | (export derive-printing) 3 | (import (chezscheme) 4 | (GrammarCompiler common match) 5 | (GrammarCompiler common aux)) 6 | 7 | ;; deriving-printing operates on the saved copy of the source grammars 8 | ;; subforms, deriving a haskell function for each that produces a string 9 | ;; representation of haskell data that is identical to the scheme sexp form. 10 | 11 | (define derive-printing 12 | (lambda (x) 13 | 14 | (define Sub 15 | (lambda (x) 16 | (match x 17 | ;; `(,name . ,fields) is the flattened version, form is the original 18 | (((,name . ,fields) ,form) 19 | (let ((field-names (field-names fields))) 20 | (let-values (((_ p) (Form (map cons field-names fields) form))) 21 | (let ((p (place-ppSexps (condense-structures p)))) 22 | `((,name . ,fields) 23 | (print (,name . ,field-names) ,p)))))) 24 | (,e (errorf 'derive/Sub "invalid: ~a" e))))) 25 | 26 | ;; Produces isomorphic haskell pretty-printing function 27 | (define Form 28 | (lambda (vars form) 29 | (match form 30 | (,nt (guard (non-terminal? nt)) 31 | (let ((p (car vars)) (vars (cdr vars))) 32 | (let ((v (car p)) (t (cdr p))) 33 | (values vars `(pp ,v))))) 34 | (() (values vars '())) 35 | ((,l * . ,rest) 36 | (let-values (((vars p) (List vars l))) 37 | (let ((f (car p)) (v (cdr p))) 38 | (let-values (((vars rest) (Form vars rest))) 39 | (values vars `(append (map ,f ,v) ,rest)))))) 40 | ((,p . ,rest) (guard (list? p)) 41 | (let-values (((vars p) (Form vars p))) 42 | (let-values (((vars rest) (Form vars rest))) 43 | (values vars `(cons ,p ,rest))))) 44 | ((,t . ,rest) (guard (terminal? t)) 45 | (let-values (((vars rest) (Form vars rest))) 46 | (values vars `(cons (string ,t) ,rest)))) 47 | ((,nt . ,rest) (guard (non-terminal? nt)) 48 | (let ((p (car vars)) (vars (cdr vars))) 49 | (let ((v (car p)) (t (cdr p))) 50 | (let-values (((vars rest) (Form vars rest))) 51 | (values vars `(cons (pp ,v) ,rest)))))) 52 | (,e (errorf 'derive/Form "invalid: ~a" e))))) 53 | 54 | (define List 55 | (lambda (vars form) 56 | (let ((p (car vars)) (vars (cdr vars))) 57 | (let ((v (car p)) (t (cdr p))) 58 | (match t 59 | ((list (tuple . ,ts)) 60 | (let ((vs (field-names ts))) 61 | (let-values (((_ f) (Form (map cons vs ts) form))) 62 | (values vars `((lambda ,vs ,f) . ,v))))) 63 | ((list ,x) 64 | (values vars `(pp . ,v))) 65 | (,e (errorf 'derive/List "invalid: ~a" e))))))) 66 | 67 | (match x 68 | ((tags ,tags 69 | ;(terminals ,t/p* 70 | (module ,name (data ,name* ,[Sub -> sub*] ...) ...)) 71 | ;) 72 | `(tags ,tags 73 | ;(terminals ,t/p* 74 | (module ,name (data ,name* ,sub* ...) ...))) 75 | ;) 76 | (,e (errorf 'derive-printing "invalid: ~a" e))))) 77 | 78 | ;; produces a list of names which each represent a haskell datum's field. 79 | (define field-names 80 | (lambda (fs) 81 | (numbered-names 82 | (map (lambda (f) (if (pair? f) 'l f)) 83 | fs)))) 84 | 85 | (define place-ppSexps 86 | (lambda (e) 87 | (define place 88 | (lambda (b e) 89 | (if b `(ppSexp ,e) e))) 90 | (define Elem 91 | (lambda (e) 92 | (match e 93 | ((list ,[l] ...) 94 | `(ppSexp (list . ,l))) 95 | ((cons ,[a] ,[List -> d]) 96 | `(ppSexp (cons ,a ,d))) 97 | ((append ,[List -> l1] ,[List -> l2]) 98 | `(ppSexp (append ,l1 ,l2))) 99 | ((map pp ,e) `(ppSexp (map pp ,e))) 100 | ((map (lambda ,fml ,[Elem -> body]) ,e) 101 | `(ppSexp (map (lambda ,fml ,body) ,e))) 102 | (,e e)))) 103 | (define List 104 | (lambda (e) 105 | (match e 106 | ((list ,[Elem -> l] ...) 107 | `(list . ,l)) 108 | ((cons ,[Elem -> a] ,[d]) 109 | `(cons ,a ,d)) 110 | ((append ,[l1] ,[l2]) 111 | `(append ,l1 ,l2)) 112 | ((map pp ,e) `(map pp ,e)) 113 | ((map (lambda ,fml ,[Elem -> body]) ,e) 114 | `(map (lambda ,fml ,body) ,e)) 115 | (,e (errorf 'place-ppSexps "huh? ~a" e))))) 116 | (Elem e))) 117 | 118 | ;; Cleans up pretty-printing function into readable form, 119 | ;; as well as raises ppSexp function to proper positions 120 | (define condense-structures 121 | (lambda (e) 122 | (match e 123 | ((cons ,[a] ,[d]) 124 | (match d 125 | ((list . ,l) `(list ,a . ,l)) 126 | ((append ,l1 ,l2) `(cons ,a (append ,l1 ,l2))) 127 | (,else `(cons ,a ,d)))) 128 | ((append ,[l1] ,[l2]) 129 | (match `(,l1 ,l2) 130 | ((,ll1 (list)) ll1) 131 | (((list) ,ll2) ll2) 132 | (((list . ,ll1) (list . ,ll2)) 133 | `(list ,ll1 ... . ,ll2)) 134 | (((list . ,ll1) (cons ,a ,d)) 135 | `(append (list ,ll1 ... ,a) ,d)) 136 | (,e `(append ,l1 ,l2)))) 137 | (() '(list)) 138 | ((map pp ,x) 139 | `(map pp ,x)) 140 | ((map (lambda ,fml* ,[e]) ,x) 141 | `(map (lambda ,fml* ,e) ,x)) 142 | ((string ,s) `(string ,s)) 143 | ((pp ,s) `(pp ,s)) 144 | (,e (errorf 'condense "invalid: ~a" e))))) 145 | 146 | ) 147 | -------------------------------------------------------------------------------- /GrammarCompiler/haskell/flatten-datatypes.ss: -------------------------------------------------------------------------------- 1 | (library (GrammarCompiler haskell flatten-datatypes) 2 | (export flatten-datatypes) 3 | (import (chezscheme) 4 | (GrammarCompiler common match) 5 | (GrammarCompiler common aux)) 6 | 7 | ;; flatten-datatypes traverses a single grammar and 8 | ;; performs the following operations: 9 | ;; - collects an alist mapping key terminal symbols to 10 | ;; the list of non-terminals under which they occur. 11 | ;; - drops the start symbol form 12 | ;; - flattens each subform of the non-terminals, but 13 | ;; - saves a copy of the original subforms, to 14 | ;; be used to derive pretty-printing functions 15 | 16 | (define seen-tags '()) 17 | 18 | (define flatten-datatypes 19 | (lambda (x) 20 | (set! seen-tags '()) 21 | (match x 22 | ((,name 23 | (start ,st) 24 | ,[Type -> type*] ...) 25 | `(tags ,seen-tags 26 | (module ,name . ,type*))) 27 | (,e (errorf 'flatten-datatypes "invalid grammar: ~a" e))))) 28 | 29 | ;; builds an alist that merges the values associated with a given key. 30 | (define add-tag 31 | (lambda (tag type) 32 | (set! seen-tags 33 | (let-values (((used-tag rest) 34 | (partition 35 | (lambda (t) 36 | (eq? (car t) tag)) 37 | seen-tags))) 38 | (cond 39 | ((null? used-tag) `((,tag ,type) . ,seen-tags)) 40 | (else 41 | (let ((used-tag (car used-tag))) 42 | (let ((used-types (cdr used-tag))) 43 | (cons `(,tag ,type . ,used-types) rest))))))))) 44 | 45 | (define Type 46 | (lambda (x) 47 | (match x 48 | ((,name ,[(Sub name) -> sub] ,[(Sub name) -> sub*] ...) 49 | `(data ,name ,sub . ,sub*)) 50 | (,else (errorf 'flatten/Type "invalid: ~a" else))))) 51 | 52 | ;; Sub returns (e^ e), where e is the original subform, and 53 | ;; e^ is the subform after flattening. The copies are for printing 54 | ;; and parsing purposes. 55 | (define Sub 56 | (lambda (type) 57 | (lambda (x) 58 | (match x 59 | ((,t . ,e*) (guard (terminal? t)) 60 | (begin 61 | (add-tag t type) 62 | (let ((new-e* (flatten-form e*))) 63 | `((,t . ,new-e*) (,t . ,e*))))) 64 | (,nt (guard (non-terminal? nt)) 65 | (let ((tag (string->symbol 66 | (string-downcase 67 | (symbol->string nt))))) 68 | (begin 69 | ;; covers cases like Disp, where a Loc will use the Disp constructor, 70 | ;; but the Disp datatype will also. 71 | (add-tag nt type) 72 | `((,nt ,nt) ,nt)))) 73 | ;; untagged subforms, eg. (Relop Triv Triv), are tagged with 'app' 74 | (,e* 75 | (begin 76 | (add-tag 'app type) 77 | (let ((new-e* (flatten-form e*))) 78 | `((app . ,new-e*) ,e*)))) 79 | (,else (errorf 'flatten/Sub "invalid: ~a" else)))))) 80 | 81 | ;; removes nesting and terminal symbols to produce form 82 | ;; that will directly translate to haskell datatype. 83 | (define flatten-form 84 | (lambda (x) 85 | (match x 86 | (,t (guard (terminal? t)) '()) 87 | (,nt (guard (non-terminal? nt)) `(,nt)) 88 | (() '()) 89 | ((,[List -> x] * . ,[rest]) 90 | (append x rest)) 91 | ((,[x] . ,[rest]) 92 | (append x rest)) 93 | (,else (errorf 'flatten-form "invalid: ~a" else))))) 94 | 95 | ;; haskell lists must be uniformly typed. 96 | ;; a single item in the list produces a list of that type. 97 | ;; multiple items in the list produce a list of tuples. 98 | (define List 99 | (lambda (x) 100 | (cond 101 | ((null? x) '()) 102 | ((or (atom? x) 103 | (null? (cdr x))) 104 | `((list ,x))) 105 | (else 106 | (let ((x (flatten-form x))) 107 | `((list (tuple . ,x)))))))) 108 | 109 | ) 110 | -------------------------------------------------------------------------------- /GrammarCompiler/haskell/lift-prints.ss: -------------------------------------------------------------------------------- 1 | (library (GrammarCompiler haskell lift-prints) 2 | (export lift-prints) 3 | (import (chezscheme) 4 | (GrammarCompiler common aux) 5 | (GrammarCompiler common match)) 6 | 7 | (define lift-prints 8 | (lambda (x) 9 | (match x 10 | ((module ,name . ,t*) 11 | (let-values (((t* p*) (Types t*))) 12 | `((module ,name . ,t*) 13 | (print . ,p*))))))) 14 | 15 | (define Type 16 | (lambda (t) 17 | (match t 18 | ((data ,name . ,s*) 19 | (let-values (((s* p*) (Subs name s*))) 20 | (values `(data ,name . ,s*) p*)))))) 21 | 22 | (define Sub 23 | (lambda (s) 24 | (match s 25 | ((,s (print . ,p)) 26 | (values s `(,p)))))) 27 | 28 | (define map-2vals 29 | (lambda (f) 30 | (lambda (ls) 31 | (cond 32 | ((null? ls) (values '() '())) 33 | (else 34 | (let-values (((x v*) (f (car ls)))) 35 | (let-values (((x* v**) ((map-2vals f) (cdr ls)))) 36 | (values `(,x . ,x*) `(,@v* . ,v**))))))))) 37 | 38 | (define Types (map-2vals Type)) 39 | (define Subs 40 | (lambda (name s*) 41 | (let-values (((s* p*) ((map-2vals Sub) s*))) 42 | (values s* `((,name . ,p*)))))) 43 | 44 | ) 45 | -------------------------------------------------------------------------------- /GrammarCompiler/main.ss: -------------------------------------------------------------------------------- 1 | (library (GrammarCompiler main) 2 | (export compile-grammars scheme-path haskell-path) 3 | (import (chezscheme) 4 | (GrammarCompiler common match) 5 | (GrammarCompiler common aux) 6 | (GrammarCompiler common desugar-directives) 7 | (GrammarCompiler haskell flatten-datatypes) 8 | (GrammarCompiler haskell derive-printing) 9 | (GrammarCompiler haskell assign-tags) 10 | ;(GrammarCompiler haskell derive-parsing) 11 | (GrammarCompiler haskell lift-prints) 12 | (GrammarCompiler haskell emit-haskell) 13 | (GrammarCompiler scheme generate-verify) 14 | (GrammarCompiler scheme emit-scheme)) 15 | 16 | (define (scheme-path x) (syntax-violation #f "misplaced aux keyword" x)) 17 | (define (haskell-path x) (syntax-violation #f "misplaced aux keyword" x)) 18 | 19 | (define-syntax compile-grammars 20 | (syntax-rules (scheme-path haskell-path) 21 | ((_ src (scheme-path ss-path) (haskell-path hs-path)) 22 | (main src ss-path hs-path)))) 23 | 24 | (define haskell-passes 25 | (compose 26 | flatten-datatypes 27 | derive-printing 28 | assign-tags 29 | ;derive-parsing)) 30 | lift-prints)) 31 | 32 | (define scheme-passes 33 | (compose 34 | generate-verify)) 35 | 36 | (define main 37 | (lambda (source-file scheme-path haskell-path) 38 | (let ((grammars (read-file source-file))) 39 | (printf "========================================\n") 40 | (printf " Desugared grammars: \n") 41 | (printf "========================================\n") 42 | (match (desugar-directives grammars) 43 | ((p423-grammars (,name* . ,g*) ...) 44 | (printf "========================================\n") 45 | (map (lambda (name g) 46 | (printf " * Codegen for grammar: ~s\n" name) 47 | (let ((g `(,name . ,g))) 48 | (begin 49 | (write-haskell haskell-path name g) 50 | (write-scheme scheme-path name g)))) 51 | name* g*)))))) 52 | 53 | (define write-code 54 | (lambda (code-f name-f suf out-f path name g) 55 | (let ((code (code-f g)) 56 | (outfile 57 | (string-append 58 | path "/" 59 | (name-f (symbol->string name)) 60 | suf))) 61 | (with-output-to-file outfile 62 | (lambda () 63 | (out-f code)) 64 | 'replace) 65 | name))) 66 | 67 | (define write-haskell 68 | (lambda (path name code) 69 | (write-code haskell-passes 70 | (compose scheme->haskell/string 71 | capitalize-string) 72 | ".hs" 73 | (emit-haskell path) 74 | ;pretty-print 75 | path 76 | name 77 | code))) 78 | 79 | (define write-scheme 80 | (lambda (path name code) 81 | (write-code scheme-passes 82 | scheme->filename/string 83 | ".ss" 84 | (emit-scheme name (verifier-name name)) 85 | path 86 | name 87 | code))) 88 | 89 | (define read-file 90 | (lambda (f) 91 | (call-with-input-file f read))) 92 | 93 | ) 94 | -------------------------------------------------------------------------------- /GrammarCompiler/scheme/emit-scheme.ss: -------------------------------------------------------------------------------- 1 | (library (GrammarCompiler scheme emit-scheme) 2 | (export emit-scheme) 3 | (import (chezscheme)) 4 | 5 | (define (emit-scheme filename passname) 6 | (lambda (maindef) 7 | (printf ";; Automatically generated file -- DO NOT MODIFY\n") 8 | (pretty-print 9 | `(library (Framework GenGrammars ,filename) 10 | (export ,passname) 11 | (import (chezscheme) 12 | (Framework match) 13 | (Framework prims)) 14 | (define (any . nested-bool-ls) 15 | (letrec ((helper 16 | (lambda (x) 17 | (cond 18 | [(not x) #f] 19 | [(null? x) #f] 20 | [(pair? x) (or (helper (car x)) (helper (cdr x)))] 21 | [else x] 22 | )))) 23 | (helper nested-bool-ls))) 24 | ,maindef) 25 | ))) 26 | ) 27 | -------------------------------------------------------------------------------- /GrammarCompiler/scheme/generate-verify.ss: -------------------------------------------------------------------------------- 1 | (library (GrammarCompiler scheme generate-verify) 2 | (export generate-verify verifier-name) 3 | (import (chezscheme) 4 | (GrammarCompiler common match) 5 | (GrammarCompiler common aux)) 6 | 7 | (define generate-verify 8 | (lambda (x) 9 | (match x 10 | ((,[Name -> name] 11 | (start ,st) 12 | ;(with-terminals ,[Terminal -> t/p*] ...) 13 | ,[Type -> t*] ...) 14 | `(define ,name 15 | (lambda (x) 16 | ,t* ... 17 | ;,t/p* ... 18 | (let ((res (,st x))) 19 | (if res (errorf ',name "~a" res) x)))))))) 20 | 21 | (define Name 22 | (lambda (s) 23 | (string->symbol 24 | (string-append 25 | "verify-grammar:" 26 | (symbol->string s))))) 27 | 28 | (define verifier-name Name) 29 | 30 | (define Terminal 31 | (lambda (t/p) 32 | (let ((term (car t/p)) (pred (cadr t/p))) 33 | `(define ,term 34 | (lambda (x) 35 | (if (,pred x) #f (invalid-expr ',term x))))))) 36 | 37 | (define Type 38 | (lambda (x) 39 | (match x 40 | ((,name . ,sub*) 41 | (let-values (((s ns) (partition non-terminal? sub*))) 42 | (let* ((grouped (group-by-head ns)) 43 | (s (map Simple s))) 44 | `(define ,name 45 | (lambda (x) 46 | (match x 47 | ,s ... 48 | ,grouped ... 49 | (,(uq 'e) (invalid-expr ',name e))) 50 | )))))))) 51 | 52 | (define Simple 53 | (lambda (s) 54 | `(,(uq 'e) (guard (not (,s e))) #f))) 55 | 56 | ;; Grammars for this course are non-ambiguous. However, the leading 57 | ;; symbol does not uniquely identify a given construct in the grammar. 58 | ;; 59 | ;; This function groups non-terminals based on their leading symbol. 60 | (define (group-by-head ls) 61 | (match ls 62 | [() '()] 63 | [((,sym ,bod* ...) ,rst ...) (guard (symbol? sym)) 64 | (let-values ([(sibs others) (partition (lambda (x) (and (pair? x) (eq? sym (car x)))) rst)]) 65 | (let ([this-clause (if (null? sibs) 66 | (SubMatchClause (car ls)) 67 | `[(,sym . ,(uq 'bod)) 68 | (and ,(map (lambda (variant) 69 | `(match (cons ',sym bod) 70 | ,(SubMatchClause variant) 71 | [,(uq 'e) (invalid-expr ',sym e)])) 72 | (cons (car ls) sibs)) 73 | ...)] 74 | )]) 75 | (cons this-clause (group-by-head others))))] 76 | [,x (errorf 'group-by-head "expected non-terminal to be a list headed by a symbol: ~a" x)])) 77 | 78 | ;; Handle each nontrivial pattern for a nonterminal: 79 | (define (SubMatchClause s) 80 | (let-values 81 | (((s n seen) 82 | (let loop ((s s) (n 1) (seen '())) 83 | ;; seen - accumulate nonterminals encountered 84 | (cond 85 | ((null? s) (values '() n seen)) 86 | (else 87 | (let ((a (car s)) (d (cdr s))) 88 | (cond 89 | ((pair? a) 90 | (let-values (((a n seen) (loop a n seen))) 91 | (let-values (((d n seen) (loop d n seen))) 92 | (values `(,a . ,d) n seen)))) 93 | ((terminal? a) 94 | (let-values (((d n seen) (loop d n seen))) 95 | (values `(,a . ,d) n seen))) 96 | ((non-terminal? a) 97 | (let ((name (number-symbol "x" n))) 98 | (let-values (((d n seen) (loop d (add1 n) (cons name seen)))) 99 | (values 100 | (cons (uq `(,a -> ,name)) d) 101 | n 102 | seen)))) 103 | ((eq? a '*) 104 | (let-values (((d n seen) (loop d n seen))) 105 | (values `(... . ,d) n seen)))))))))) 106 | `(,s (any . ,seen)) 107 | )) 108 | 109 | (define uq 110 | (lambda (s) 111 | (list 'unquote s))) 112 | 113 | ) 114 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | #---------------------------------------------------------------------- 2 | # File Makefile 3 | # Written by Chris Frisz 4 | # 5 | # Created 10 Jan 2012 6 | # 7 | # This Makefile is intended for use with CSCI-P423 and runs the the 8 | # load_and_test.ss file. It may be extended to do other things as you 9 | # may need. 10 | #---------------------------------------------------------------------- 11 | 12 | #-- Variables --# 13 | SC=$(shell which scheme 2> /dev/null) 14 | ifeq ($(SC),) 15 | SC=petite 16 | endif 17 | HS=ghc 18 | 19 | # HS_FLAGS=-v0 20 | HS_FLAGS= 21 | 22 | SCRIPT_DIR=scripts 23 | 24 | SC_FILE=load_and_test.ss 25 | HS_FILE=LoadAndTest.hs 26 | CG_FILE=compile_grammars.ss 27 | 28 | SRC_GRAMMAR=source-grammar.ss 29 | 30 | HS_EXE=$(HS_FILE:.hs=.exe) 31 | 32 | #-- Rules --# 33 | 34 | # The main point of this file is to run the tests 35 | all : grammars 36 | 37 | grammars : Framework/GenGrammars 38 | Framework/GenGrammars: $(SRC_GRAMMAR) GrammarCompiler 39 | @mkdir -p Framework/GenGrammars 40 | @mkdir -p FrameworkHs/GenGrammars 41 | $(SC) --script $(SCRIPT_DIR)/$(CG_FILE) "$(SRC_GRAMMAR)" 42 | 43 | scheme : grammars 44 | $(SC) $(SCRIPT_DIR)/$(SC_FILE) 45 | 46 | scheme-test: 47 | echo '(import (Framework testing)) (exit (if (test-all) 0 1))' | scheme 48 | 49 | scheme-xml: 50 | @echo '(begin (import (Framework testing)) (exit (if (test-all-xml) 0 1)))' | $(SC) -q 51 | 52 | # Run the tests straight away: 53 | haskell: haskell-test 54 | haskell-test: grammars build-haskell 55 | ./$(HS_EXE) 56 | 57 | build-haskell: 58 | $(HS) --make -o $(HS_EXE) $(HS_FLAGS) $(SCRIPT_DIR)/$(HS_FILE) 59 | 60 | # Load up the compiler interactively so as to run the tests: 61 | haskell-interactive : grammars 62 | $(HS) --interactive $(HS_FLAGS) $(SCRIPT_DIR)/$(HS_FILE) 63 | 64 | # Test both backends: 65 | test: 66 | $(MAKE) clean 67 | $(MAKE) grammars 68 | # RRN: This cannot be interactive and needs to get the exit code right: 69 | $(MAKE) scheme-test 70 | # RRN: It can be faster to run interpreted rather than compile: 71 | # (But I'm having problems with that on SOIC machines.) 72 | # runghc $(SCRIPT_DIR)/$(HS_FILE) 73 | $(MAKE) haskell 74 | 75 | clean : 76 | rm -f t.s t $(HS_EXE) 77 | rm -rf Framework{,Hs}/GenGrammars 78 | find FrameworkHs -name "*.o" -exec rm -f {} \; 79 | find FrameworkHs -name "*.hi" -exec rm -f {} \; 80 | find CompilerHs -name "*.o" -exec rm -f {} \; 81 | find CompilerHs -name "*.hi" -exec rm -f {} \; 82 | 83 | .PHONY: scheme haskell grammars clean test test-scheme test-haskell 84 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # p423-compiler 2 | 3 | Archive repo of a Scheme to x86-64 compiler in Scheme. 4 | 5 | Supports: 6 | - closures 7 | - first-class procedures 8 | - side effects with `set!` 9 | - closure conversion, tail-call elimination, branch predication, constant folding, dead-code elimination, and... several other optimizations 10 | 11 | The supported BNF is listed as below. 12 | ``` 13 | Program ::= Expr 14 | Expr ::= Constant 15 | | Var 16 | | (quote Datum) 17 | | (if Expr Expr) 18 | | (if Expr Expr Expr) 19 | | (and Expr *) 20 | | (or Expr *) 21 | | (begin Expr * Expr) 22 | | (lambda (Var *) Expr +) 23 | | (let ([Var Expr] *) Expr +) 24 | | (letrec ([Var Expr] *) Expr +) 25 | | (set! Var Expr) 26 | | (prim Expr *) 27 | | (Expr Expr *) 28 | Datum ::= Constant | (Datum *) | #(Datum *) 29 | Constant ::= fixnum | () | #t | #f 30 | Var ::= an arbitrary symbol 31 | ``` 32 | 33 | For more information, please refer to the [course page](http://homes.soic.indiana.edu/classes/spring2015/csci/p423-rrnewton/) of CSCI-P 423 at Indiana University. Unless otherwise specified, I only own the files under [`Compiler`](https://github.com/keyanzhang/p423-compiler/tree/master/Compiler). 34 | -------------------------------------------------------------------------------- /p423-compiler.cabal: -------------------------------------------------------------------------------- 1 | Name: p423-compiler 2 | Version: 0.0.1 3 | Synopsis: P423 class compiler framework. 4 | 5 | Author: Ryan R. Newton 6 | Maintainer: rrnewton@gmail.com 7 | Category: Language 8 | Build-type: Simple 9 | 10 | -- Constraint on the version of Cabal needed to build this package: 11 | Cabal-version: >=1.10 12 | 13 | Library 14 | Exposed-modules: 15 | CompilerHs.Compile 16 | FrameworkHs.Helpers 17 | FrameworkHs.Driver 18 | FrameworkHs.Prims 19 | FrameworkHs.Testing 20 | FrameworkHs.SExpReader.LispData 21 | FrameworkHs.SExpReader.Parser 22 | FrameworkHs.ParseL01 23 | 24 | FrameworkHs.GenGrammars.L01VerifyScheme 25 | 26 | CompilerHs.VerifyScheme 27 | CompilerHs.GenerateX86_64 28 | 29 | default-language: Haskell2010 30 | build-depends: 31 | base == 4.*, deepseq == 1.3.*, vector >= 0.10, containers, process, pretty, 32 | symbol, mtl >= 2, parsec >=3, bytestring >= 0.10, blaze-builder 33 | 34 | Executable test-p423-compiler 35 | -- Replace the previous line with these two if you like: 36 | -- Test-Suite test-p423-compiler 37 | -- type: exitcode-stdio-1.0 38 | main-is: scripts/LoadAndTest.hs 39 | default-language: Haskell2010 40 | build-depends: 41 | base == 4.*, deepseq == 1.3.*, vector >= 0.10, containers, process, pretty, 42 | symbol, mtl >= 2, parsec >=3, bytestring >= 0.10, blaze-builder 43 | -------------------------------------------------------------------------------- /scripts/LoadAndTest.hi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/keyz/p423-compiler/5efe33f128d6d4b3decb818f315d9f14781cc241/scripts/LoadAndTest.hi -------------------------------------------------------------------------------- /scripts/LoadAndTest.hs: -------------------------------------------------------------------------------- 1 | import FrameworkHs.Testing 2 | import FrameworkHs.Helpers (Option (Default, Option)) 3 | 4 | import System.Exit (exitSuccess, exitFailure) 5 | import System.Console.GetOpt as G 6 | import System.Environment (getArgs) 7 | 8 | main = do 9 | argv <- getArgs 10 | let header = "Usage: LoadAndTest [OPTION...] [test-index ...]" 11 | (vs,ivs) <- case getOpt Permute options argv of 12 | (opts,other,[] ) -> 13 | case opts of 14 | [] -> runDefault 15 | [Invalid] -> runInvalid (map read other) 16 | [Valid] -> runValid (map read other) 17 | _ -> error "Cannot pass both --valid and --invalid" 18 | (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) 19 | 20 | if (all isPass vs && all isFail ivs) 21 | then exitSuccess 22 | else exitFailure 23 | 24 | 25 | 26 | isPass :: TestResult -> Bool 27 | isPass (Pass s) = True 28 | isPass (Fail e) = False 29 | 30 | isFail :: TestResult -> Bool 31 | isFail (Fail e) = True 32 | isFail (Pass s) = False 33 | 34 | data Flag = Valid | Invalid 35 | deriving Show 36 | 37 | options :: [OptDescr Flag] 38 | options = 39 | [ G.Option ['v'] ["valid"] (NoArg Valid) "run a selection of valid tests (by index)" 40 | , G.Option ['i'] ["invalid"] (NoArg Invalid) "run a selection of invalid tests (by index)" 41 | ] 42 | 43 | -------------------------------------------------------------------------------- /scripts/LoadAndTest.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/keyz/p423-compiler/5efe33f128d6d4b3decb818f315d9f14781cc241/scripts/LoadAndTest.o -------------------------------------------------------------------------------- /scripts/compile_grammars.ss: -------------------------------------------------------------------------------- 1 | #!/usr/bin/scheme-script 2 | (import (GrammarCompiler main)) 3 | 4 | (define source-grammar-file 5 | (lambda () 6 | (let ((args (command-line-arguments))) 7 | (if (not (= (length args) 1)) 8 | (errorf 'compile-grammars (usage args)) 9 | (car args))))) 10 | 11 | (define usage 12 | (lambda (a) 13 | (printf "Invalid arguments: ~a\n" a) 14 | (printf "Usage:\n") 15 | (printf " scheme --script compile_grammars.ss \n\n"))) 16 | 17 | (compile-grammars (source-grammar-file) 18 | (scheme-path "Framework/GenGrammars") 19 | (haskell-path "FrameworkHs/GenGrammars")) 20 | -------------------------------------------------------------------------------- /scripts/load_and_test.ss: -------------------------------------------------------------------------------- 1 | (import (Compiler compile)) 2 | (import (Framework testing)) 3 | 4 | (test-all) 5 | --------------------------------------------------------------------------------