├── .gitignore ├── LICENSE ├── Makefile ├── README ├── compiler ├── .gitignore ├── analysis.rkt ├── asm.rkt ├── assembler.rkt ├── ast.rkt ├── back-end.rkt ├── code-gen.rkt ├── comp.rkt ├── env.rkt ├── front-end.rkt ├── ir.rkt ├── library.scm ├── parser.rkt ├── picobit.rkt ├── primitives.rkt ├── reader.rkt ├── scheduling.rkt ├── tree-shaker.rkt └── utilities.rkt ├── p ├── picobit ├── tests ├── fail │ ├── compile │ │ ├── define-ordering.expected │ │ ├── define-ordering.scm │ │ ├── set-bang-prim.expected │ │ ├── set-bang-prim.scm │ │ ├── unbound.expected │ │ └── unbound.scm │ └── execute │ │ ├── car-number.expected │ │ └── car-number.scm ├── run-tests.rkt └── succeed │ ├── 256.expected │ ├── 256.scm │ ├── add.expected │ ├── add.scm │ ├── bug-gc-bignum.expected │ ├── bug-gc-bignum.scm │ ├── callcc.expected │ ├── callcc.scm │ ├── clock.expected │ ├── clock.scm │ ├── cmp.expected │ ├── cmp.scm │ ├── cond.expected │ ├── cond.scm │ ├── constant-folding.expected │ ├── constant-folding.scm │ ├── copy-propagation.expected │ ├── copy-propagation.scm │ ├── div.expected │ ├── div.scm │ ├── duplicate-constants.expected │ ├── duplicate-constants.scm │ ├── empty.expected │ ├── empty.scm │ ├── fixnums.expected │ ├── fixnums.scm │ ├── gc-bignum-display.expected │ ├── gc-bignum-display.scm │ ├── gc.expected │ ├── gc.scm │ ├── geq-leq.expected │ ├── geq-leq.scm │ ├── globals.expected │ ├── globals.scm │ ├── higher-order-prim.expected │ ├── higher-order-prim.scm │ ├── infinite-loop.expected │ ├── infinite-loop.scm │ ├── io.expected │ ├── io.input │ ├── io.scm │ ├── ior.expected │ ├── ior.scm │ ├── lambda-mut-immut.expected │ ├── lambda-mut-immut.scm │ ├── left-left-lambda.expected │ ├── left-left-lambda.scm │ ├── letrec.expected │ ├── letrec.scm │ ├── list.expected │ ├── list.scm │ ├── loops.expected │ ├── loops.scm │ ├── mul.expected │ ├── mul.scm │ ├── named-let.expected │ ├── named-let.scm │ ├── neg.expected │ ├── neg.scm │ ├── nested-inline-eta.expected │ ├── nested-inline-eta.scm │ ├── num-display.expected │ ├── num-display.scm │ ├── pairs.expected │ ├── pairs.scm │ ├── pointers.expected │ ├── pointers.scm │ ├── procs.expected │ ├── procs.scm │ ├── rom-bignum.expected │ ├── rom-bignum.scm │ ├── set-cdr.expected │ ├── set-cdr.scm │ ├── set-global.expected │ ├── set-global.scm │ ├── shadowing.expected │ ├── shadowing.scm │ ├── string.expected │ ├── string.scm │ ├── sub.expected │ ├── sub.scm │ ├── substring.expected │ ├── substring.scm │ ├── symbolp.expected │ ├── symbolp.scm │ ├── u8-copy.expected │ ├── u8-copy.scm │ ├── u8-gc-compact.expected │ ├── u8-gc-compact.scm │ ├── u8-gc.expected │ ├── u8-gc.scm │ ├── u8.expected │ ├── u8.scm │ ├── var-chain.expected │ ├── var-chain.scm │ ├── vector.expected │ ├── vector.scm │ ├── xor.expected │ └── xor.scm └── vm ├── .config ├── .gitignore ├── Kconfig ├── Makefile ├── arch ├── Makefile ├── arm │ ├── Kconfig │ ├── Makefile │ └── cortex-m3 │ │ ├── Kconfig │ │ ├── Makefile │ │ ├── board-vldiscovery.c │ │ ├── include │ │ ├── memory.h │ │ ├── stm32 │ │ │ ├── afio.h │ │ │ ├── bits.h │ │ │ ├── gpio.h │ │ │ ├── rcc.h │ │ │ ├── spi.h │ │ │ └── usart.h │ │ └── types.h │ │ ├── init.s │ │ ├── lib │ │ ├── common.ld │ │ └── stm32f100rb.ld │ │ └── stdlib-vldiscovery.scm └── host │ ├── Kconfig │ ├── Makefile │ ├── entry.c │ ├── include │ ├── memory.h │ └── types.h │ ├── primitives.c │ └── stdlib.scm ├── core ├── .gitignore ├── Kconfig ├── Makefile ├── bignum_fixed.c ├── bignum_long.c ├── debug.c ├── dispatch.c ├── gc.c ├── heap.c ├── primitives-control.c ├── primitives-list.c ├── primitives-numeric.c ├── primitives-util.c └── primitives-vector.c ├── include ├── .gitignore ├── bignum.h ├── debug.h ├── dispatch.h ├── gc.h ├── heap.h ├── object.h ├── picobit.h └── primitives.h ├── kconfig ├── .gitignore ├── Makefile ├── conf.c ├── confdata.c ├── expr.c ├── expr.h ├── lex.backup ├── lex.zconf.c_shipped ├── lkc.h ├── lkc_proto.h ├── menu.c ├── nconf.c ├── nconf.gui.c ├── nconf.h ├── symbol.c ├── util.c ├── zconf.gperf ├── zconf.hash.c_shipped ├── zconf.l ├── zconf.tab.c_shipped └── zconf.y └── scripts ├── prim-dispatchgen.awk ├── prim-headergen.awk ├── prim-schemegen.awk └── scanner.awk /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.hex 3 | *~ 4 | TAGS 5 | picobit-vm 6 | compiled/ 7 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: compiler vm 2 | 3 | # compiler can always be run, raco make will figure the rest out 4 | .PHONY: compiler vm 5 | 6 | compiler: vm 7 | raco make compiler/picobit.rkt 8 | 9 | vm: 10 | cd vm && make 11 | [ -e vm/picobit-vm ] && cp vm/picobit-vm . || rm -f picobit-vm 12 | 13 | clean: 14 | cd vm && make clean 15 | 16 | test: compiler vm 17 | raco make tests/run-tests.rkt 18 | racket tests/run-tests.rkt 19 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is a very small Scheme system designed to run on small 2 | microcontrollers, currently PIC18 and ARM. 3 | 4 | It consists of 5 | 6 | * a bytecode compiler which compiles Scheme source code to bytecode. 7 | The bytecode compiler is run using Racket, usually on a 8 | PC/workstation. 9 | 10 | * a bytecode interpreter which can be either compiled to run on a 11 | microcontroller, or to be run on some common operating systems, at 12 | least GNU/Linux (Windows support hasn't been tested in a while, 13 | though, and especially the networking part might not work out of the 14 | box). It is written in (mostly) portable C. 15 | 16 | 17 | USAGE: 18 | 19 | 1. Install Racket (needed to run the bytecode compiler) 20 | racket-lang.org 21 | 22 | 2. Build the VM: 23 | make 24 | This will build the VM with the default configuration (workstation, 25 | no deubgging). To configure the VM for another architecture, or with 26 | different options, run 27 | make help 28 | from the `vm' directory. 29 | 30 | Note: gawk is required to build the VM. 31 | 32 | 2. Compile a Scheme program: 33 | ./picobit prog.scm 34 | 35 | 3. Run the resulting program: 36 | ./picobit-vm prog.hex 37 | 38 | Note: The `p' script is a shortcut for compiling and running programs: 39 | ./p prog.scm 40 | is equivalent to 41 | ./picobit prog.scm ; ./picobit-vm prog.hex 42 | 43 | 44 | SEE ALSO: 45 | 46 | * A paper describing PICOBIT has been presented to IFL 2009: 47 | http://www.ccs.neu.edu/home/stamourv/papers/picobit.pdf 48 | Slides from the presentation: 49 | http://www.ccs.neu.edu/home/stamourv/slides/picobit-ifl09.pdf 50 | 51 | * S3 (Small Scheme Stack) : A Scheme TCP/IP Stack Targeting Small 52 | Embedded Applications 53 | http://www.ccs.neu.edu/home/stamourv/papers/s3.pdf 54 | Slides from the presentation: 55 | http://www.ccs.neu.edu/home/stamourv/slides/s3-sw08.pdf 56 | 57 | PICOBIT is a descendant of the BIT and PICBIT systems. You can find 58 | papers describing these systems at: 59 | http://w3.ift.ulaval.ca/~dadub100/ 60 | 61 | 62 | HISTORY: 63 | 64 | Marc Feeley originally wrote PICOBIT around 2006. 65 | Vincent St-Amour took over development in 2008. 66 | Jim Shargo worked on a port to Racket in 2011. 67 | The Racket port was completed in June 2011. 68 | Peter Zotov (whitequark) ported PICOBIT to ARM in August 2011. 69 | 70 | LICENCE: 71 | 72 | PICOBIT is released under the GPLv3. 73 | -------------------------------------------------------------------------------- /compiler/.gitignore: -------------------------------------------------------------------------------- 1 | gen.* 2 | -------------------------------------------------------------------------------- /compiler/analysis.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "utilities.rkt" "env.rkt" "ast.rkt" "primitives.rkt") 4 | 5 | ;;----------------------------------------------------------------------------- 6 | 7 | (provide mark-needed-global-vars!) 8 | 9 | (define (mark-var! var) 10 | (when (and (var-global? var) 11 | (not (var-needed? var)) 12 | ;; globals that obey the following condition are considered 13 | ;; to be constants 14 | ;; below fails if no definition (e.g. primitives), or mutable 15 | (not (cst? (var-val var)))) 16 | (set-var-needed?! var #t) 17 | (let ([val (var-val var)]) 18 | (when (and val (side-effect-less? val)) 19 | (mark-needed-global-vars! val))))) 20 | 21 | (define (mark-needed-global-vars! node) 22 | (match node 23 | [(ref _ '() var) 24 | (mark-var! var)] 25 | [(def _ `(,val) _) 26 | (when (not (side-effect-less? val)) 27 | (mark-needed-global-vars! val))] 28 | [(or (? cst? node) (? set? node) (? if*? node) (? prc? node) 29 | (? call? node) (? seq? node)) 30 | (for-each mark-needed-global-vars! (node-children node))] 31 | [_ 32 | (compiler-error "unknown expression type" node)])) 33 | 34 | ;;----------------------------------------------------------------------------- 35 | 36 | (provide needs-closure?) 37 | 38 | (define (toplevel-prc? var) 39 | ;; Since we don't have internal defines, the only way a variable can have 40 | ;; a val is to be defined at the toplevel. Otherwise, it would be lambda 41 | ;; -bound, in which case it has no val. 42 | (let ([val (var-val var)]) ; non-false implies immutable 43 | (and (prc? val) 44 | val))) 45 | 46 | ;; A lambda needs a closure if it has rest args, or if forced to because of 47 | ;; how one of its references uses it. 48 | (define (needs-closure? var) 49 | (let ([prc (toplevel-prc? var)]) 50 | (and prc 51 | (not (prc-rest? prc)) 52 | (andmap (lambda (r) 53 | (let ([parent (node-parent r)]) 54 | (and (call? parent) 55 | (eq? (child1 parent) r) 56 | (= (length (prc-params prc)) 57 | (- (length (node-children parent)) 1))))) 58 | ;; may point to refs that are not in the program anymore 59 | ;; this makes the analysis conservative, so we're safe 60 | (var-refs var)) 61 | prc))) 62 | 63 | ;;----------------------------------------------------------------------------- 64 | 65 | (provide side-effect-less? side-effect-oblivious?) 66 | 67 | ;; oblivious? is true if we want to check for side-effect obliviousless, which 68 | ;; is stronger 69 | (define (side-effect-less? node [oblivious? #f] [seen '()]) 70 | (and (or (cst? node) (prc? node) ; values 71 | ;; mutable var references are side-effect-less, but not oblivious 72 | (and (ref? node) 73 | (not (and oblivious? (mutable-var? (ref-var node))))) 74 | (and (or (seq? node) (if*? node)) 75 | (for/and ([c (in-list (node-children node))]) 76 | (side-effect-less? c oblivious? seen))) 77 | (and (call? node) 78 | (for/and ([c (in-list (cdr (node-children node)))]) ; args 79 | (side-effect-less? c oblivious? seen)) 80 | (let ([op (car (node-children node))]) 81 | (cond [(prc? op) 82 | (side-effect-less? oblivious? (child1 op))] ; body 83 | [(ref? op) 84 | (or (let* ([var (ref-var op)] 85 | [prim (var-primitive var)]) 86 | ;; has a folder implies side-effect-less? 87 | (and prim (primitive-constant-folder prim) 88 | ;; for obliviousness, we also need it not to 89 | ;; access mutable state 90 | (if oblivious? 91 | (not (memf (lambda (x) (var=? x var)) 92 | mutable-data-accessors)) 93 | #t))) 94 | (let* ([var (ref-var op)] 95 | [val (var-val var)]) ; non-false -> immutable 96 | ;; refers to a side-effect-less? proc 97 | ;; to avoid non-termination, we reject recursive funs 98 | ;; Note: we could chase references further. 99 | ;; we currently refet a ref to a ref of a 100 | ;; side-effect-less? proc 101 | (and (prc? val) 102 | (not (for/or ([s (in-list seen)]) (var=? s var))) 103 | (side-effect-less? (child1 val) ; body 104 | oblivious? 105 | (cons var seen)))))])))))) 106 | ;; could look into if*, seq, etc in operator position, making sure it refers to 107 | ;; a side-effect-less? proc (refs encountered during that are not automatically 108 | ;; ok) 109 | 110 | ;; The result of this expression does not depend on other side effects. 111 | ;; Implies: side-effect-less? 112 | ;; Corollary: this expression can be moved. 113 | (define (side-effect-oblivious? node) 114 | (side-effect-less? node #t)) 115 | 116 | ;;----------------------------------------------------------------------------- 117 | 118 | ;; Free variable analysis. 119 | 120 | (provide global-fv 121 | non-global-fv 122 | fv) 123 | 124 | (require (except-in racket/set 125 | set? set)) ; to avoid collision with the node type 126 | 127 | ;; varsets are eq? sets 128 | 129 | (define (build-params-varset params) 130 | (list->seteq params)) 131 | 132 | ;; These two are for outside consumption, so they return results as lists. 133 | (define (global-fv node) 134 | (filter var-global? 135 | (set->list (fv node)))) 136 | (define (non-global-fv node) 137 | (filter (lambda (x) (not (var-global? x))) 138 | (set->list (fv node)))) 139 | 140 | (define (fv node) 141 | (match node 142 | [(? cst? node) 143 | (seteq)] ; empty varset 144 | [(ref _ '() var) 145 | (seteq var)] ; singleton varset 146 | [(def _ `(,val) var) 147 | (set-add (fv val) var)] 148 | [(set _ `(,val) var) 149 | (set-add (fv val) var)] 150 | [(prc _ `(,body) params _ _) 151 | (set-subtract 152 | (fv body) 153 | (build-params-varset params))] 154 | [(or (? if*? node) (? call? node) (? seq? node)) 155 | (apply set-union (map fv (node-children node)))] 156 | [_ 157 | (compiler-error "unknown expression type" node)])) 158 | -------------------------------------------------------------------------------- /compiler/ast.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | (require syntax/parse unstable/match racket/syntax) 5 | (require "utilities.rkt" "env.rkt") 6 | 7 | ;; Syntax-tree node representation. 8 | 9 | ;; The AST is doubly linked, children point to their parent. This makes it 10 | ;; possible to crawl the tree backwards, which is useful for some analysis 11 | ;; and transformations. 12 | 13 | ;; In addition, variable objects are doubly linked as well. Defs, refs, sets 14 | ;; and prcs point to the variables involved, and the variables point back to 15 | ;; their definition, references and assignments. Again, this makes analysis 16 | ;; and transformations easier. 17 | 18 | ;; Important invariant: No node sharing. 19 | ;; If we create identical nodes, or copy an existing node, the results 20 | ;; must _not_ be eq?. 21 | ;; Otherwise, this may screw up accounting (e.g. for refs) or cycle 22 | ;; detection in analysis, etc. 23 | 24 | (define-struct node (parent children) #:mutable #:transparent) 25 | 26 | (define (child1 node) (car (node-children node))) 27 | 28 | (define (immutable-var? var) (null? (var-sets var))) 29 | (define (mutable-var? var) (not (immutable-var? var))) 30 | 31 | ;; If v is defined, return the node corresponding to its value. 32 | ;; Returns #f if something goes wrong. 33 | (define (var-val v) 34 | (define def (var-def v)) 35 | (and (immutable-var? v) 36 | def 37 | (not (prc? def)) ; var defined in a lambda, no fixed value 38 | (child1 def))) ; rhs of a define 39 | 40 | 41 | (define-struct (cst node) (val)) 42 | (define-struct (ref node) (var)) 43 | (define-struct (def node) (var)) ; children: (rhs) 44 | (define-struct (set node) (var)) ; children: (rhs) 45 | (define-struct (if* node) ()) ; children: (test then else) 46 | (define-struct (prc node) ; children: (body) 47 | ((params #:mutable) ; listof var? 48 | rest? 49 | (entry-label #:mutable))) 50 | (define-struct (call node) ()) ; children: (op . args) 51 | (define-struct (seq node) ()) ; children: (body ...) 52 | 53 | 54 | ;; parsing helpers 55 | (define (extract-ids pattern) 56 | (syntax->list 57 | (syntax-parse pattern 58 | [(x:identifier ...) #'(x ...)] 59 | [(x:identifier ... . y:identifier) #'(x ... y)]))) 60 | (define (has-rest-param? pattern) 61 | (syntax-parse pattern 62 | [(x:identifier ...) #f] 63 | [(x:identifier ... . y:identifier) #t])) 64 | 65 | 66 | ;; AST construction helpers 67 | 68 | (define (create-ref v) 69 | (define r (make-ref #f '() v)) ; parent needs to be set by caller 70 | (set-var-refs! v (cons r (var-refs v))) 71 | r) 72 | ;; Needs to be called every time we remove a ref from the AST to avoid 73 | ;; dangling references which hurt analysis precision. 74 | (define (discard-ref r) 75 | (define var (ref-var r)) 76 | (define refs (var-refs var)) 77 | (unless (memq r refs) 78 | (compiler-error "discard-ref: ref is not in the variable's refs" 79 | (var-id var))) 80 | (set-var-refs! var (remq r refs))) 81 | (define (discard-set s) 82 | (define var (set-var s)) 83 | (define sets (var-sets var)) 84 | (unless (memq s sets) 85 | (compiler-error "discard-set: set is not in the variable's sets" 86 | (var-id var))) 87 | (set-var-sets! var (remq s sets))) 88 | 89 | ;; Crawls e and discards any refs, and sets it encounters, so that e can 90 | ;; be dropped without leaving dangling references. 91 | (define (discard-node! e parent) 92 | (when (memq e (node-children (node-parent e))) 93 | (error "discard-node!: can't discard a node that's still attached" 94 | (node->expr e))) 95 | (set-node-parent! e #f) 96 | (when (ref? e) (discard-ref e)) 97 | (when (set? e) (discard-set e)) 98 | (define cs (node-children e)) 99 | (set-node-children! e '()) ; detach children, so they can be discarded too 100 | (for ([c (in-list cs)]) (discard-node! c e))) 101 | 102 | (define (create-prc children params rest?) 103 | (make-prc #f children params rest? 104 | #f)) ; entry-label, will be filled later 105 | 106 | 107 | (define (fix-children-parent! p) 108 | (for-each (lambda (x) (set-node-parent! x p)) (node-children p))) 109 | 110 | ;; Note: if new is a descendant of old, it needs to be copied before begin 111 | ;; substituted in. This is because we discard old and all its descendants. 112 | (define (substitute-child! parent old new) 113 | (define children (node-children parent)) 114 | (unless (memq old children) 115 | (compiler-error "substitute-child!: old is not in children" 116 | (node->expr old))) 117 | (set-node-parent! new parent) 118 | (set-node-children! parent (map (lambda (x) (if (eq? x old) new x)) 119 | children)) 120 | (discard-node! old parent)) 121 | 122 | ;; Is c a descendant of p? 123 | (define (inside? c p) 124 | (or (eq? c p) 125 | (and c ; not at the top of the program 126 | (inside? (node-parent c) p)))) 127 | 128 | ;; Splice the child begin inside the parent begin in place of the old node. 129 | (define (splice-begin! old child parent) 130 | (set-node-children! 131 | parent 132 | (apply append 133 | (for/list ([c (node-children parent)]) 134 | (if (eq? c old) ; we replace that 135 | (node-children child) 136 | (list c))))) ; keep that one 137 | (fix-children-parent! parent)) 138 | 139 | 140 | ;; Since nodes know their parents, we can't just reuse them directly. 141 | ;; For this reason, this is a deep copy. 142 | ;; Optionally takes a list of variable substitutions. When we copy lambdas, 143 | ;; we need to create new var objects, otherwise the copy's variables will be 144 | ;; the same as the original's. 145 | (define (copy-node e [substs '()]) ; substs : (listof (pair var var)) 146 | (define (maybe-substitute-var var) 147 | (cond [(assoc var substs var=?) => cdr] 148 | [else var])) 149 | (define new 150 | (match e 151 | ;; parent is left #f, caller must set it 152 | ;; children are copied below 153 | [(cst _ _ val) ; no need to copy val 154 | (make-cst #f '() val)] 155 | [(ref _ _ var) ; we may need to substitute 156 | (create-ref (maybe-substitute-var var))] ; registers the reference 157 | [(def _ _ var) ; only at the top-level, makes no sense to copy 158 | (compiler-error "copying the definition of" (var-id var))] 159 | [(set _ _ var) ; as above 160 | (define res (make-set #f '() (maybe-substitute-var var))) 161 | (set-var-sets! var (cons res (var-sets var))) 162 | res] 163 | [(if* _ _) 164 | (make-if* #f '())] 165 | [(prc _ _ params rest? entry) 166 | (define new (make-prc #f '() '() rest? entry)) 167 | ;; we need to create new parameters, and replace the old ones in body 168 | ;; Note: with Racket identifiers being used for variables, we'll need 169 | ;; to freshen the new vars, otherwise the new ones will be 170 | ;; free-identifier=? with the old ones, and we don't want that! 171 | (define (copy-var v) 172 | (make-local-var (generate-temporary (var-id v)) new)) 173 | (define new-params (map copy-var params)) 174 | (set-prc-params! new new-params) 175 | new] 176 | [(call _ _) 177 | (make-call #f '())] 178 | [(seq _ _) 179 | (make-seq #f '())])) 180 | ;; If we're copying a lambda, we need to substitute the new one's params 181 | ;; for the original's 182 | (define new-substs 183 | (if (prc? new) 184 | (append (map cons (prc-params e) (prc-params new)) 185 | substs) 186 | substs)) 187 | (set-node-children! new (for/list ([c (in-list (node-children e))]) 188 | (copy-node c new-substs))) 189 | (fix-children-parent! new) 190 | new) 191 | 192 | 193 | ;; Pretty-printer, mostly for debugging 194 | 195 | (provide node->expr) 196 | 197 | (define (node->expr node) 198 | (match node 199 | [(cst _ '() val) 200 | (if (self-eval? val) 201 | val 202 | (list 'quote val))] 203 | [(ref _ '() var) 204 | (var-bare-id var)] 205 | [(def _ `(,rhs) var) 206 | (list 'define (var-bare-id var) (node->expr rhs))] 207 | [(set _ `(,rhs) var) 208 | (list 'set! (var-bare-id var) (node->expr rhs))] 209 | [(if* _ `(,tst ,thn ,els)) 210 | (list 'if (node->expr tst) (node->expr thn) (node->expr els))] 211 | [(prc _ `(,body) params rest? _) 212 | (define (build-pattern params rest?) 213 | (cond [(null? params) 214 | '()] 215 | [(null? (cdr params)) 216 | (if rest? 217 | (var-bare-id (car params)) 218 | (list (var-bare-id (car params))))] 219 | [else 220 | (cons (var-bare-id (car params)) 221 | (build-pattern (cdr params) rest?))])) 222 | `(lambda ,(build-pattern params rest?) 223 | ,(node->expr body))] 224 | [(call _ children) 225 | (map node->expr children)] 226 | [(seq _ children) 227 | (cons 'begin (map node->expr children))] 228 | [_ 229 | (compiler-error "unknown expression type" node)])) 230 | -------------------------------------------------------------------------------- /compiler/back-end.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "ir.rkt" "ast.rkt") 4 | 5 | ;; Back-end utilities. 6 | 7 | ;;----------------------------------------------------------------------------- 8 | 9 | (provide renumber-labels) 10 | 11 | (define (renumber-labels bbs ref-counts n) 12 | 13 | (define (fix instr) 14 | (define (make-new-label label) 15 | (bb-label (vector-ref bbs label))) 16 | (match instr 17 | [`(,(and opcode (or 'closure 'call-toplevel 'jump-toplevel 'goto)) ,arg) 18 | (list opcode (make-new-label arg))] 19 | [`(goto-if-false ,a1 ,a2) 20 | (list 'goto-if-false (make-new-label a1) (make-new-label a2))] 21 | [_ instr])) 22 | 23 | (let ([new-bbs (make-vector n)]) 24 | (for ([(b label) (in-indexed bbs)] 25 | #:when (> (vector-ref ref-counts label) 0)) 26 | (match b 27 | [(bb new-label rev-instrs) 28 | (vector-set! new-bbs new-label 29 | (make-bb new-label (map fix rev-instrs)))])) 30 | new-bbs)) 31 | 32 | ;;----------------------------------------------------------------------------- 33 | 34 | (provide code->vector) 35 | 36 | (define (code->vector code) 37 | (let ([v (make-vector (+ (code-last-label code) 1))]) 38 | (for ([bb (in-list (code-rev-bbs code))]) 39 | (vector-set! v (bb-label bb) bb)) 40 | v)) 41 | 42 | ;;----------------------------------------------------------------------------- 43 | 44 | (provide resolve-toplevel-labels!) 45 | 46 | (define (resolve-toplevel-labels! bbs) 47 | (for ([i (in-range (vector-length bbs))]) 48 | (let* ([bb (vector-ref bbs i)] 49 | [rev-instrs (bb-rev-instrs bb)]) 50 | (set-bb-rev-instrs! 51 | bb 52 | (map (match-lambda 53 | [`(,(and opcode (or 'call-toplevel 'jump-toplevel)) ,arg) 54 | `(,opcode ,(prc-entry-label arg))] 55 | [instr 56 | instr]) 57 | rev-instrs))))) 58 | -------------------------------------------------------------------------------- /compiler/code-gen.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | (require "ir.rkt") 5 | 6 | ;; Code generation utilities. 7 | ;; Each of these adds an IR instruction to the code stream. 8 | 9 | (define (gen-instruction instr nb-pop nb-push ctx) 10 | (let* ([env (context-env ctx)] 11 | [stk (stack-extend #f 12 | nb-push 13 | (stack-discard nb-pop (env-local env)))]) 14 | (context-add-instr (context-change-env ctx (env-change-local env stk)) 15 | instr))) 16 | 17 | (define (gen-entry nparams rest? ctx) 18 | (gen-instruction `(entry ,nparams ,rest?) 0 0 ctx)) 19 | 20 | (define (gen-push-constant val ctx) 21 | (gen-instruction `(push-constant ,val) 0 1 ctx)) 22 | 23 | (define (gen-push-unspecified ctx) 24 | (gen-push-constant #f ctx)) 25 | 26 | (define (gen-push-local-var var ctx) 27 | (let ([i (find-local-var var (context-env ctx))]) 28 | (if (>= i 0) 29 | (gen-push-stack i ctx) 30 | (gen-push-stack ; in the closed env, past the local variables 31 | (+ (- -1 i) 32 | (length (stack-slots (env-local (context-env ctx))))) ctx)))) 33 | 34 | (define (gen-push-stack pos ctx) 35 | (gen-instruction `(push-stack ,pos) 0 1 ctx)) 36 | 37 | (define (gen-push-global var ctx) 38 | (gen-instruction `(push-global ,var) 0 1 ctx)) 39 | 40 | (define (gen-set-global var ctx) 41 | (gen-instruction `(set-global ,var) 1 0 ctx)) 42 | 43 | (define (gen-call nargs ctx) 44 | (gen-instruction `(call ,nargs) (+ nargs 1) 1 ctx)) 45 | 46 | (define (gen-jump nargs ctx) 47 | (gen-instruction `(jump ,nargs) (+ nargs 1) 1 ctx)) 48 | 49 | (define (gen-call-toplevel nargs id ctx) 50 | (gen-instruction `(call-toplevel ,id) nargs 1 ctx)) 51 | 52 | (define (gen-jump-toplevel nargs id ctx) 53 | (gen-instruction `(jump-toplevel ,id) nargs 1 ctx)) 54 | 55 | (define (gen-goto label ctx) 56 | (gen-instruction `(goto ,label) 0 0 ctx)) 57 | 58 | (define (gen-goto-if-false label-false label-true ctx) 59 | (gen-instruction `(goto-if-false ,label-false ,label-true) 1 0 ctx)) 60 | 61 | (define (gen-closure label-entry ctx) 62 | (gen-instruction `(closure ,label-entry) 1 1 ctx)) 63 | 64 | (define (gen-prim id nargs unspec-result? ctx) 65 | (gen-instruction `(prim ,id) 66 | nargs 67 | (if unspec-result? 0 1) 68 | ctx)) 69 | 70 | (define (gen-pop ctx) 71 | (gen-instruction '(pop) 1 0 ctx)) 72 | 73 | (define (gen-return ctx) 74 | (let ([ss (stack-size (env-local (context-env ctx)))]) 75 | (gen-instruction '(return) ss 0 ctx))) 76 | -------------------------------------------------------------------------------- /compiler/env.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | (require racket/mpair) 5 | (require "utilities.rkt") 6 | 7 | ;; Environment representation. 8 | 9 | (define global-env (mlist)) 10 | (define (set-global-env! e) (set! global-env e)) ; for primitive generation 11 | 12 | (define-struct var 13 | (id ; identifier? 14 | global? 15 | (refs #:mutable) 16 | (sets #:mutable) 17 | (def #:mutable) ; #f or node 18 | (needed? #:mutable) 19 | primitive) 20 | #:transparent) 21 | 22 | (define-struct primitive 23 | (nargs 24 | (constant-folder #:mutable) ; added post-creation 25 | (eta-expansion #:mutable) ; for higher-order uses 26 | unspecified-result?) 27 | #:transparent) 28 | 29 | (define/contract (make-primitive-var id prim) 30 | (identifier? primitive? . -> . var?) 31 | (make-var id #t '() '() #f #f prim)) 32 | (define/contract (make-global-var id def) 33 | (identifier? any/c . -> . var?) 34 | (make-var id #t '() '() def #f #f)) 35 | (define/contract (make-local-var id def) 36 | (identifier? any/c . -> . var?) 37 | (make-var id #f '() '() def #f #f)) 38 | 39 | (define (var-bare-id v) (syntax->datum (var-id v))) ; for code-generation 40 | 41 | ;; Once we plug in Racket's expander, we'll be able to do better. 42 | (define (var=? x y) 43 | (and (id=? (var-id x) (var-id y)) ; same symbol 44 | (eq? (var-def x) (var-def y)))) ; defined in the same place 45 | (define (id=? x y) (eq? (syntax->datum x) (syntax->datum y))) 46 | 47 | 48 | (define allow-forward-references? (make-parameter #t)) 49 | 50 | (define/contract (env-lookup env id) ((mlistof var?) identifier? . -> . var?) 51 | (or (for/first ([b (in-mlist env)] 52 | #:when (id=? (var-id b) id)) 53 | b) 54 | ;; We didn't find it. If reasonable to do so, add it to the env. 55 | ;; This makes it possible to have forward references at the top level. 56 | (let ([x (make-var id #t '() '() #f #f #f)]) 57 | (unless (allow-forward-references?) 58 | (compiler-error "variable referenced before its definition:" id)) 59 | (mappend! env (mlist x)) 60 | x))) 61 | 62 | (define/contract (env-extend env ids def) 63 | ((mlistof var?) (listof identifier?) any/c . -> . (mlistof var?)) 64 | (mappend (list->mlist 65 | (map (lambda (id) 66 | (make-var id #f '() '() def #f #f)) 67 | ids)) 68 | env)) 69 | 70 | 71 | ;; extra code environment : list of AST nodes 72 | ;; To hold code generated by the compiler that must be compiled along with the 73 | ;; rest of the program (e.g. primitive eta-expansions). 74 | ;; All this code needs to be generated before compilation begins, and will be 75 | ;; merged with the rest of the program after parsing. 76 | (define extra-code-env '()) 77 | (define (add-extra-code c) (set! extra-code-env (cons c extra-code-env))) 78 | -------------------------------------------------------------------------------- /compiler/ir.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | (require srfi/1) 5 | (require "ast.rkt" "env.rkt") 6 | 7 | (define-struct context (code env env2) #:transparent) 8 | 9 | (define (context-change-code ctx code) 10 | (make-context code 11 | (context-env ctx) 12 | (context-env2 ctx))) 13 | 14 | (define (context-change-env ctx env) 15 | (make-context (context-code ctx) 16 | env 17 | (context-env2 ctx))) 18 | 19 | (define (context-change-env2 ctx env2) 20 | (make-context (context-code ctx) 21 | (context-env ctx) 22 | env2)) 23 | 24 | (define (make-init-context) 25 | (make-context (make-init-code) 26 | (make-init-env) 27 | #f)) 28 | 29 | (define (context-make-label ctx) 30 | (let ([r (context-change-code ctx (code-make-label (context-code ctx)))]) 31 | (values r (code-last-label (context-code r))))) 32 | 33 | (define (context-add-bb ctx label) 34 | (context-change-code ctx (code-add-bb (context-code ctx) label))) 35 | 36 | (define (context-add-instr ctx instr) 37 | (context-change-code ctx (code-add-instr (context-code ctx) instr))) 38 | 39 | ;; Representation of code. 40 | 41 | (define-struct code (last-label rev-bbs) #:transparent) 42 | 43 | (define-struct bb (label (rev-instrs #:mutable)) #:transparent) 44 | 45 | (define (make-init-code) 46 | (make-code 0 47 | (list (make-bb 0 (list))))) 48 | 49 | (define (code-make-label code) 50 | (make-code (+ (code-last-label code) 1) 51 | (code-rev-bbs code))) 52 | 53 | (define (code-add-bb code label) 54 | (make-code (code-last-label code) 55 | (cons (make-bb label '()) 56 | (code-rev-bbs code)))) 57 | 58 | (define (code-add-instr cur-code instr) 59 | (match cur-code 60 | [(code last-label `(,(bb label rev-instrs) . ,rest)) 61 | (make-code last-label 62 | (cons (make-bb label 63 | (cons instr rev-instrs)) 64 | rest))])) 65 | 66 | 67 | ;; Representation of compile-time stack. 68 | 69 | ;;; A stack is a (make-stack size slots) where: 70 | ;;; - size is the number of slots 71 | ;;; - slots is a list of variables or #f in each slot 72 | (define-struct stack (size slots) #:transparent) 73 | 74 | (define (make-init-stack) 75 | (make-stack 0 '())) 76 | 77 | (define (stack-extend x nb-slots stk) 78 | (match stk 79 | [(stack size slots) 80 | (make-stack (+ size nb-slots) 81 | (append (make-list nb-slots x) slots))])) 82 | 83 | (define (stack-discard nb-slots stk) 84 | (match stk 85 | [(stack size slots) 86 | (make-stack 87 | (- size nb-slots) 88 | (list-tail slots nb-slots))])) 89 | 90 | 91 | 92 | ;; Representation of compile-time environment. 93 | 94 | (define-struct env (local closed) #:transparent) 95 | 96 | (define (make-init-env) 97 | (make-env (make-init-stack) 98 | '())) 99 | 100 | (define (env-change-local env local) 101 | (make-env local 102 | (env-closed env))) 103 | 104 | (define (env-change-closed env closed) 105 | (make-env (env-local env) 106 | closed)) 107 | 108 | (define (find-local-var var env) 109 | (define target? (lambda (x) (eq? x var))) 110 | (or (list-index target? (stack-slots (env-local env))) 111 | (- (+ (list-index target? (env-closed env)) 1)))) 112 | -------------------------------------------------------------------------------- /compiler/parser.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide parse-program) 4 | (require "utilities.rkt" "analysis.rkt" "env.rkt" "ast.rkt") 5 | (require syntax/parse racket/syntax) 6 | 7 | (define (parse-program lst env) 8 | (define exprs 9 | (append extra-code-env 10 | (parse-top-list #`(#,@lst (#%halt)) env))) 11 | (define r (make-seq #f exprs)) 12 | (fix-children-parent! r) 13 | r) 14 | 15 | (define (parse-top-list lst env) 16 | (append-map (lambda (e) (parse-top e env)) 17 | (syntax->list lst))) 18 | 19 | ;; returns a list of parsed expressions 20 | (define (parse-top expr env) 21 | (syntax-parse expr #:literals (define lambda) 22 | ;; As in the reader, this is a hack. The Racket expander will eventually 23 | ;; take care of begin, define, etc. and spit out core forms. 24 | [(begin body ...) ; splicing begins 25 | #:when (eq? (syntax->datum #'begin) 'begin) 26 | (parse-top-list #'(body ...) env)] 27 | [(define (var params ...) body ...) 28 | (parse-define #'var #'(lambda (params ...) body ...) env)] 29 | [(define var:identifier val) 30 | (parse-define #'var #'val env 31 | ;; If we're not defining a function, forward references are 32 | ;; invalid. 33 | (syntax-parse #'val 34 | [(lambda etc ...) #t] 35 | [_ #f]))] 36 | [_ 37 | (list (parse 'value expr env))])) 38 | 39 | (define (parse-define var val env [forward-references? #t]) 40 | (let ([var2 (env-lookup env var)]) 41 | (parameterize ([allow-forward-references? forward-references?]) 42 | (let* ([val2 (parse 'value val env)] 43 | [r (make-def #f (list val2) var2)]) 44 | (fix-children-parent! r) 45 | (when (var-def var2) 46 | (compiler-error "variable redefinition forbidden" var2)) 47 | (set-var-def! var2 r) 48 | (list r))))) 49 | 50 | (define (parse use expr env [operator-position? #f]) 51 | (syntax-parse expr 52 | #:literals (set! quote if cond else => lambda letrec begin let let* and or) 53 | [expr 54 | #:when (self-eval? (syntax->datum #'expr)) 55 | (make-cst #f '() (syntax->datum #'expr))] 56 | [expr:identifier 57 | (define var 58 | (let* ([v (env-lookup env #'expr)] 59 | [prim (var-primitive v)]) 60 | (if (and prim (not operator-position?)) 61 | ;; We eta-expand any primitive used in a higher-order fashion. 62 | (primitive-eta-expansion prim) 63 | v))) 64 | (define r (create-ref var)) 65 | (if (not (var-global? var)) 66 | (let* ([unbox (parse 'value #'#%unbox env)] 67 | [app (make-call #f (list unbox r))]) 68 | (fix-children-parent! app) 69 | app) 70 | r)] 71 | [(set! lhs rhs) 72 | ;; Again, hack. 73 | (let ([var (env-lookup env #'lhs)] 74 | [val (parse 'value #'rhs env)]) 75 | (when (var-primitive var) 76 | (compiler-error "cannot mutate primitive" (var-id var))) 77 | (if (var-global? var) 78 | (let ([r (make-set #f (list val) var)]) 79 | (fix-children-parent! r) 80 | (set-var-sets! var (cons r (var-sets var))) 81 | r) 82 | (let* ([ref (create-ref var)] 83 | [bs (create-ref (env-lookup env #'#%box-set!))] 84 | [r (make-call #f `(,bs ,ref ,val))]) 85 | (fix-children-parent! r) 86 | (set-var-sets! var (cons r (var-sets var))) 87 | r)))] 88 | [(quote datum) 89 | (make-cst #f '() (syntax->datum #'datum))] 90 | [(if tst thn els ...) 91 | (let* ([a (parse 'test #'tst env)] 92 | [b (parse use #'thn env)] 93 | [c (if (null? (syntax->list #'(els ...))) 94 | (make-cst #f '() #f) 95 | (parse use (car (syntax-e #'(els ...))) env))] 96 | [r (make-if* #f (list a b c))]) 97 | (fix-children-parent! r) 98 | r)] 99 | [(cond body ...) ; should eventually be a macro 100 | (syntax-parse #'(body ...) 101 | [() 102 | (parse use #'(if #f #f) env)] 103 | [((else rhs ...)) 104 | (parse use #'(begin rhs ...) env)] 105 | [((tst => rhs) other-clauses ...) 106 | (let ([x (generate-temporary)]) 107 | (parse use 108 | #`(let ([#,x tst]) 109 | (if #,x 110 | (rhs #,x) 111 | (cond other-clauses ...))) 112 | env))] 113 | [((tst rhs ...) other-clauses ...) 114 | (parse use 115 | #'(if tst 116 | (begin rhs ...) 117 | (cond other-clauses ...)) 118 | env)])] 119 | [(lambda pattern body* ...) 120 | (let* ([ids (extract-ids #'pattern)] 121 | ;; children params rest? 122 | [r (create-prc '() #f (has-rest-param? #'pattern))] 123 | [new-env (env-extend env ids r)] 124 | [body (parse-body #'(body* ...) new-env)] 125 | [mut-vars (for*/list ([id (in-list ids)] 126 | [v (in-value (env-lookup new-env id))] 127 | #:when (mutable-var? v)) 128 | v)]) 129 | (cond [(null? mut-vars) 130 | (set-prc-params! r 131 | (map (lambda (id) (env-lookup new-env id)) 132 | ids)) 133 | (set-node-children! r (list body)) 134 | (fix-children-parent! r) 135 | r] 136 | [else 137 | (let* ([prc (create-prc (list body) mut-vars #f)] ; no rest 138 | [new-vars (map var-id mut-vars)] 139 | [tmp-env (env-extend new-env new-vars r)] 140 | [app 141 | (make-call 142 | r 143 | (cons prc 144 | (map (lambda (id) 145 | (parse 'value #`(#%box #,id) tmp-env)) 146 | new-vars)))]) 147 | ;; (lambda (a b) (set! a b)) 148 | ;; => (lambda (_a b) ((lambda (a) (box-set! a b)) (box _a))) 149 | (for-each (lambda (var) (set-var-def! var prc)) 150 | mut-vars) 151 | (fix-children-parent! app) 152 | (set-prc-params! r 153 | (map (lambda (id) (env-lookup tmp-env id)) 154 | ids)) 155 | (set-node-children! r (list app)) 156 | (fix-children-parent! prc) 157 | r)]))] 158 | [(letrec ((ks vs) ...) body ...) 159 | (parse use 160 | #'(let ([ks #f] ...) 161 | (set! ks vs) ... 162 | body ...) 163 | env)] 164 | [(begin forms ...) 165 | (let ([exprs (map (lambda (x) (parse 'value x env)) 166 | (syntax->list #'(forms ...)))]) 167 | (cond [(> (length exprs) 1) 168 | (define r (make-seq #f exprs)) 169 | (fix-children-parent! r) 170 | r] 171 | [else 172 | (car exprs)]))] 173 | [(let id:identifier ((ks vs) ...) body ...) ; named let 174 | (parse use 175 | #'(letrec ([id (lambda (ks ...) body ...)]) 176 | (id vs ...)) 177 | env)] 178 | [(let () body ...) 179 | (parse use #'(begin body ...) env)] 180 | [(let ((ks vs) ...) body ...) 181 | (parse use #'((lambda (ks ...) body ...) vs ...) env)] 182 | [(let* () body ...) ; base case for let* 183 | (parse use #'(let () body ...) env)] 184 | [(let* ((k v) bindings ...) body ...) 185 | (parse use 186 | #'(let ([k v]) 187 | (let* (bindings ...) 188 | body ...)) 189 | env)] 190 | [(and) 191 | (parse use #'#t env)] 192 | [(and tst) 193 | (parse use #'tst env)] 194 | [(and tst rest ...) 195 | (parse use #'(if tst (and rest ...) #f) env)] 196 | [(or) ; base case for or 197 | (parse use #'#f env)] 198 | [(or tst) 199 | (parse use #'tst env)] 200 | [(or tst rest ...) 201 | (if (eq? use 'test) 202 | ;; we don't need to keep the actual result, we only care about 203 | ;; its "truthiness" 204 | (parse use #'(if tst #t (or rest ...)) env) 205 | (parse use 206 | (let ([v (generate-temporary)]) 207 | #`(let ([#,v tst]) 208 | (if #,v #,v (or rest ...)))) 209 | env))] 210 | [(op args ...) 211 | #:when (memq (syntax->datum #'op) 212 | '(quote quasiquote unquote unquote-splicing lambda if set! 213 | cond and or case let let* letrec begin do define delay)) 214 | (compiler-error "the compiler does not implement the special form" 215 | (syntax->datum #'op))] 216 | [(op args ...) ; call 217 | (define exprs 218 | (cons (parse 'value #'op env #t) ; in operator position 219 | (map (lambda (e) (parse 'value e env)) 220 | (syntax->list #'(args ...))))) 221 | (define r (make-call #f exprs)) 222 | (fix-children-parent! r) 223 | r] 224 | [_ 225 | (compiler-error "unknown expression" expr)])) 226 | 227 | (define (parse-body exprs env) 228 | (parse 'value #`(begin #,@exprs) env)) 229 | -------------------------------------------------------------------------------- /compiler/picobit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "utilities.rkt" 4 | "ast.rkt" 5 | "env.rkt" 6 | "reader.rkt" 7 | "parser.rkt" 8 | "front-end.rkt" 9 | "ir.rkt" 10 | "comp.rkt" 11 | "back-end.rkt" 12 | "assembler.rkt" 13 | "analysis.rkt" 14 | "scheduling.rkt" 15 | "tree-shaker.rkt") 16 | (require racket/pretty) 17 | 18 | ;;----------------------------------------------------------------------------- 19 | 20 | (define (compile in-port out-port-thunk) 21 | (let* ([forms (read-program in-port)] 22 | [node (parse-program forms global-env)]) 23 | (when (show-parsed?) 24 | (pretty-print (node->expr node))) 25 | (adjust-unmutable-references! node) 26 | ;; done first to expose more left-left-lambdas, help constant folding, etc. 27 | (copy-propagate! node) 28 | (inline-left-left-lambda! node) ; gives constant folding more to do 29 | (inline-calls-to-calls! node) ; same 30 | (copy-propagate! node) ; same 31 | (constant-fold! node) 32 | (copy-propagate! node) ; again, for cleanup 33 | ;; analysis needed by the back-end 34 | (mark-needed-global-vars! node) 35 | (when (show-post-front-end?) 36 | (pretty-print (node->expr node))) 37 | (let* ([ctx (comp-none node (make-init-context))] 38 | [code (context-code ctx)] 39 | [bbs (code->vector code)]) 40 | (resolve-toplevel-labels! bbs) 41 | (let ([prog (schedule (tree-shake! bbs))]) 42 | (when (show-asm?) 43 | (pretty-print prog)) 44 | ;; output port is in a thunk to avoid creating result 45 | ;; files if compilation fails 46 | (let ([size (assemble prog (out-port-thunk))]) 47 | (when (show-size?) 48 | (printf "~a bytes\n" size))))))) 49 | 50 | (define output-file-gen 51 | (make-parameter 52 | (lambda (in) 53 | (let ([hex-filename (path-replace-suffix in ".hex")]) 54 | ;; r5rs's with-output-to-file (in asm.rkt) can't overwrite. bleh 55 | (when (file-exists? hex-filename) 56 | (delete-file hex-filename)) 57 | hex-filename)))) 58 | 59 | (command-line 60 | #:once-each 61 | [("--size") 62 | "Display the size of the generated bytecode." 63 | (show-size? #t)] 64 | [("--parse") 65 | "Display post-parsing representation of the program." 66 | (show-parsed? #t)] 67 | [("--front") 68 | "Display post-front-end representation of the program." 69 | (show-post-front-end? #t)] 70 | [("-S" "--asm") 71 | "Display generated bytecode pre-assembly." 72 | (show-asm? #t)] 73 | [("--stats") 74 | "Display statistics about generated instructions." 75 | (stats? #t)] 76 | [("-o") out 77 | "Place the output into the given file." 78 | (output-file-gen (lambda (in) out))] 79 | #:args (filename) 80 | (void 81 | (if (equal? filename "-") 82 | ;; read input from stdin, produce code on stdout 83 | (compile 84 | (current-input-port) 85 | (lambda () (current-output-port))) 86 | (compile 87 | (open-input-file filename) 88 | (lambda () (open-output-file ((output-file-gen) filename))))))) 89 | -------------------------------------------------------------------------------- /compiler/primitives.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/mpair unstable/sequence racket/syntax) 4 | (require srfi/4) 5 | (require "env.rkt" "ast.rkt") ; to build the eta-expansions 6 | 7 | ;;----------------------------------------------------------------------------- 8 | 9 | (provide primitive-encodings) 10 | (define primitive-encodings '()) 11 | 12 | 13 | (define-syntax define-primitive 14 | (syntax-rules () 15 | [(define-primitive name nargs encoding) 16 | (define-primitive name nargs encoding #:uns-res? #f)] 17 | [(define-primitive name nargs encoding #:unspecified-result) 18 | (define-primitive name nargs encoding #:uns-res? #t)] 19 | [(define-primitive name nargs encoding #:uns-res? uns?) 20 | (let* ([prim (make-primitive nargs #f #f uns?)] 21 | [var (make-primitive-var #'name prim)]) 22 | ;; eta-expansion, for higher-order uses 23 | (set-primitive-eta-expansion! prim (create-eta-expansion var nargs)) 24 | ;; we need to set env directly, since we create the variables ourselves 25 | (set-global-env! (mcons var global-env)) 26 | (set! primitive-encodings 27 | (dict-set primitive-encodings 'name encoding)))])) 28 | 29 | (define (create-eta-expansion prim-var nargs) 30 | ;; We create AST nodes directly. Looks a lot like the parsing of lambdas. 31 | (define r (create-prc '() '() #f)) ; children params rest? 32 | (define ids (build-list nargs (lambda (x) (generate-temporary)))) 33 | (define new-env (env-extend global-env ids r)) 34 | (define args (for/list ([id (in-list ids)]) (env-lookup new-env id))) 35 | (define op (create-ref prim-var)) 36 | (define call (make-call #f (cons op (map create-ref args)))) 37 | (fix-children-parent! call) 38 | (set-prc-params! r args) 39 | (set-node-children! r (list call)) 40 | ;; hidden. you need to know it to get it 41 | (define eta-id (generate-temporary (var-id prim-var))) 42 | (define eta-var (make-global-var eta-id #f)) 43 | (define def (make-def #f (list r) eta-var)) 44 | (fix-children-parent! def) 45 | (set-var-def! eta-var def) 46 | (add-extra-code def) 47 | eta-var) 48 | 49 | (include "gen.primitives.rkt") 50 | 51 | 52 | ;; Since constant folding is a compiler-only concept, it doesn't make 53 | ;; much sense to add folders to primitives in the VM, where primitives 54 | ;; are defined. 55 | ;; Instead, we add the constant folders post-facto. This requires that 56 | ;; the foldable primitives actually be defined, though. Since folding 57 | ;; is used for "essential" primitives, that shouldn't be an issue. 58 | 59 | (define (add-constant-folder name folder) 60 | (define prim (var-primitive (env-lookup global-env name))) 61 | (set-primitive-constant-folder! prim folder)) 62 | 63 | (define folders 64 | `((,#'number? . ,number?) 65 | (,#'#%+ . ,+) 66 | (,#'#%- . ,-) 67 | (,#'#%mul-non-neg . ,*) 68 | (,#'#%div-non-neg . ,quotient) 69 | (,#'#%rem-non-neg . ,remainder) 70 | (,#'= . ,=) 71 | (,#'< . ,<) 72 | (,#'> . ,>) 73 | (,#'pair? . ,pair?) 74 | (,#'car . ,car) 75 | (,#'cdr . ,cdr) 76 | (,#'null? . ,null?) 77 | (,#'eq? . ,eq?) 78 | (,#'not . ,not) 79 | (,#'symbol? . ,symbol?) 80 | (,#'string? . ,string?) 81 | (,#'string->list . ,string->list) 82 | (,#'list->string . ,list->string) 83 | (,#'u8vector-ref . ,u8vector-ref) 84 | (,#'u8vector? . ,u8vector?) 85 | (,#'u8vector-length . ,u8vector-length) 86 | (,#'boolean? . ,boolean?) 87 | (,#'bitwise-ior . ,bitwise-ior) 88 | (,#'bitwise-xor . ,bitwise-xor))) 89 | 90 | (for ([(name folder) (in-pairs folders)]) 91 | (add-constant-folder name folder)) 92 | 93 | 94 | (provide mutable-data-accessors) 95 | ;; Some primitives that can be constant-folded away may not be 96 | ;; side-effect-oblivious. For instance, car and cdr are side-effect-less?, 97 | ;; but they can't always be moved since their behavior depends on the ordering 98 | ;; of other side effects. 99 | (define mutable-data-accessors 100 | (for/list ([name (in-list (list #'car #'cdr #'u8vector-ref 101 | #'string->list #'list->string))]) 102 | (env-lookup global-env name))) 103 | -------------------------------------------------------------------------------- /compiler/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/runtime-path syntax/parse 4 | srfi/4) 5 | 6 | (provide read-program) 7 | 8 | ;; at this point, the #u or #u8(...) has already been seen 9 | (define (read-u8vector port) 10 | (unless (and (equal? (read-char port) #\8) 11 | (equal? (read-char port) #\()) 12 | (error "bad byte vector syntax")) 13 | (let ([s (open-output-string)]) 14 | (let loop ([c (read-char port)] 15 | [n 4]) ; how many characters we've seen (so far, "#u8(") 16 | ;; parse until the closing paren 17 | (cond [(eof-object? c) 18 | (error "bad byte vector syntax")] 19 | [(not (equal? c #\))) 20 | (display c s) 21 | (loop (read-char port) (add1 n))] 22 | [else 23 | ;; we saw the closing paren, we're done 24 | (let ([contents (regexp-split #px"[[:space:]]+" 25 | (get-output-string s))]) 26 | (values (list->u8vector 27 | (map string->number contents)) 28 | n))])))) 29 | 30 | ;; u8vector literals are not natively supported by Racket 31 | (define u8vector-readtable 32 | (make-readtable 33 | (current-readtable) 34 | #\u 35 | 'dispatch-macro 36 | (case-lambda 37 | [(char port) ; read 38 | (read-u8vector port)] 39 | [(char port src line col pos) ; read-syntax 40 | (define-values (vec span) (read-u8vector port)) 41 | (datum->syntax #'here 42 | vec 43 | (list src line col pos span))]))) 44 | 45 | (define (expand-includes exprs) 46 | #`(#,@(map 47 | (syntax-parser 48 | ;; This is a hack. Eventually, we should have the Racket expander 49 | ;; take care of includes. 50 | [(include file) 51 | #:when (eq? (syntax->datum #'include) 'include) 52 | #`(begin 53 | #,@(expand-includes 54 | (let ([in (open-input-file (syntax->datum #'file))]) 55 | (port-count-lines! in) 56 | (port->list (lambda (p) (read-syntax 'here p)) in))))] 57 | [e #'e]) 58 | (if (syntax? exprs) (syntax->list exprs) exprs)))) 59 | 60 | (define-runtime-path compiler-dir ".") 61 | 62 | (define (read-program port) 63 | (parameterize ([current-readtable u8vector-readtable]) 64 | (define (read-lib f) 65 | (define in (open-input-file (build-path compiler-dir f))) 66 | (port-count-lines! in) 67 | (port->list (lambda (p) (read-syntax 'here p)) in)) 68 | (define library 69 | #`(#,@(read-lib "library.scm") ; architecture-independent 70 | #,@(read-lib "gen.library.scm"))) ; architecture-dependent 71 | (port-count-lines! port) 72 | (define prog 73 | (expand-includes 74 | #`(#,@library 75 | #,@(port->list (lambda (p) (read-syntax 'here p)) port)))) 76 | (datum->syntax 77 | #'here ; to get the Racket bindings for define and co, for syntax-parse 78 | (syntax->datum prog) 79 | prog))) ; for source location 80 | -------------------------------------------------------------------------------- /compiler/scheduling.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "ir.rkt" "back-end.rkt") 4 | 5 | (provide schedule) 6 | 7 | ;; Basic block scheduling. 8 | (define (schedule bbs) 9 | (linearize (reorder! bbs))) 10 | 11 | 12 | ;;----------------------------------------------------------------------------- 13 | 14 | (define (reorder! bbs) 15 | (let* ([done (make-vector (vector-length bbs) #f)]) 16 | 17 | (define (unscheduled? label) (not (vector-ref done label))) 18 | 19 | (define (label-refs instrs todo) 20 | (for/fold ([todo todo]) 21 | ([instr (in-list instrs)] 22 | #:when (memq (car instr)'(closure call-toplevel jump-toplevel))) 23 | (cons (cadr instr) todo))) 24 | 25 | (define (schedule-here label new-label todo) 26 | (match (vector-ref bbs label) 27 | [(bb label (and rev-instrs `(,jump . ,rest))) 28 | (define new-todo (label-refs rev-instrs todo)) 29 | (vector-set! bbs label (make-bb new-label rev-instrs)) 30 | (vector-set! done label #t) 31 | (match jump 32 | [`(goto ,label) 33 | (if (unscheduled? label) 34 | (schedule-here label (+ new-label 1) new-todo) 35 | (values (+ new-label 1) new-todo))] 36 | [`(goto-if-false ,label-then ,label-else) 37 | (cond [(unscheduled? label-else) 38 | (schedule-here label-else 39 | (+ new-label 1) 40 | (cons label-then new-todo))] 41 | [(unscheduled? label-then) 42 | (schedule-here label-then 43 | (+ new-label 1) 44 | new-todo)] 45 | [else (values (+ new-label 1) new-todo)])] 46 | [_ (values (+ new-label 1) new-todo)])])) 47 | 48 | (define (schedule-todo new-label todo) 49 | (when (pair? todo) 50 | (let ([label (car todo)]) 51 | (if (unscheduled? label) 52 | (call-with-values 53 | (lambda () (schedule-here label new-label (cdr todo))) 54 | schedule-todo) 55 | (schedule-todo new-label (cdr todo)))))) 56 | 57 | (call-with-values (lambda () (schedule-here 0 0 '())) 58 | schedule-todo) 59 | 60 | (define len (vector-length bbs)) 61 | (renumber-labels bbs (make-vector len 1) len))) 62 | 63 | ;;----------------------------------------------------------------------------- 64 | 65 | ;; State for linearize. 66 | ;; Ugly, but better than having everything as an internal define 67 | (define rev-code '()) 68 | (define pos 0) 69 | (define todo (mcons '() '())) 70 | (define bbs #f) 71 | (define dumped #f) 72 | 73 | (define (emit x) 74 | (set! pos (+ pos 1)) 75 | (set! rev-code (cons x rev-code))) 76 | 77 | (define (get fallthrough-to-next?) 78 | (define r-todo (mcdr todo)) 79 | (and (mpair? r-todo) 80 | (if fallthrough-to-next? 81 | (match r-todo 82 | [(mcons (and label-pos `(,label . ,_)) rest) 83 | (unless (mpair? rest) 84 | (set-mcar! todo todo)) 85 | (set-mcdr! todo rest) 86 | label]) 87 | (let ([best-label-pos 88 | (for/fold ([best-label-pos #f]) 89 | ([x (in-mlist r-todo)] 90 | #:when (not (vector-ref dumped (car x))) 91 | #:when (or (not best-label-pos) 92 | (> (cdr x) (cdr best-label-pos)))) 93 | x)]) 94 | (and best-label-pos 95 | (car best-label-pos)))))) 96 | 97 | (define (next) 98 | (for/first ([label-pos (in-mlist (mcdr todo))] 99 | #:when (not (vector-ref dumped (car label-pos)))) 100 | (car label-pos))) 101 | 102 | (define (schedule! label tail?) 103 | (let ([label-pos (cons label pos)]) 104 | (if tail? 105 | (let ([cell (mcons label-pos '())]) 106 | (set-mcdr! (mcar todo) cell) 107 | (set-mcar! todo cell)) 108 | (let ([cell (mcons label-pos (mcdr todo))]) 109 | (set-mcdr! todo cell) 110 | (when (eq? (mcar todo) todo) 111 | (set-mcar! todo cell)))))) 112 | 113 | (define (dump) 114 | (let loop ([fallthrough-to-next? #t]) 115 | (let ([label (get fallthrough-to-next?)]) 116 | (when label 117 | (cond [(not (vector-ref dumped label)) 118 | (vector-set! dumped label #t) 119 | (loop (dump-bb label))] 120 | [else (loop fallthrough-to-next?)]))))) 121 | 122 | (define (dump-bb label) 123 | (match (vector-ref bbs label) 124 | [(bb label `(,jump . ,rest)) 125 | (emit label) 126 | (for ([instr (in-list (reverse rest))]) 127 | (match instr 128 | [`(,(or 'closure 'call-toplevel) ,arg) 129 | (schedule! arg #t)] 130 | [_ (void)]) 131 | (emit instr)) 132 | (match jump 133 | [`(goto ,label) 134 | (schedule! label #f) 135 | (if (not (equal? label (next))) 136 | (begin (emit jump) #f) 137 | #t)] 138 | [`(goto-if-false ,label-then ,label-else) 139 | (schedule! label-then #f) 140 | (schedule! label-else #f) 141 | (cond [(equal? label-else (next)) 142 | (emit (list 'goto-if-false label-then)) 143 | #t] 144 | [(equal? label-then (next)) 145 | (emit (list 'prim '#%not)) 146 | (emit (list 'goto-if-false label-else)) 147 | #t] 148 | [else 149 | (emit (list 'goto-if-false label-then)) 150 | (emit (list 'goto label-else)) 151 | #f])] 152 | [`(jump-toplevel ,label) 153 | (schedule! label #f) 154 | ;; it is not correct to remove jump-toplevel when label is next 155 | (emit jump) 156 | #f] 157 | [_ 158 | (emit jump) 159 | #f])])) 160 | 161 | 162 | (define (linearize cur-bbs) 163 | (set! bbs cur-bbs) 164 | (set! dumped (make-vector (vector-length cur-bbs) #f)) 165 | (set-mcar! todo todo) ;; make fifo 166 | (schedule! 0 #f) 167 | (dump) 168 | (reverse rev-code)) 169 | -------------------------------------------------------------------------------- /compiler/tree-shaker.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide tree-shake!) 4 | 5 | (require "ir.rkt" "back-end.rkt") 6 | 7 | (define (tree-shake! bbs) 8 | (tighten-jump-cascades! bbs) 9 | (remove-useless-bbs! bbs)) 10 | 11 | (define (bbs->ref-counts bbs) 12 | (let ([ref-counts (make-vector (vector-length bbs) 0)]) 13 | 14 | (define (visit label) 15 | (let ([ref-count (vector-ref ref-counts label)]) 16 | (vector-set! ref-counts label (+ ref-count 1)) 17 | (when (= ref-count 0) 18 | (for ([instr (in-list (bb-rev-instrs (vector-ref bbs label)))]) 19 | (match instr 20 | [`(goto ,arg) 21 | (visit arg)] 22 | [`(goto-if-false ,a1 ,a2) 23 | (visit a1) 24 | (visit a2)] 25 | [`(,(or 'closure 'call-toplevel 'jump-toplevel) ,arg) 26 | (visit arg)] 27 | [_ (void)]))))) 28 | 29 | (visit 0) 30 | 31 | ref-counts)) 32 | 33 | (define (tighten-jump-cascades! bbs) 34 | (let ([ref-counts (bbs->ref-counts bbs)]) 35 | 36 | (define (resolve label) 37 | (let ([rev-instrs (bb-rev-instrs (vector-ref bbs label))]) 38 | (and (or (null? (cdr rev-instrs)) 39 | (= (vector-ref ref-counts label) 1)) 40 | rev-instrs))) 41 | 42 | (define (iterate) 43 | 44 | (define changed? 45 | (for/fold ([changed? #f]) 46 | ([(cur-bb i) (in-indexed (vector-length bbs))] 47 | #:when (> (vector-ref ref-counts i) 0)) 48 | (match cur-bb 49 | 50 | [(bb label `(,jump . ,rest)) 51 | (match jump 52 | [`(goto ,label) 53 | (let ([jump-replacement (resolve label)]) 54 | (if jump-replacement 55 | ;; void is non-false, counts as a change 56 | (vector-set! bbs i 57 | (make-bb label 58 | (append jump-replacement rest))) 59 | changed?))] 60 | 61 | [`(goto-if-false ,label-then ,label-else) 62 | (let* ([jump-then-replacement (resolve label-then)] 63 | [jump-else-replacement (resolve label-else)] 64 | [just-jump-then 65 | (and jump-then-replacement 66 | (null? (cdr jump-then-replacement)))] 67 | [just-jump-else 68 | (and jump-else-replacement 69 | (null? (cdr jump-else-replacement)))] 70 | [then-goto (eq? (caar jump-then-replacement) 'goto)] 71 | [else-goto (eq? (caar jump-else-replacement) 'goto)]) 72 | (if (and just-jump-then just-jump-else 73 | (or then-goto else-goto)) 74 | ;; void is non-false, counts as a change 75 | (vector-set! bbs i 76 | (make-bb 77 | label 78 | `((goto-if-false 79 | ,(if then-goto 80 | (cadar jump-then-replacement) 81 | label-then) 82 | ,(if else-goto 83 | (cadar jump-else-replacement) 84 | label-else)) 85 | . rest))) 86 | changed?))])] 87 | [_ changed?]))) 88 | 89 | (when changed? 90 | (iterate))) 91 | 92 | (iterate))) 93 | 94 | (define (remove-useless-bbs! bbs) 95 | (define ref-counts (bbs->ref-counts bbs)) 96 | (define new-label 97 | (for/fold ([new-label 0]) 98 | ([(bb label) (in-indexed bbs)] 99 | [ref-count (in-vector ref-counts)] 100 | #:when (> ref-count 0)) 101 | (vector-set! bbs label (make-bb new-label (bb-rev-instrs bb))) 102 | (+ new-label 1))) 103 | (renumber-labels bbs ref-counts new-label)) 104 | -------------------------------------------------------------------------------- /compiler/utilities.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require srfi/4) 6 | 7 | (define (compiler-error msg . others) 8 | (parameterize ([current-output-port (current-error-port)]) 9 | (printf "*** PICOBIT ERROR -- ~a" msg) 10 | (for ([x (in-list others)]) 11 | (printf " ~a" 12 | (if (identifier? x) 13 | (format "~a at ~a:~a" 14 | (syntax->datum x) 15 | (syntax-line x) 16 | (syntax-column x)) 17 | (format "~s" x)))) 18 | (newline) 19 | (exit 1))) 20 | 21 | (define (self-eval? expr) 22 | (or (number? expr) 23 | (char? expr) 24 | (boolean? expr) 25 | (string? expr) 26 | (u8vector? expr))) 27 | 28 | 29 | ;; to control output level 30 | (define show-size? (make-parameter #f)) 31 | (define show-asm? (make-parameter #f)) 32 | (define show-parsed? (make-parameter #f)) 33 | (define show-post-front-end? (make-parameter #f)) 34 | (define stats? (make-parameter #f)) 35 | -------------------------------------------------------------------------------- /p: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env racket 2 | #lang racket 3 | 4 | (define (usage) 5 | (printf "usage: p path/to/file.scm\n") 6 | (exit 1)) 7 | 8 | (if (= (vector-length (current-command-line-arguments)) 1) 9 | (let ([file (vector-ref (current-command-line-arguments) 0)]) 10 | (void (and (system* "picobit" (path-replace-suffix file ".scm")) 11 | (system* "picobit-vm" (path-replace-suffix file ".hex"))))) 12 | (usage)) 13 | -------------------------------------------------------------------------------- /picobit: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | racket compiler/picobit.rkt $@ 4 | -------------------------------------------------------------------------------- /tests/fail/compile/define-ordering.expected: -------------------------------------------------------------------------------- 1 | *** PICOBIT ERROR -- variable referenced before its definition: bar at #f:#f 2 | -------------------------------------------------------------------------------- /tests/fail/compile/define-ordering.scm: -------------------------------------------------------------------------------- 1 | (define foo bar) 2 | 3 | (define (bar) 3) 4 | -------------------------------------------------------------------------------- /tests/fail/compile/set-bang-prim.expected: -------------------------------------------------------------------------------- 1 | *** PICOBIT ERROR -- cannot mutate primitive car at 4:18 2 | -------------------------------------------------------------------------------- /tests/fail/compile/set-bang-prim.scm: -------------------------------------------------------------------------------- 1 | (set! car 3) 2 | -------------------------------------------------------------------------------- /tests/fail/compile/unbound.expected: -------------------------------------------------------------------------------- 1 | *** PICOBIT ERROR -- undefined variable: toto at #f:#f 2 | -------------------------------------------------------------------------------- /tests/fail/compile/unbound.scm: -------------------------------------------------------------------------------- 1 | (display toto) 2 | -------------------------------------------------------------------------------- /tests/fail/execute/car-number.expected: -------------------------------------------------------------------------------- 1 | ERROR: car.2: An argument of type pair was expected 2 | -------------------------------------------------------------------------------- /tests/fail/execute/car-number.scm: -------------------------------------------------------------------------------- 1 | (car 5) 2 | -------------------------------------------------------------------------------- /tests/run-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit rackunit/text-ui) 4 | 5 | ;; This tests whether the programs produce the expected output. 6 | ;; This is a pretty weak equivalence, and doesn't catch optimization 7 | ;; regressions. Checking for bytecode equality would be too strong an 8 | ;; equivalence. 9 | ;; This should be fixed. 10 | 11 | (define (test-file? file) 12 | (and (regexp-match? #rx"[.]scm$" file) 13 | ;; skip emacs temp unsaved file backups 14 | (not (regexp-match "^\\.#" file)))) 15 | 16 | (define (run-one file f) 17 | (when (test-file? file) 18 | (let* ([file-str (path->string file)] 19 | [hex (path-replace-suffix file ".hex")] 20 | [expected (path-replace-suffix file ".expected")] 21 | [input (path-replace-suffix file ".input")]) 22 | (test-suite 23 | file-str 24 | (begin 25 | ;; (displayln file) 26 | (test-case "no expected file" 27 | (check-true (file-exists? expected))) 28 | (when (file-exists? expected) 29 | (f file-str hex expected input)) 30 | (when (file-exists? hex) 31 | (delete-file hex))))))) 32 | 33 | (define (run-succeed file) 34 | (run-one 35 | file 36 | (lambda (file-str hex expected input) 37 | (system* "./picobit" file-str) 38 | (test-case "compilation" (check-true (file-exists? hex))) 39 | (when (file-exists? hex) 40 | (define out (open-output-string)) 41 | (parameterize ([current-input-port (if (file-exists? input) 42 | (open-input-file input) 43 | (open-input-string ""))] 44 | [current-output-port out] 45 | [current-error-port out]) ; run-fail-execute needs that 46 | (system* "./picobit-vm" hex)) 47 | (test-case "execution" 48 | (check-equal? (get-output-string out) 49 | (file->string expected))))))) 50 | 51 | (define (run-fail-compile file) 52 | (run-one 53 | file 54 | (lambda (file-str hex expected input) 55 | (define err (open-output-string)) 56 | (parameterize ([current-error-port err]) 57 | (system* "./picobit" file-str)) 58 | (test-case "compilation error" 59 | (check-false (file-exists? hex)) 60 | (check-equal? (get-output-string err) 61 | (file->string expected)))))) 62 | 63 | (define (run-fail-execute file) (run-succeed file)) 64 | 65 | (define (run-single file) 66 | (let*-values ([(path p b) (split-path file)] 67 | [(dir) (path->string path)]) 68 | (cond [(equal? dir "tests/succeed/") 69 | (run-succeed file)] 70 | [(equal? dir "tests/fail/compile/") 71 | (run-fail-compile file)] 72 | [(equal? dir "tests/fail/execute/") 73 | (run-fail-execute file)]))) 74 | 75 | (define args (current-command-line-arguments)) 76 | 77 | (void 78 | (run-tests 79 | (cond [(>= (vector-length args) 1) ; run one 80 | (run-single (string->path (vector-ref args 0)))] 81 | [else ; run all 82 | (make-test-suite 83 | "PICOBIT tests" 84 | (filter (lambda (x) (not (void? x))) 85 | (append 86 | (for/list ([file (in-directory "./tests/succeed/")]) 87 | (run-succeed file)) 88 | (for/list ([file (in-directory "./tests/fail/compile/")]) 89 | (run-fail-compile file)) 90 | (for/list ([file (in-directory "./tests/fail/execute/")]) 91 | (run-fail-execute file)))))]))) 92 | -------------------------------------------------------------------------------- /tests/succeed/256.expected: -------------------------------------------------------------------------------- 1 | #f#t#t 2 | 513 3 | 257#t 4 | 256#t 5 | 255 6 | -------------------------------------------------------------------------------- /tests/succeed/256.scm: -------------------------------------------------------------------------------- 1 | ;; to test fixnum boundary conditions 2 | 3 | (define x 256) 4 | (define y 257) 5 | 6 | (display (> x y)) 7 | (display (< x y)) 8 | (display (> x 255)) 9 | (newline) 10 | (display (+ x y)) 11 | (newline) 12 | (display (+ x 1)) 13 | (display (= (+ x 1) y)) 14 | (newline) 15 | (display (- y 1)) 16 | (display (= x (- y 1))) 17 | (newline) 18 | (display (- x 1)) 19 | (newline) 20 | -------------------------------------------------------------------------------- /tests/succeed/add.expected: -------------------------------------------------------------------------------- 1 | #t 2 | #t 3 | #t 4 | #t 5 | #t 6 | #t 7 | #t 8 | #t 9 | #t 10 | -------------------------------------------------------------------------------- /tests/succeed/add.scm: -------------------------------------------------------------------------------- 1 | (displayln (= (+ 2 2) 4)) 2 | (displayln (= (+ 0 5) 5)) 3 | (displayln (= (+ 2 7) 9)) 4 | (displayln (= (+ 0 -5) -5)) 5 | (displayln (= (+ 2 -5) -3)) 6 | (displayln (= (+ 7 -5) 2)) 7 | (displayln (= (+ -3 -7) -10)) 8 | 9 | (displayln (= (+ 100000 1) (+ 50000 50001))) 10 | (displayln (= (+ 32768 32768) 65536)) 11 | -------------------------------------------------------------------------------- /tests/succeed/bug-gc-bignum.expected: -------------------------------------------------------------------------------- 1 | 3 2 | 45 3 | 45897500835 4 | -------------------------------------------------------------------------------- /tests/succeed/bug-gc-bignum.scm: -------------------------------------------------------------------------------- 1 | ;; This triggers gc inside bignum operations. 2 | ;; Before bignum temp vars were GC roots, this caused all kinds of 3 | ;; trouble. 4 | ;; Registering them as roots fixed the problem. 5 | (displayln (* 1 3)) 6 | (displayln (* 15 3)) 7 | (displayln (* 21435 2141241)) 8 | -------------------------------------------------------------------------------- /tests/succeed/callcc.expected: -------------------------------------------------------------------------------- 1 | 2 2 | -------------------------------------------------------------------------------- /tests/succeed/callcc.scm: -------------------------------------------------------------------------------- 1 | ;; tests call/cc -- 2 for phds 2 | 3 | (displayln (+ 1 (call/cc (lambda (fst) (+ 5 (call/cc (lambda (snd) (+ 10 (fst 1))))))))) 4 | -------------------------------------------------------------------------------- /tests/succeed/clock.expected: -------------------------------------------------------------------------------- 1 | 07 -------------------------------------------------------------------------------- /tests/succeed/clock.scm: -------------------------------------------------------------------------------- 1 | (define x (time->seconds (current-time))) 2 | (display x) 3 | (sleep 700) 4 | (display (- (time->seconds (current-time)) x)) 5 | -------------------------------------------------------------------------------- /tests/succeed/cmp.expected: -------------------------------------------------------------------------------- 1 | #t 2 | #t 3 | #t 4 | #t 5 | #t 6 | #t 7 | #t 8 | #t 9 | #t 10 | #t 11 | #t 12 | #t 13 | #t 14 | -------------------------------------------------------------------------------- /tests/succeed/cmp.scm: -------------------------------------------------------------------------------- 1 | ;; to avoid being constant-folded away 2 | (define zero 0) 3 | (define min-one -1) 4 | (define five 5) 5 | (define two 2) 6 | (define min-five -5) 7 | (define min-two -2) 8 | 9 | (displayln (not (< zero zero))) 10 | (displayln (< min-one zero)) 11 | (displayln (= five five)) 12 | (displayln (< two five)) 13 | (displayln (> five two)) 14 | (displayln (= min-five min-five)) 15 | (displayln (> min-two min-five)) 16 | (displayln (< min-five min-two)) 17 | (displayln (< min-five 65533)) 18 | (displayln (< min-five two)) 19 | (displayln (> five -65533)) 20 | (displayln (> five min-two)) 21 | (displayln (< min-five 65700)) 22 | -------------------------------------------------------------------------------- /tests/succeed/cond.expected: -------------------------------------------------------------------------------- 1 | 2baz 2 | -------------------------------------------------------------------------------- /tests/succeed/cond.scm: -------------------------------------------------------------------------------- 1 | (define x 3) 2 | (define y 2) 3 | (set! x 5) 4 | 5 | (display (cond (#f 2) ((= 1 y) 4) (#t 2))) 6 | ;; if all is false, returns an object, acceptable 7 | 8 | (display (cond ((> y x) "foo") 9 | ((= 1 y) "bar") 10 | (else "baz"))) 11 | (newline) 12 | -------------------------------------------------------------------------------- /tests/succeed/constant-folding.expected: -------------------------------------------------------------------------------- 1 | 14 2 | 1 3 | 1 4 | 2 5 | 3 6 | 1 7 | -------------------------------------------------------------------------------- /tests/succeed/constant-folding.scm: -------------------------------------------------------------------------------- 1 | ;; For now, we have to use the primitives directly, since there's no way 2 | ;; to ensure that the + or * we're seeing is indeed the one from stdlib. 3 | ;; Also, the current test harness cannot detect if constant folding does 4 | ;; not happen. This test will only fail if there's an error somewhere. 5 | (displayln (#%+ 2 (#%mul-non-neg 3 4))) 6 | 7 | (displayln (if #t 1 2)) ; all these should be a single constant, no if 8 | (displayln (if 3 1 2)) 9 | (displayln (if #f 1 2)) 10 | 11 | (displayln (begin 2 3)) ; same 12 | (displayln (if (begin 2 3) 1 2)) 13 | -------------------------------------------------------------------------------- /tests/succeed/copy-propagation.expected: -------------------------------------------------------------------------------- 1 | 3 2 | 5 3 | 2 4 | 4 5 | 8 6 | 11 7 | -------------------------------------------------------------------------------- /tests/succeed/copy-propagation.scm: -------------------------------------------------------------------------------- 1 | ;; optimization test, must be checked manually 2 | 3 | (define x 3) ; should disappear, no non-propagated uses 4 | (displayln x) ; should be inlined 5 | (displayln (#%+ x 2)) ; inlined + constant propagated 6 | 7 | (define y 2) 8 | (displayln y) ; no can do, mutation 9 | (set! y 1) 10 | 11 | (define a 4) ; transitive chain 12 | (define b a) ; all 3 globals should be gone 13 | (define c b) 14 | (displayln c) ; should be 4 15 | 16 | (define aa 5) 17 | (define (f x) 18 | (+ x aa)) ; make sure it inlines inside functions 19 | (displayln (f 3)) ; f is single use, should be propagated 20 | 21 | (define bb (#%+ aa 2)) ; can't prove plain + side-effect oblivious 22 | (displayln (+ bb 4)) ; yes, bb is single-use 23 | -------------------------------------------------------------------------------- /tests/succeed/div.expected: -------------------------------------------------------------------------------- 1 | 23-3 -------------------------------------------------------------------------------- /tests/succeed/div.scm: -------------------------------------------------------------------------------- 1 | (display (quotient 10 5)) 2 | (display (quotient 6 2)) 3 | (display (quotient 6 -2)) 4 | -------------------------------------------------------------------------------- /tests/succeed/duplicate-constants.expected: -------------------------------------------------------------------------------- 1 | (1 2 3 1 2 3) 2 | -------------------------------------------------------------------------------- /tests/succeed/duplicate-constants.scm: -------------------------------------------------------------------------------- 1 | ;; this is a test that ensures that multiple copies of the same constant 2 | ;; are generated only one in the resulting program 3 | ;; this has to be checked manually 4 | (define x '(1 2 3)) 5 | (define y '(1 2 3)) 6 | (displayln (append x y)) 7 | -------------------------------------------------------------------------------- /tests/succeed/empty.expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stamourv/picobit/bde85aa193964b7151f2d0eb39d47058d4298fc6/tests/succeed/empty.expected -------------------------------------------------------------------------------- /tests/succeed/empty.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stamourv/picobit/bde85aa193964b7151f2d0eb39d47058d4298fc6/tests/succeed/empty.scm -------------------------------------------------------------------------------- /tests/succeed/fixnums.expected: -------------------------------------------------------------------------------- 1 | 255 2 | 254 3 | 253 4 | 252 5 | 251 6 | 250 7 | 249 8 | 248 9 | 247 10 | 246 11 | 245 12 | 244 13 | 243 14 | 242 15 | 241 16 | 240 17 | 239 18 | 238 19 | 237 20 | 236 21 | 235 22 | 234 23 | 233 24 | 232 25 | 231 26 | 230 27 | 229 28 | 228 29 | 227 30 | 226 31 | 225 32 | 224 33 | 223 34 | 222 35 | 221 36 | 220 37 | 219 38 | 218 39 | 217 40 | 216 41 | 215 42 | 214 43 | 213 44 | 212 45 | 211 46 | 210 47 | 209 48 | 208 49 | 207 50 | 206 51 | 205 52 | 204 53 | 203 54 | 202 55 | 201 56 | 200 57 | 199 58 | 198 59 | 197 60 | 196 61 | 195 62 | 194 63 | 193 64 | 192 65 | 191 66 | 190 67 | 189 68 | 188 69 | 187 70 | 186 71 | 185 72 | 184 73 | 183 74 | 182 75 | 181 76 | 180 77 | 179 78 | 178 79 | 177 80 | 176 81 | 175 82 | 174 83 | 173 84 | 172 85 | 171 86 | 170 87 | 169 88 | 168 89 | 167 90 | 166 91 | 165 92 | 164 93 | 163 94 | 162 95 | 161 96 | 160 97 | 159 98 | 158 99 | 157 100 | 156 101 | 155 102 | 154 103 | 153 104 | 152 105 | 151 106 | 150 107 | 149 108 | 148 109 | 147 110 | 146 111 | 145 112 | 144 113 | 143 114 | 142 115 | 141 116 | 140 117 | 139 118 | 138 119 | 137 120 | 136 121 | 135 122 | 134 123 | 133 124 | 132 125 | 131 126 | 130 127 | 129 128 | 128 129 | 127 130 | 126 131 | 125 132 | 124 133 | 123 134 | 122 135 | 121 136 | 120 137 | 119 138 | 118 139 | 117 140 | 116 141 | 115 142 | 114 143 | 113 144 | 112 145 | 111 146 | 110 147 | 109 148 | 108 149 | 107 150 | 106 151 | 105 152 | 104 153 | 103 154 | 102 155 | 101 156 | 100 157 | 99 158 | 98 159 | 97 160 | 96 161 | 95 162 | 94 163 | 93 164 | 92 165 | 91 166 | 90 167 | 89 168 | 88 169 | 87 170 | 86 171 | 85 172 | 84 173 | 83 174 | 82 175 | 81 176 | 80 177 | 79 178 | 78 179 | 77 180 | 76 181 | 75 182 | 74 183 | 73 184 | 72 185 | 71 186 | 70 187 | 69 188 | 68 189 | 67 190 | 66 191 | 65 192 | 64 193 | 63 194 | 62 195 | 61 196 | 60 197 | 59 198 | 58 199 | 57 200 | 56 201 | 55 202 | 54 203 | 53 204 | 52 205 | 51 206 | 50 207 | 49 208 | 48 209 | 47 210 | 46 211 | 45 212 | 44 213 | 43 214 | 42 215 | 41 216 | 40 217 | 39 218 | 38 219 | 37 220 | 36 221 | 35 222 | 34 223 | 33 224 | 32 225 | 31 226 | 30 227 | 29 228 | 28 229 | 27 230 | 26 231 | 25 232 | 24 233 | 23 234 | 22 235 | 21 236 | 20 237 | 19 238 | 18 239 | 17 240 | 16 241 | 15 242 | 14 243 | 13 244 | 12 245 | 11 246 | 10 247 | 9 248 | 8 249 | 7 250 | 6 251 | 5 252 | 4 253 | 3 254 | 2 255 | 1 256 | -------------------------------------------------------------------------------- /tests/succeed/fixnums.scm: -------------------------------------------------------------------------------- 1 | ;; test for the new (0-255) fixnums 2 | 3 | (define x 255) 4 | (define (loop x) 5 | (if (> x 0) 6 | (begin (displayln x) 7 | (loop (- x 1))))) 8 | (loop x) 9 | -------------------------------------------------------------------------------- /tests/succeed/gc-bignum-display.expected: -------------------------------------------------------------------------------- 1 | 45897500835 2 | 45897500835 3 | 45897500835 4 | 45897500835 5 | 45897500835 6 | 45897500835 7 | 45897500835 8 | 45897500835 9 | 45897500835 10 | 45897500835 11 | 45897500835 12 | 45897500835 13 | -------------------------------------------------------------------------------- /tests/succeed/gc-bignum-display.scm: -------------------------------------------------------------------------------- 1 | ;; bug: after GC, bignum display becomes odd 2 | 3 | (displayln (* 21435 2141241)) 4 | (displayln (* 21435 2141241)) 5 | (displayln (* 21435 2141241)) 6 | (displayln (* 21435 2141241)) 7 | (displayln (* 21435 2141241)) 8 | (displayln (* 21435 2141241)) 9 | (displayln (* 21435 2141241)) 10 | (displayln (* 21435 2141241)) 11 | (displayln (* 21435 2141241)) 12 | (displayln (* 21435 2141241)) 13 | (displayln (* 21435 2141241)) 14 | (displayln (* 21435 2141241)) 15 | -------------------------------------------------------------------------------- /tests/succeed/gc.expected: -------------------------------------------------------------------------------- 1 | 0#t 2 | 1#t 3 | 2#t 4 | 3#t 5 | 4#t 6 | 5#t 7 | 6#t 8 | 7#t 9 | 8#t 10 | 9#t 11 | 10#t 12 | 11#t 13 | 12#t 14 | 13#t 15 | 14#t 16 | 15#t 17 | 16#t 18 | 17#t 19 | 18#t 20 | 19#t 21 | -------------------------------------------------------------------------------- /tests/succeed/gc.scm: -------------------------------------------------------------------------------- 1 | (let loop ((i 0)) 2 | (if (< i 20) 3 | (begin (display i) 4 | (displayln (= (* 21435 2141241) 45897500835)) 5 | (loop (+ i 1))))) 6 | -------------------------------------------------------------------------------- /tests/succeed/geq-leq.expected: -------------------------------------------------------------------------------- 1 | PASSED 2 | #t#t#t#t#t#t 3 | -------------------------------------------------------------------------------- /tests/succeed/geq-leq.scm: -------------------------------------------------------------------------------- 1 | ;; test to see if the newly reintroduced <= and >= work 2 | 3 | (if (and (<= 45 45) 4 | (<= 45 47) 5 | (not (<= 45 32)) 6 | (>= 32 10) 7 | (>= 32 32) 8 | (not (>= 32 45))) 9 | (display "PASSED\n")) 10 | (display (<= 45 45)) 11 | (display (<= 45 47)) 12 | (display (not (<= 45 32))) 13 | (display (>= 32 10)) 14 | (display (>= 32 32)) 15 | (display (not (>= 32 45))) 16 | (display "\n") 17 | -------------------------------------------------------------------------------- /tests/succeed/globals.expected: -------------------------------------------------------------------------------- 1 | 3274655 2 | -------------------------------------------------------------------------------- /tests/succeed/globals.scm: -------------------------------------------------------------------------------- 1 | (define x 2) 2 | (define y 3) 3 | (define foo (lambda (x) (+ x 8 213 32523))) 4 | (display (foo x)) 5 | (display (+ x y)) 6 | 7 | (define (foo2 x y) 8 | (if (and x y) 9 | (+ x y) 10 | -1)) 11 | 12 | (display (foo2 x y)) 13 | (newline) 14 | -------------------------------------------------------------------------------- /tests/succeed/higher-order-prim.expected: -------------------------------------------------------------------------------- 1 | (1 4 7) 2 | 1 3 | -------------------------------------------------------------------------------- /tests/succeed/higher-order-prim.scm: -------------------------------------------------------------------------------- 1 | (displayln (map car '((1 2 3) (4 5 6) (7 8 9)))) 2 | (define my-car car) 3 | (displayln (my-car '(1 2 3))) 4 | -------------------------------------------------------------------------------- /tests/succeed/infinite-loop.expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stamourv/picobit/bde85aa193964b7151f2d0eb39d47058d4298fc6/tests/succeed/infinite-loop.expected -------------------------------------------------------------------------------- /tests/succeed/infinite-loop.scm: -------------------------------------------------------------------------------- 1 | ;; this test is to make sure the inliner does not go in an infinite loop 2 | (define (f x) (f x)) 3 | 4 | (define (g x) (h x)) 5 | (define (h x) (g x)) 6 | -------------------------------------------------------------------------------- /tests/succeed/io.expected: -------------------------------------------------------------------------------- 1 | ab -------------------------------------------------------------------------------- /tests/succeed/io.input: -------------------------------------------------------------------------------- 1 | ab -------------------------------------------------------------------------------- /tests/succeed/io.scm: -------------------------------------------------------------------------------- 1 | (putchar (getchar)) 2 | 3 | (putchar (getchar-wait 10)) 4 | 5 | (sleep 1) 6 | -------------------------------------------------------------------------------- /tests/succeed/ior.expected: -------------------------------------------------------------------------------- 1 | #t 2 | #t 3 | #t 4 | #t 5 | #t 6 | #t 7 | #t 8 | #t 9 | -------------------------------------------------------------------------------- /tests/succeed/ior.scm: -------------------------------------------------------------------------------- 1 | ;; bitwise or tests 2 | 3 | (displayln (= (bitwise-ior #xf0 #x0f) #xff)) 4 | (displayln (= (bitwise-ior #x30 #x00) #x30)) 5 | (displayln (= (bitwise-ior #x00 #x05) #x05)) 6 | (displayln (= (bitwise-ior #x08 #x05) #x0D)) 7 | (displayln (= (bitwise-ior #x18 #x05) #x1D)) 8 | (displayln (= (bitwise-ior #x18 #x25) #x3D)) 9 | (displayln (= (bitwise-ior #x18 #x35) #x3D)) 10 | (displayln (= (bitwise-ior #x1823122312 #x351234123456) 58386709362518)) 11 | -------------------------------------------------------------------------------- /tests/succeed/lambda-mut-immut.expected: -------------------------------------------------------------------------------- 1 | 10 2 | -------------------------------------------------------------------------------- /tests/succeed/lambda-mut-immut.scm: -------------------------------------------------------------------------------- 1 | (define (f x y) ; one is mutable, the other is not 2 | (set! x 4) 3 | (#%+ x y)) 4 | (displayln (f 1 6)) 5 | -------------------------------------------------------------------------------- /tests/succeed/left-left-lambda.expected: -------------------------------------------------------------------------------- 1 | 5 2 | 7 3 | 9 4 | 3 5 | 4 6 | 5 7 | 7 8 | 8 9 | 8 10 | 8 11 | 5 12 | 6 13 | 9 14 | 15 15 | -------------------------------------------------------------------------------- /tests/succeed/left-left-lambda.scm: -------------------------------------------------------------------------------- 1 | ;; opt test for left-left-lambda inlining 2 | 3 | (displayln ((lambda (x) (+ x 2)) 3)) ; yes 4 | 5 | (define y 5) 6 | (displayln ((lambda (x) (+ x 2)) y)) ; yes 7 | 8 | (displayln ((lambda (x y) (+ x y 2)) 2 y)) ; yes 9 | 10 | (displayln ((lambda (x y) (+ x 2)) 2 (displayln 3))) ; no, side-effect 11 | 12 | (let ([x 3]) 13 | (displayln (+ x 2))) ; yes 14 | 15 | (let* ([x 3] ; yes 16 | [y 4]) ; chain. body of one l-l-l is another. 17 | (displayln (+ x y))) 18 | 19 | ;; can't mutate to fool other opts, mutable vars are not side-effect oblivious 20 | (define z 4) 21 | (displayln ((lambda (x) (+ x 3)) (#%+ 1 z))) ; yes, side-effect-oblivious 22 | 23 | (define (f x) (#%+ 1 x)) 24 | (displayln ((lambda (x) (+ x 3)) (f z))) ; yes, body of f is ok 25 | (displayln ((lambda (x) (+ x 3)) (+ 1 z))) ; no, body of + is recursive 26 | 27 | (displayln ((lambda (x) (+ x 3)) (if z 2 3))) ; yes 28 | 29 | (displayln ((lambda (x) (+ x 3)) (begin 2 3))) ; yes 30 | 31 | 32 | (displayln ((lambda (x) (+ x (* x 2))) 3)) ; yes, trivial arg used twice 33 | (displayln ((lambda (x) (+ x (* x 2))) 34 | (#%+ 1 z))) ; no, non-trivial arg used twice 35 | ;; Note: currently, the arg is only non-trivial because left-left-lambda 36 | ;; inlining is done before constant propagation. _Very_ brittle. 37 | -------------------------------------------------------------------------------- /tests/succeed/letrec.expected: -------------------------------------------------------------------------------- 1 | #t 2 | 7 3 | -------------------------------------------------------------------------------- /tests/succeed/letrec.scm: -------------------------------------------------------------------------------- 1 | (letrec ((odd? (lambda (x) (and (not (= x 0)) (even? (- x 1))))) 2 | (even? (lambda (x) (or (= x 0) (odd? (- x 1)))))) 3 | (display (even? 2))) 4 | (newline) 5 | 6 | (letrec ((foo (lambda (x) (if (> x 6) x (bar x)))) 7 | (bar (lambda (x) (foo (+ x 1))))) 8 | (display (foo 1))) 9 | (newline) 10 | -------------------------------------------------------------------------------- /tests/succeed/list.expected: -------------------------------------------------------------------------------- 1 | #t 2 | #t 3 | 0 4 | 4 5 | (1 2 3 4 # # # #) 6 | (100 99 98 97) 7 | abcd 8 | (97 98 99 100) 9 | 5 10 | -------------------------------------------------------------------------------- /tests/succeed/list.scm: -------------------------------------------------------------------------------- 1 | ;; tests with lists 2 | 3 | (define lst1 '()) 4 | (define lst2 '(1 2 3 4)) 5 | (define lst3 '(a b c d)) 6 | (define lst4 '(#\a #\b #\c #\d)) 7 | 8 | (displayln (null? lst1)) 9 | (displayln (not (null? lst2))) 10 | (displayln (length lst1)) 11 | (displayln (length lst2)) 12 | (displayln (append lst2 lst3)) 13 | (displayln (reverse lst4)) 14 | 15 | (displayln (list->string lst4)) 16 | (define s "abcd") ; to defeat constant folding 17 | (displayln (string->list s)) 18 | 19 | (define lst5 (list 1 2 3 4)) 20 | (list-set! lst5 2 5) 21 | (displayln (list-ref lst5 2)) 22 | -------------------------------------------------------------------------------- /tests/succeed/loops.expected: -------------------------------------------------------------------------------- 1 | (2 3 4 5 6) 2 | #f 3 | -------------------------------------------------------------------------------- /tests/succeed/loops.scm: -------------------------------------------------------------------------------- 1 | ;; tests with loops 2 | 3 | (displayln (map (lambda (x) (+ x 1)) '(1 2 3 4 5))) 4 | (displayln (for-each (lambda (x) (set! x (+ x 1))) '(1 2 3 4 5))) 5 | -------------------------------------------------------------------------------- /tests/succeed/mul.expected: -------------------------------------------------------------------------------- 1 | 3 2 | 45 3 | 45897500835 4 | 10000 5 | #t 6 | #t 7 | #t 8 | #t 9 | #t 10 | #t 11 | #t 12 | #t 13 | #t 14 | #t 15 | #t 16 | #t 17 | #t 18 | #t 19 | -------------------------------------------------------------------------------- /tests/succeed/mul.scm: -------------------------------------------------------------------------------- 1 | (define (foo x y) 2 | (* x y)) 3 | 4 | (displayln (foo 1 3)) 5 | (displayln (foo 15 3)) 6 | (displayln (* 21435 2141241)) 7 | (displayln (* 100 100)) 8 | 9 | (displayln (= (* 2 2) 4)) 10 | (displayln (= (* 0 5) 0)) 11 | (displayln (= (* 2 7) 14)) 12 | (displayln (= (* 1 -5) -5)) 13 | (displayln (= (* 2 -5) -10)) 14 | (displayln (= (* -7 5) -35)) 15 | (displayln (= (* -3 -7) 21)) 16 | 17 | (displayln (= (* 10000 10000) 100000000)) 18 | (displayln (= (* -10000 10000) -100000000)) 19 | (displayln (= (* 10000 -10000) -100000000)) 20 | (displayln (= (* -10000 -10000) 100000000)) 21 | 22 | (displayln (= (* 100000 10000) 1000000000)) 23 | (displayln (= (* 10000 100000) 1000000000)) 24 | (displayln (= (* 100000 100000) 10000000000)) 25 | -------------------------------------------------------------------------------- /tests/succeed/named-let.expected: -------------------------------------------------------------------------------- 1 | 0 2 | 1 3 | 2 4 | 3 5 | 4 6 | 5 7 | 6 8 | 7 9 | 8 10 | 9 11 | -------------------------------------------------------------------------------- /tests/succeed/named-let.scm: -------------------------------------------------------------------------------- 1 | (let loop ((x 0)) 2 | (if (< x 10) 3 | (begin (displayln x) 4 | (loop (+ x 1))))) 5 | -------------------------------------------------------------------------------- /tests/succeed/neg.expected: -------------------------------------------------------------------------------- 1 | -1 -------------------------------------------------------------------------------- /tests/succeed/neg.scm: -------------------------------------------------------------------------------- 1 | (display (- 1)) 2 | -------------------------------------------------------------------------------- /tests/succeed/nested-inline-eta.expected: -------------------------------------------------------------------------------- 1 | 7 2 | 6 3 | 5 4 | 5 5 | 5 6 | 5 7 | 4 8 | 4 9 | 5 10 | 5 11 | 8 12 | 8 13 | -------------------------------------------------------------------------------- /tests/succeed/nested-inline-eta.scm: -------------------------------------------------------------------------------- 1 | ;; this is to make sure an optimization happens, so it needs to be checked 2 | ;; manually 3 | 4 | (define (foo x y) ; these should all be the same 5 | (bar x y)) 6 | (define (bar x y) 7 | (baz x y)) 8 | (define (baz x y) 9 | (#%+ x y)) 10 | 11 | (displayln (foo 3 4)) ; should be calling #%+ directly 12 | (displayln (foo (foo 1 2) 3)) ; same here 13 | 14 | 15 | (define (f x) (g 3)) ; no, f has 2 args, g has 2 16 | (define (g x) (#%+ x 2)) 17 | (displayln (f 2)) ; should be (g 3) 18 | 19 | (define (h) (a 3)) ; no, increases arg count 20 | (define (a x) (#%+ x 2)) 21 | (displayln (h)) 22 | 23 | (define (b x) (c x 3)) ; yes 24 | (define (c x y) (#%+ x y)) 25 | (displayln (b 2)) ; no we'd trade 1 arg for 2 26 | (displayln (b 2)) ; to defeat copy propagation (not single-use) 27 | 28 | (define (d x) (e x 3)) ; yes 29 | (define (e x y) (#%+ x 2)) 30 | (displayln (d 2)) ; no, same 31 | (displayln (d 2)) ; same 32 | 33 | (define (ff x) (gg x 3)) ; yes, with constant prop, should just be 5 34 | (define (gg x y) (#%+ y 2)) 35 | (displayln (ff 2)) ; no, same 36 | (displayln (ff 2)) 37 | 38 | (define (hh x y) (#%+ x (aa y 34))) ; yes 39 | (define (aa x y) (#%+ x 3)) ; hh's y is aa's x, tests capture-avoiding subst. 40 | (displayln (hh 2 3)) ; no, one inner arg is non-trivial: (aa y) 41 | (displayln (hh 2 3)) 42 | -------------------------------------------------------------------------------- /tests/succeed/num-display.expected: -------------------------------------------------------------------------------- 1 | 32768 -> 32768 2 | 1000000 -> 1000000 3 | -32768 -> -32768 4 | -70000 -> -70000 5 | 0 -> 0 6 | -------------------------------------------------------------------------------- /tests/succeed/num-display.scm: -------------------------------------------------------------------------------- 1 | (display 32768) 2 | (display " -> 32768\n") 3 | (display 1000000) 4 | (display " -> 1000000\n") 5 | (display -32768) 6 | (display " -> -32768\n") 7 | (display -70000) 8 | (display " -> -70000\n") 9 | (display (+ 32768 -32768)) 10 | (display " -> 0\n") 11 | -------------------------------------------------------------------------------- /tests/succeed/pairs.expected: -------------------------------------------------------------------------------- 1 | 2 2 | 1 3 | 6 4 | (4 . 2) 5 | -------------------------------------------------------------------------------- /tests/succeed/pairs.scm: -------------------------------------------------------------------------------- 1 | (define l '(0 1 2 3 4 5 6)) 2 | 3 | (define l2 (cons 2 3)) 4 | 5 | (displayln (car l2)) 6 | (set-car! l2 1) 7 | (displayln (car l2)) 8 | 9 | (define l3 (cons (list-ref l 4) 2)) 10 | 11 | (displayln (list-ref l 6)) 12 | 13 | (displayln l3) 14 | -------------------------------------------------------------------------------- /tests/succeed/pointers.expected: -------------------------------------------------------------------------------- 1 | 4 -------------------------------------------------------------------------------- /tests/succeed/pointers.scm: -------------------------------------------------------------------------------- 1 | (display (+ 2 2)) 2 | -------------------------------------------------------------------------------- /tests/succeed/procs.expected: -------------------------------------------------------------------------------- 1 | 0 2 | 0 3 | 0 4 | 0 5 | 0 6 | 0 7 | 0 8 | 0 9 | 0 10 | 0 11 | 1 12 | 1 13 | 1 14 | 1 15 | 1 16 | 1 17 | 1 18 | 1 19 | 1 20 | 1 21 | 2 22 | 2 23 | 2 24 | 2 25 | 2 26 | 2 27 | 2 28 | 2 29 | 2 30 | 3 31 | 3 32 | 3 33 | 3 34 | 3 35 | 3 36 | 3 37 | 3 38 | 4 39 | 4 40 | 4 41 | 4 42 | 4 43 | 4 44 | 4 45 | 5 46 | 5 47 | 5 48 | 5 49 | 5 50 | 5 51 | 6 52 | 6 53 | 6 54 | 6 55 | 6 56 | 7 57 | 7 58 | 7 59 | 7 60 | 8 61 | 8 62 | 8 63 | 9 64 | 9 65 | 10 66 | DONE 67 | 0 68 | 0 69 | 0 70 | 0 71 | 0 72 | 0 73 | 0 74 | 0 75 | 0 76 | 0 77 | 1 78 | 1 79 | 1 80 | 1 81 | 1 82 | 1 83 | 1 84 | 1 85 | 1 86 | 1 87 | 2 88 | 2 89 | 2 90 | 2 91 | 2 92 | 2 93 | 2 94 | 2 95 | 2 96 | 3 97 | 3 98 | 3 99 | 3 100 | 3 101 | 3 102 | 3 103 | 3 104 | 4 105 | 4 106 | 4 107 | 4 108 | 4 109 | 4 110 | 4 111 | 5 112 | 5 113 | 5 114 | 5 115 | 5 116 | 5 117 | 6 118 | 6 119 | 6 120 | 6 121 | 6 122 | 7 123 | 7 124 | 7 125 | 7 126 | 8 127 | 8 128 | 8 129 | 9 130 | 9 131 | 10 132 | DONE 133 | -------------------------------------------------------------------------------- /tests/succeed/procs.scm: -------------------------------------------------------------------------------- 1 | ;; test processes 2 | 3 | (start-first-process 4 | (lambda () 5 | (let loop ((a 1)) 6 | (begin 7 | (spawn 8 | (lambda () 9 | (let loop2 ((a2 0)) 10 | (yield) 11 | (displayln a2) 12 | (if (= a a2) (exit) 13 | (loop2 (+ a2 1)))))) 14 | (if (= a 10) 15 | (exit) 16 | (loop (+ a 1))))))) 17 | (displayln "DONE") 18 | (start-first-process 19 | (lambda () 20 | (let loop ((a 1)) 21 | (begin 22 | (spawn 23 | (lambda () 24 | (let loop2 ((a2 0)) 25 | (yield) 26 | (displayln a2) 27 | (if (= a a2) #f 28 | (loop2 (+ a2 1)))))) 29 | (if (= a 10) 30 | (exit) 31 | (loop (+ a 1))))))) 32 | (displayln "DONE") 33 | -------------------------------------------------------------------------------- /tests/succeed/rom-bignum.expected: -------------------------------------------------------------------------------- 1 | 3369 2 | -------------------------------------------------------------------------------- /tests/succeed/rom-bignum.scm: -------------------------------------------------------------------------------- 1 | ;; checks if ROM bignums are encoded correctly 2 | (displayln (+ 1024 2345)) 3 | -------------------------------------------------------------------------------- /tests/succeed/set-cdr.expected: -------------------------------------------------------------------------------- 1 | 34 2 | -------------------------------------------------------------------------------- /tests/succeed/set-cdr.scm: -------------------------------------------------------------------------------- 1 | (define x (cons 2 3)) 2 | (display (cdr x)) 3 | (set-cdr! x 4) 4 | (display (cdr x)) 5 | (newline) 6 | -------------------------------------------------------------------------------- /tests/succeed/set-global.expected: -------------------------------------------------------------------------------- 1 | 1 -------------------------------------------------------------------------------- /tests/succeed/set-global.scm: -------------------------------------------------------------------------------- 1 | (define *x* 0) 2 | 3 | ; Any one of the following crashes the picobit compiler: 4 | 5 | (let ((x 1)) (set! *x* x)) 6 | 7 | ((lambda () (set! *x* 1))) 8 | 9 | (define (picobit-crashes) (set! *x* 1)) 10 | (picobit-crashes) 11 | 12 | (display *x*) 13 | -------------------------------------------------------------------------------- /tests/succeed/shadowing.expected: -------------------------------------------------------------------------------- 1 | 2 2 | 6 3 | -------------------------------------------------------------------------------- /tests/succeed/shadowing.scm: -------------------------------------------------------------------------------- 1 | (let ([+ -]) 2 | (displayln (+ 4 2))) 3 | (displayln (+ 4 2)) 4 | -------------------------------------------------------------------------------- /tests/succeed/string.expected: -------------------------------------------------------------------------------- 1 | abc4 2 | -------------------------------------------------------------------------------- /tests/succeed/string.scm: -------------------------------------------------------------------------------- 1 | ;; tests with strings 2 | 3 | (define (foo x) 4 | (+ (string-length x) 1)) 5 | 6 | (display "abc") 7 | (display (foo "abc")) 8 | (newline) 9 | -------------------------------------------------------------------------------- /tests/succeed/sub.expected: -------------------------------------------------------------------------------- 1 | #t 2 | #t 3 | #t 4 | #t 5 | #t 6 | #t 7 | #t 8 | #t 9 | -------------------------------------------------------------------------------- /tests/succeed/sub.scm: -------------------------------------------------------------------------------- 1 | (displayln (= (- 2 2) 0)) 2 | (displayln (= (- 5 3) 2)) 3 | (displayln (= (- 5 7) -2)) 4 | (displayln (= (- 4 0) 4)) 5 | (displayln (= (- 0 4) -4)) 6 | (displayln (= (- 2 -2) 4)) 7 | (displayln (= (- -2 -5) 3)) 8 | (displayln (= (- -5 -2) -3)) 9 | -------------------------------------------------------------------------------- /tests/succeed/substring.expected: -------------------------------------------------------------------------------- 1 | ob -------------------------------------------------------------------------------- /tests/succeed/substring.scm: -------------------------------------------------------------------------------- 1 | (display (substring "foobar" 2 4)) 2 | -------------------------------------------------------------------------------- /tests/succeed/symbolp.expected: -------------------------------------------------------------------------------- 1 | #f -------------------------------------------------------------------------------- /tests/succeed/symbolp.scm: -------------------------------------------------------------------------------- 1 | (display (not (symbol? 'a))) 2 | -------------------------------------------------------------------------------- /tests/succeed/u8-copy.expected: -------------------------------------------------------------------------------- 1 | 0 1 2 3 4 5 2 | 10 11 12 1 2 3 4 17 18 19 3 | 20 21 20 21 12 1 2 3 4 29 4 | -------------------------------------------------------------------------------- /tests/succeed/u8-copy.scm: -------------------------------------------------------------------------------- 1 | ;; test for the 2 cases of vector copy 2 | ;; TODO error case ? 3 | (define x '#u8(0 1 2 3 4 5)) 4 | (define y (u8vector 10 11 12 13 14 15 16 17 18 19)) 5 | (define z (u8vector 20 21 22 23 24 25 26 27 28 29)) 6 | 7 | (define (display-vector v) 8 | (let loop ((i 0)) 9 | (if (< i (u8vector-length v)) 10 | (begin (display (u8vector-ref v i)) 11 | (display " ") 12 | (loop (+ i 1))))) 13 | (display "\n")) 14 | 15 | ;; (display-vector x) 16 | ;; (display-vector y) 17 | ;; (display-vector z) 18 | 19 | (u8vector-copy! x 1 y 3 4) 20 | (u8vector-copy! y 2 z 4 5) 21 | (u8vector-copy! z 0 z 2 2) 22 | (display-vector x) 23 | (display-vector y) 24 | (display-vector z) 25 | -------------------------------------------------------------------------------- /tests/succeed/u8-gc-compact.expected: -------------------------------------------------------------------------------- 1 | DONE 2 | 67 3 | (194 144 94 44 250 200 150 100 50 3) 4 | -------------------------------------------------------------------------------- /tests/succeed/u8-gc-compact.scm: -------------------------------------------------------------------------------- 1 | ;; test that should trigger vector heap compaction 2 | 3 | ;; this allocation pattern should cause compaction: 4 | ;; vector of size 1, size 2, size 3, etc. dropping each of these right away 5 | ;; by the time we fill up the vector space, say when allocating for size n, 6 | ;; the heap will be full of blocks of size at most n-1 7 | ;; gc will be triggered, all the smaller vectors will be freed, but the 8 | ;; heap will be too fragmented to accomodate a vector of size n, triggering 9 | ;; compaction 10 | ;; if gc triggers before vector space is full, that's fine too. none of the 11 | ;; freed blocks will be reusable, since they will all be too small for the 12 | ;; next vector to be allocated 13 | 14 | ;; for a 32k vector heap, 300 vectors should be enough 15 | (define l (list (make-u8vector 30 3))) 16 | (define x (make-u8vector 30 67)) 17 | (define (loop i v) 18 | (if (< i 500) 19 | (let ([v2 (make-u8vector i (modulo i 256))]) 20 | (if (= (modulo i 50) 0) ; save some, to not always free everything 21 | (set! l (cons v2 l))) 22 | (if (not (= (u8vector-ref v2 (- i 1)) (modulo i 256))) 23 | (displayln "BAD")) 24 | (loop (+ i 1) v2)))) 25 | (loop 1 (make-u8vector 1 3)) 26 | (displayln "DONE") 27 | (displayln (u8vector-ref x 17)) 28 | (displayln (map (lambda (x) (u8vector-ref x 0)) l)) 29 | -------------------------------------------------------------------------------- /tests/succeed/u8-gc.expected: -------------------------------------------------------------------------------- 1 | DONE 2 | 56 3 | -------------------------------------------------------------------------------- /tests/succeed/u8-gc.scm: -------------------------------------------------------------------------------- 1 | (define x (make-u8vector 2 56)) 2 | (let loop ((i 0)) 3 | (if (< i 10000) 4 | (begin (if (not (= (u8vector-ref (u8vector 1 2 3) 2) 3)) 5 | (displayln "BAD!")) 6 | (loop (+ i 1))))) 7 | (displayln "DONE") 8 | (displayln (u8vector-ref x 1)) 9 | -------------------------------------------------------------------------------- /tests/succeed/u8.expected: -------------------------------------------------------------------------------- 1 | 63 2 | 83 3 | 53 4 | #t#f#t#t 5 | -------------------------------------------------------------------------------- /tests/succeed/u8.scm: -------------------------------------------------------------------------------- 1 | (define x (u8vector 2 3 4)) 2 | (define y '#u8(6 7 8)) 3 | (define z (make-u8vector 3 7)) 4 | (display (+ (u8vector-ref x 2) 2)) 5 | (display (u8vector-length x)) 6 | (display "\n") 7 | (display (u8vector-ref y 2)) 8 | (display (u8vector-length y)) 9 | (display "\n") 10 | (u8vector-set! z 2 5) 11 | (display (u8vector-ref z 2)) 12 | (display (u8vector-length z)) 13 | (display "\n") 14 | (display (equal? '#u8(0 1 2) '#u8(0 1 2))) 15 | (display (equal? '#u8(0 1 2) '#u8(0 1 3))) 16 | (display (equal? '#u8(0 1 2) (u8vector 0 1 2))) 17 | (display (equal? (u8vector 0 1 2) (u8vector 0 1 2))) 18 | (display "\n") 19 | -------------------------------------------------------------------------------- /tests/succeed/var-chain.expected: -------------------------------------------------------------------------------- 1 | 3 2 | -------------------------------------------------------------------------------- /tests/succeed/var-chain.scm: -------------------------------------------------------------------------------- 1 | (define (f) 2 | (let ([x 3]) 3 | (let ([y x]) 4 | (let ([z y]) 5 | z)))) 6 | (displayln (f)) 7 | -------------------------------------------------------------------------------- /tests/succeed/vector.expected: -------------------------------------------------------------------------------- 1 | 6 2 | 15 3 | 3 4 | 7 5 | 10 6 | -------------------------------------------------------------------------------- /tests/succeed/vector.scm: -------------------------------------------------------------------------------- 1 | (define x '#(2 4 6 8 9)) 2 | (displayln (vector-ref x 2)) 3 | (displayln (bitwise-xor (vector-ref x 2) (vector-ref x 4))) 4 | (define y (vector 1 2 3 4)) 5 | (displayln (vector-ref y 2)) 6 | (vector-set! y 2 7) 7 | (displayln (vector-ref y 2)) 8 | (displayln (+ (car x) (vector-ref x 1) (vector-ref y 3))) 9 | -------------------------------------------------------------------------------- /tests/succeed/xor.expected: -------------------------------------------------------------------------------- 1 | #t 2 | #t 3 | #t 4 | #t 5 | #t 6 | #t 7 | #t 8 | #t 9 | -------------------------------------------------------------------------------- /tests/succeed/xor.scm: -------------------------------------------------------------------------------- 1 | ;; bitwise xor tests 2 | 3 | (displayln (= (bitwise-xor #xf0 #x0f) #xff)) 4 | (displayln (= (bitwise-xor #x30 #x00) #x30)) 5 | (displayln (= (bitwise-xor #x00 #x05) #x05)) 6 | (displayln (= (bitwise-xor #x08 #x05) #x0D)) 7 | (displayln (= (bitwise-xor #x18 #x05) #x1D)) 8 | (displayln (= (bitwise-xor #x18 #x25) #x3D)) 9 | (displayln (= (bitwise-xor #x18 #x35) #x2D)) 10 | (displayln (= (bitwise-xor #xF7 #xDD) #x2A)) 11 | -------------------------------------------------------------------------------- /vm/.config: -------------------------------------------------------------------------------- 1 | # 2 | # Automatically generated make config: don't edit 3 | # Picobit Virtual Machine Configuration 4 | # Thu Aug 25 23:06:36 2011 5 | # 6 | CONFIG_ARCH_HOST=y 7 | # CONFIG_ARCH_ARM is not set 8 | CONFIG_ERROR_HANDLING=y 9 | CONFIG_DEBUG_STRINGS=y 10 | CONFIG_ARCH_32BIT=y 11 | CONFIG_ARCH="host" 12 | # CONFIG_BIGNUM_FIXED is not set 13 | CONFIG_BIGNUM_LONG=y 14 | # CONFIG_VM_DEBUG is not set 15 | # CONFIG_GC_STATISTICS is not set 16 | # CONFIG_GC_DEBUG is not set 17 | -------------------------------------------------------------------------------- /vm/.gitignore: -------------------------------------------------------------------------------- 1 | .config.old 2 | include/arch 3 | picobit-vm 4 | picobit.hex 5 | picobit.elf 6 | .primitives.p 7 | -------------------------------------------------------------------------------- /vm/Kconfig: -------------------------------------------------------------------------------- 1 | mainmenu "Picobit Virtual Machine Configuration" 2 | 3 | choice 4 | prompt "Target architecture" 5 | help 6 | Select a platform to run Picobit VM on. 7 | 8 | 9 | config ARCH_HOST 10 | bool "Host executable" 11 | select ARCH_32BIT 12 | select ERROR_HANDLING 13 | select DEBUG_STRINGS 14 | help 15 | Build Picobit as a host (Linux) executable for easy 16 | debugging. 17 | 18 | 19 | config ARCH_ARM 20 | bool "ARM microcontrollers" 21 | select ARCH_32BIT 22 | endchoice 23 | 24 | config ERROR_HANDLING 25 | bool 26 | 27 | config DEBUG_STRINGS 28 | bool 29 | 30 | config ARCH_8BIT 31 | bool 32 | 33 | config ARCH_32BIT 34 | bool 35 | 36 | config ARCH 37 | string 38 | default "host" if ARCH_HOST 39 | default "arm" if ARCH_ARM 40 | 41 | if ARCH_HOST 42 | source "arch/host/Kconfig" 43 | endif 44 | 45 | if ARCH_ARM 46 | source "arch/arm/Kconfig" 47 | endif 48 | 49 | source "core/Kconfig" 50 | -------------------------------------------------------------------------------- /vm/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: 3 | 4 | Makefile: ; 5 | 6 | no-dot-config-targets := clean mrproper help 7 | 8 | config-targets := 0 9 | mixed-targets := 0 10 | dot-config := 1 11 | 12 | ifneq ($(filter $(no-dot-config-targets), $(MAKECMDGOALS)),) 13 | ifeq ($(filter-out $(no-dot-config-targets), $(MAKECMDGOALS)),) 14 | dot-config := 0 15 | endif 16 | endif 17 | 18 | ifneq ($(filter config %config,$(MAKECMDGOALS)),) 19 | config-targets := 1 20 | ifneq ($(filter-out config %config,$(MAKECMDGOALS)),) 21 | mixed-targets := 1 22 | endif 23 | endif 24 | 25 | ifeq ($(mixed-targets),1) 26 | # We're called with mixed targets (*config and build targets). 27 | # Handle them one by one. 28 | 29 | %:: FORCE 30 | make $@ 31 | 32 | else 33 | ifeq ($(config-targets),1) 34 | # *config targets only - make sure prerequisites are updated, and descend 35 | # in scripts/kconfig to make the *config target 36 | 37 | .PHONY: config_generated 38 | config_generated: 39 | mkdir -p include/config include/generated 40 | 41 | nconfig: config_generated FORCE 42 | make -C kconfig nconf 43 | ./kconfig/nconf Kconfig 44 | 45 | config: config_generated FORCE 46 | make -C kconfig conf 47 | ./kconfig/conf Kconfig 48 | 49 | %config: config_generated FORCE 50 | make -C kconfig conf 51 | ./kconfig/conf --$@ Kconfig 52 | 53 | else 54 | # Build targets only -- generally all targets except *config targets. 55 | 56 | ifneq ($(dot-config),0) 57 | 58 | # Used to fix quoted Kconfig variables 59 | unquote = $(patsubst "%,%,$(patsubst %",%,$(1))) 60 | 61 | # Read in config 62 | include include/config/auto.conf 63 | 64 | # Read in dependencies to all Kconfig* files, make sure to run 65 | # oldconfig if changes are detected. 66 | include include/config/auto.conf.cmd 67 | 68 | # To avoid any implicit rule to kick in, define an empty command 69 | .config include/config/auto.conf.cmd: ; 70 | 71 | # If .config is newer than include/config/auto.conf, someone tinkered 72 | # with it and forgot to run make oldconfig. 73 | # if auto.conf.cmd is missing then we are probably in a cleaned tree so 74 | # we execute the config step to be sure to catch updated Kconfig files 75 | include/config/%.conf: .config include/config/auto.conf.cmd 76 | make silentoldconfig 77 | 78 | include/arch: include/config/auto.conf 79 | @rm -f include/arch 80 | @ln -sf ../$(arch)/include/ include/arch 81 | 82 | CROSS := $(call unquote,$(CONFIG_CROSS_COMPILER)) 83 | CFLAGS := -Iinclude/ -DPICOBIT -Wall -Werror -Os 84 | 85 | arch = arch/$(call unquote,$(CONFIG_ARCH)) 86 | # Some linkers may have trouble with this order. Put arch first if 87 | # your linker cannot use linker scripts or is limited in other ways. 88 | obj-y = $(addprefix core/,$(core-y)) \ 89 | $(addprefix $(arch)/,$(arch-y)) 90 | scm-y = $(addprefix $(arch)/,$(stdlib-y)) 91 | 92 | .PHONY: arch-all 93 | arch-all: 94 | 95 | include core/Makefile 96 | include arch/Makefile 97 | 98 | prim-gen = gawk -f scripts/scanner.awk -f scripts/prim-$(1).awk \ 99 | .primitives.p >$(2) 100 | 101 | .primitives.p: include/arch $(obj-y) 102 | rm -f $@ 103 | for object in $(obj-y); do \ 104 | $(CROSS)cpp -DNO_PRIMITIVE_EXPAND $(CFLAGS) \ 105 | $$object -o - >>$@; \ 106 | done 107 | $(call prim-gen,headergen,include/gen.primitives.h) 108 | $(call prim-gen,schemegen,../compiler/gen.primitives.rkt) 109 | $(call prim-gen,dispatchgen,core/gen.dispatch.c) 110 | 111 | .PHONY: ../compiler/gen.config.rkt 112 | ../compiler/gen.config.rkt: 113 | @echo "#lang racket" >$@ 114 | @echo "" >>$@ 115 | @echo "(define code-start $(load-address))" >>$@ 116 | @echo "(provide code-start)" >>$@ 117 | 118 | ../compiler/gen.library.scm: $(arch)/Makefile 119 | for scm in $(scm-y); do \ 120 | echo "(include \"vm/$${scm}\")" >>$@; \ 121 | done 122 | 123 | all: include/arch .primitives.p ../compiler/gen.config.rkt \ 124 | ../compiler/gen.library.scm arch-all 125 | 126 | endif # $(dot-config) 127 | 128 | endif # $(config-targets) 129 | endif # $(mixed-targets) 130 | 131 | clean: FORCE 132 | rm -f include/arch picobit-vm picobit.elf picobit.hex \ 133 | .primitives.p ../compiler/gen.* include/gen.* \ 134 | core/gen.* 135 | 136 | mrproper: clean FORCE 137 | make -C kconfig clean 138 | rm -f .config .config.old 139 | rm -rf include/config include/generated 140 | 141 | help: 142 | @echo "Picobit Virtual Machine" 143 | @echo " Picobit uses Kconfig for configuring its VM build" 144 | @echo " process. Configuration options are mostly same." 145 | @echo 146 | @echo "Configuration:" 147 | @echo " config: command-line configurator" 148 | @echo " nconfig: ncurses-based configurator" 149 | @echo " oldconfig: update configuration using current .config as base" 150 | @echo " silentoldconfig: same as oldconfig, but do not ask about new options" 151 | @echo 152 | @echo "Building:" 153 | @echo " all: build everything" 154 | @echo 155 | @echo "Cleaning:" 156 | @echo " clean: remove intermediate files" 157 | @echo " mrproper: remove intermediate files and configuration" 158 | 159 | .PHONY: FORCE 160 | -------------------------------------------------------------------------------- /vm/arch/Makefile: -------------------------------------------------------------------------------- 1 | ifdef CONFIG_ARCH_HOST 2 | arch := arch/host 3 | include arch/host/Makefile 4 | endif 5 | 6 | ifdef CONFIG_ARCH_ARM 7 | arch := arch/arm 8 | include arch/arm/Makefile 9 | endif 10 | -------------------------------------------------------------------------------- /vm/arch/arm/Kconfig: -------------------------------------------------------------------------------- 1 | config CROSS_COMPILER 2 | string "Cross compiler prefix" 3 | default "arm-none-eabi-" 4 | 5 | choice 6 | prompt "Processor core type" 7 | 8 | config ARM_CORTEX_M3 9 | bool "Cortex-M3" 10 | endchoice 11 | 12 | if ARM_CORTEX_M3 13 | source "arch/arm/cortex-m3/Kconfig" 14 | endif 15 | -------------------------------------------------------------------------------- /vm/arch/arm/Makefile: -------------------------------------------------------------------------------- 1 | ifdef CONFIG_ARM_CORTEX_M3 2 | arch := $(arch)/cortex-m3 3 | endif 4 | 5 | include $(arch)/Makefile -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/Kconfig: -------------------------------------------------------------------------------- 1 | choice 2 | prompt "Processor model" 3 | 4 | config ARM_CPU_STM32F100RB 5 | bool "ST STM32F100RB" 6 | endchoice 7 | 8 | choice 9 | prompt "Board name" 10 | 11 | config ARM_BOARD_STM32_VLDISCOVERY 12 | bool "STM32 VLDISCOVERY" 13 | endchoice 14 | -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/Makefile: -------------------------------------------------------------------------------- 1 | ifdef CONFIG_ARM_CPU_STM32F100RB 2 | ldscript := stm32f100rb.ld 3 | endif 4 | 5 | CFLAGS += -mcpu=cortex-m3 -mthumb -g -fno-hosted -nostdlib \ 6 | -L$(arch)/lib -T$(ldscript) -Wl,-warn-common 7 | 8 | arch-y += init.s 9 | 10 | arch-$(CONFIG_ARM_BOARD_STM32_VLDISCOVERY) += board-vldiscovery.c 11 | stdlib-$(CONFIG_ARM_BOARD_STM32_VLDISCOVERY) += stdlib-vldiscovery.scm 12 | 13 | load-address := \#x8008000 14 | 15 | arch-all: picobit.hex 16 | 17 | picobit.hex: picobit.elf 18 | $(CROSS)objcopy -O ihex $^ $@ 19 | 20 | picobit.elf: $(obj-y) .config 21 | $(CROSS)cc $(CFLAGS) -o $@ $(obj-y) 22 | -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/board-vldiscovery.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | void halt_with_error () 9 | { 10 | GPIOC->ODR |= BIT(8); 11 | 12 | while(1); 13 | } 14 | 15 | PRIMITIVE_UNSPEC(#%sleep, arch_sleep, 1) 16 | { 17 | static int a, b; 18 | 19 | a1 = decode_int (arg1); 20 | 21 | for(a = 0; a < a1; a++) { 22 | for(b = 0; b < 100; b++) { 23 | __asm__ __volatile__("nop"); 24 | } 25 | } 26 | 27 | arg1 = OBJ_FALSE; 28 | } 29 | 30 | PRIMITIVE_UNSPEC(#%set-led!, arch_set_led, 1) 31 | { 32 | if (arg1 == OBJ_FALSE) { 33 | GPIOC->ODR &= ~BIT(9); 34 | } else { 35 | GPIOC->ODR |= BIT(9); 36 | } 37 | 38 | arg1 = OBJ_FALSE; 39 | } 40 | 41 | void main () 42 | { 43 | RCC->APB2ENR |= IOPCEN; 44 | GPIOC->CRH = 0x44444411; 45 | 46 | interpreter(); 47 | } 48 | -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/include/memory.h: -------------------------------------------------------------------------------- 1 | #ifndef PICOBIT_ARCH_ARM_CORTEX_M3_MEMORY_H 2 | #define PICOBIT_ARCH_ARM_CORTEX_M3_MEMORY_H 3 | 4 | #define CODE_START 0x8000 5 | 6 | extern uint8 __picobit_heap; 7 | 8 | #define ram_get(a) ((uint8*)&__picobit_heap)[a] 9 | #define ram_set(a,x) ((uint8*)&__picobit_heap)[a] = (x) 10 | 11 | #define rom_get(a) (((uint8*) 0)[a]) 12 | 13 | #endif 14 | -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/include/stm32/afio.h: -------------------------------------------------------------------------------- 1 | #ifndef _STM32_AFIO_H_ 2 | #define _STM32_AFIO_H_ 3 | 4 | #include 5 | 6 | struct regs_AFIO { 7 | reg EVCR; 8 | #define EVOE BIT(7) 9 | #define R_PORT(v) R_BITS(v, 4, 6) 10 | #define W_PORT(v, x) W_BITS(v, x, 4, 6) 11 | #define PORT(x) BITS(v, 4, 6) 12 | #define R_PIN(v) R_BITS(v, 0, 3) 13 | #define W_PIN(v, x) W_BITS(v, x, 0, 3) 14 | #define PIN(x) BITS(x, 0, 3) 15 | reg MAPR; 16 | #define R_SWJ_CFG(v) R_BITS(v, 24, 26) 17 | #define W_SWJ_CFG(v, x) W_BITS(v, x, 24, 26) 18 | #define SWJ_CFG(x) BITS(x, 24, 26) 19 | #define SWJ_CFG_SWJ 0 20 | #define SWJ_CFG_SWJ_NRST 1 21 | #define SWJ_CFG_SW 2 22 | #define SWJ_CFG_NONE 4 23 | #define TIM5CH4_IREMAP BIT(16) 24 | #define PD01_REMAP BIT(15) 25 | #define TIM4_REMAP BIT(12) 26 | #define R_TIM3_REMAP(v) R_BITS(v, 10, 11) 27 | #define W_TIM3_REMAP(v, x) W_BITS(v, x, 10, 11) 28 | #define TIM3_REMAP(x) BITS(x, 10, 11) 29 | #define R_TIM2_REMAP(v) R_BITS(v, 8, 9) 30 | #define W_TIM2_REMAP(v, x) W_BITS(v, x, 8, 9) 31 | #define TIM2_REMAP(x) BITS(x, 8, 9) 32 | #define R_TIM1_REMAP(v) R_BITS(v, 6, 7) 33 | #define W_TIM1_REMAP(v, x) W_BITS(v, x, 6, 7) 34 | #define TIM1_REMAP(x) BITS(x, 6, 7) 35 | #define R_USART3_REMAP(v) R_BITS(v, 4, 5) 36 | #define W_USART3_REMAP(v, x) W_BITS(v, x, 4, 5) 37 | #define USART3_REMAP(x) BITS(x, 4, 5) 38 | #define USART2_REMAP BIT(3) 39 | #define USART1_REMAP BIT(2) 40 | #define I2C1_REMAP BIT(1) 41 | #define SPI1_REMAP BIT(0) 42 | reg EXTICR1; 43 | reg EXTICR2; 44 | reg EXTICR3; 45 | reg EXTICR4; 46 | reg MAPR2; 47 | #define MISC_REMAP BIT(13) 48 | #define TIM12_REMAP BIT(12) 49 | #define TIM76_DAC_DMA_REMAP BIT(11) 50 | #define FSMC_NADV BIT(10) 51 | #define TIM14_REMAP BIT(9) 52 | #define TIM13_REMAP BIT(8) 53 | #define TIM1_DMA_REMAP BIT(4) 54 | #define CEC_REMAP BIT(3) 55 | #define TIM17_REMAP BIT(2) 56 | #define TIM16_REMAP BIT(1) 57 | #define TIM15_REMAP BIT(0) 58 | }; 59 | 60 | CONFIG_AREA(regs_AFIO, AFIO, 0x40010000); 61 | 62 | #endif -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/include/stm32/bits.h: -------------------------------------------------------------------------------- 1 | #ifndef _BITS_H_ 2 | #define _BITS_H_ 3 | 4 | typedef volatile unsigned int reg; 5 | typedef volatile unsigned short reg16; 6 | 7 | typedef unsigned int u32; 8 | typedef unsigned short u16; 9 | typedef unsigned char u8; 10 | 11 | typedef signed int s32; 12 | typedef signed short s16; 13 | typedef signed char s8; 14 | 15 | #define CONFIG_AREA(type, name, addr) \ 16 | static struct type* const name = (struct type*) addr; 17 | 18 | #define BIT(n) (1 << (n)) 19 | #define MASK(nbits) ((1 << (nbits)) - 1) 20 | 21 | #define BITS(x, s, e) (((x) & MASK(e - s + 1)) << s) 22 | #define R_BITS(v, s, e) (((v) & MASK(e - s + 1)) >> s) 23 | #define W_BITS(v, x, s, e) (v) = ((v) & ~(MASK(e - s + 1) << s)) | BITS(x, s, e) 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/include/stm32/gpio.h: -------------------------------------------------------------------------------- 1 | #ifndef _STM32_GPIO_H_ 2 | #define _STM32_GPIO_H_ 3 | 4 | #include 5 | 6 | struct regs_GPIO { 7 | reg CRL; 8 | reg CRH; 9 | reg IDR; 10 | reg ODR; 11 | reg BSRR; 12 | reg BRR; 13 | reg LCKR; 14 | }; 15 | 16 | CONFIG_AREA(regs_GPIO, GPIOA, 0x40010800); 17 | CONFIG_AREA(regs_GPIO, GPIOB, 0x40010C00); 18 | CONFIG_AREA(regs_GPIO, GPIOC, 0x40011000); 19 | CONFIG_AREA(regs_GPIO, GPIOD, 0x40011800); 20 | CONFIG_AREA(regs_GPIO, GPIOE, 0x40011C00); 21 | 22 | #endif -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/include/stm32/rcc.h: -------------------------------------------------------------------------------- 1 | #ifndef _STM32_RCC_H_ 2 | #define _STM32_RCC_H_ 3 | 4 | #include 5 | 6 | struct regs_RCC { 7 | reg CR; 8 | #define PLLRDY BIT(25) 9 | #define PLLON BIT(24) 10 | #define CSSON BIT(19) 11 | #define HSEBYP BIT(18) 12 | #define HSERDY BIT(17) 13 | #define HSEON BIT(16) 14 | #define R_HSICAL(v) R_BITS(v, 8, 15) 15 | #define W_HSICAL(v, x) W_BITS(v, x, 8, 15) 16 | #define HSICAL(x) BITS(x, 8, 15) 17 | #define R_HSITRIM(v) R_BITS(x, 3, 7) 18 | #define W_HSITRIM(v, x) W_BITS(v, x, 3, 7) 19 | #define HSITRIM(x) BITS(x, 3, 7) 20 | #define HSIRDY BIT(1) 21 | #define HSION BIT(0) 22 | reg CFGR; 23 | #define R_MCO(v) R_BITS(v, 24, 26) 24 | #define W_MCO(v, x) W_BITS(v, 24, 26) 25 | #define MCO(x) BITS(x, 24, 26) 26 | #define MCO_NONE 0 27 | #define MCO_SYSCLK 4 28 | #define MCO_HSI 5 29 | #define MCO_HSE 6 30 | #define MCO_PLL_DIV2 7 31 | #define R_PLLMUL(v) R_BITS(v, 18, 21) 32 | #define W_PLLMUL(v, x) W_BITS(v, x, 18, 21) 33 | #define PLLMUL(x) BITS(x, 18, 21) 34 | #define PLLXTPRE BIT(17) 35 | #define PLLSRC BIT(16) 36 | #define R_ADCPRE(v) R_BITS(v, 14, 15) 37 | #define W_ADCPRE(v, x) W_BITS(v, x, 14, 15) 38 | #define ADCPRE(x) BITS(x, 14, 15) 39 | #define R_PPRE2(v) R_BITS(v, 11, 13) 40 | #define W_PPRE2(v, x) W_BITS(v, x, 11, 13) 41 | #define PPRE2(x) BITS(x, 11, 13) 42 | #define R_PPRE1(v) R_BITS(v, 8, 10) 43 | #define W_PPRE1(v, x) W_BITS(v, x, 8, 10) 44 | #define PPRE1(x) BITS(x, 8, 10) 45 | #define R_HPRE(v) R_BITS(v, 4, 7) 46 | #define W_HPRE(v, x) W_BITS(v, x, 4, 7) 47 | #define HPRE(x) BITS(x, 4, 7) 48 | #define R_SWS(v) R_BITS(v, 2, 3) 49 | #define SWS_HSI 0 50 | #define SWS_HSE 1 51 | #define SWS_PLL 2 52 | #define R_SW(v) R_BITS(v, 0, 1) 53 | #define W_SW(v, x) W_BITS(v, x, 0, 1) 54 | #define SW(x) BITS(x, 0, 1) 55 | #define SW_HSI 0 56 | #define SW_HSE 1 57 | #define SW_PLL 2 58 | reg CIR; 59 | #define CSSC BIT(23) 60 | #define PLLRDYC BIT(20) 61 | #define HSERDYC BIT(19) 62 | #define HSIRDYC BIT(18) 63 | #define LSERDYC BIT(17) 64 | #define LSIRDYC BIT(16) 65 | #define PLLRDYIE BIT(12) 66 | #define HSERDYIE BIT(11) 67 | #define HSIRDYIE BIT(10) 68 | #define LSERDYIE BIT(9) 69 | #define LSIRDYIE BIT(8) 70 | #define CSSF BIT(7) 71 | #define PLLRDYF BIT(4) 72 | #define HSERDYF BIT(3) 73 | #define HSIRDYF BIT(2) 74 | #define LSERDYF BIT(1) 75 | #define LSIRDYF BIT(0) 76 | reg APB2RSTR; 77 | #define TIM17RST BIT(18) 78 | #define TIM16RST BIT(17) 79 | #define TIM15RST BIT(16) 80 | #define USART1RST BIT(14) 81 | #define SPI1RST BIT(12) 82 | #define TIM1RST BIT(11) 83 | #define ADC1RST BIT(9) 84 | #define IOPGRST BIT(8) 85 | #define IOPFRST BIT(7) 86 | #define IOPERST BIT(6) 87 | #define IOPDRST BIT(5) 88 | #define IOPCRST BIT(4) 89 | #define IOPBRST BIT(3) 90 | #define IOPARST BIT(2) 91 | #define AFIORST BIT(0) 92 | reg APB1RSTR; 93 | #define CECRST BIT(30) 94 | #define DACRST BIT(29) 95 | #define PWRRST BIT(28) 96 | #define BKPRST BIT(27) 97 | #define I2C2RST BIT(22) 98 | #define I2C1RST BIT(21) 99 | #define UART5RST BIT(20) 100 | #define UART4RST BIT(19) 101 | #define USART3RST BIT(18) 102 | #define USART2RST BIT(17) 103 | #define SPI3RST BIT(15) 104 | #define SPI2RST BIT(14) 105 | #define WWDGRST BIT(11) 106 | #define TIM14RST BIT(8) 107 | #define TIM13RST BIT(7) 108 | #define TIM12RST BIT(6) 109 | #define TIM7RST BIT(5) 110 | #define TIM6RST BIT(4) 111 | #define TIM5RST BIT(3) 112 | #define TIM4RST BIT(2) 113 | #define TIM3RST BIT(1) 114 | #define TIM2RST BIT(0) 115 | reg AHBENR; 116 | #define FMSCEN BIT(8) 117 | #define CRCEN BIT(6) 118 | #define FLITFEN BIT(4) 119 | #define SRAMEN BIT(2) 120 | #define DMA2EN BIT(1) 121 | #define DMA1EN BIT(0) 122 | reg APB2ENR; 123 | #define TIM17EN BIT(18) 124 | #define TIM16EN BIT(17) 125 | #define TIM15EN BIT(16) 126 | #define USART1EN BIT(14) 127 | #define SPI1EN BIT(12) 128 | #define TIM1EN BIT(11) 129 | #define ADC1EN BIT(9) 130 | #define IOPGEN BIT(8) 131 | #define IOPFEN BIT(7) 132 | #define IOPEEN BIT(6) 133 | #define IOPDEN BIT(5) 134 | #define IOPCEN BIT(4) 135 | #define IOPBEN BIT(3) 136 | #define IOPAEN BIT(2) 137 | #define AFIOEN BIT(0) 138 | reg APB1ENR; 139 | #define CECEN BIT(30) 140 | #define DACEN BIT(29) 141 | #define PWREN BIT(28) 142 | #define BKPEN BIT(27) 143 | #define I2C2EN BIT(22) 144 | #define I2C1EN BIT(21) 145 | #define UART5EN BIT(20) 146 | #define UART4EN BIT(19) 147 | #define USART3EN BIT(18) 148 | #define USART2EN BIT(17) 149 | #define SPI3EN BIT(15) 150 | #define SPI2EN BIT(14) 151 | #define WWDGEN BIT(11) 152 | #define TIM14EN BIT(8) 153 | #define TIM13EN BIT(7) 154 | #define TIM12EN BIT(6) 155 | #define TIM7EN BIT(5) 156 | #define TIM6EN BIT(4) 157 | #define TIM5EN BIT(3) 158 | #define TIM4EN BIT(2) 159 | #define TIM3EN BIT(1) 160 | #define TIM2EN BIT(0) 161 | reg BDCR; 162 | #define BDRST BIT(16) 163 | #define RTCEN BIT(15) 164 | #define R_RTCSEL(v) R_BITS(v, 8, 9) 165 | #define W_RTCSEL(v, x) W_BITS(v, x, 8, 9) 166 | #define RTCSEL(x) BITS(x, 8, 9) 167 | #define RTCSEL_NONE 0 168 | #define RTCSEL_LSI 1 169 | #define RTCSEL_LSE 2 170 | #define RTCSEL_HSE 3 171 | #define LSEBYP BIT(2) 172 | #define LSERDY BIT(1) 173 | #define LSEON BIT(0) 174 | reg CSR; 175 | #define LPWRRSTF BIT(31) 176 | #define WWDGRSTF BIT(30) 177 | #define IWDGRSTF BIT(29) 178 | #define SFTRSTF BIT(28) 179 | #define PORRSTF BIT(27) 180 | #define PINRSTF BIT(26) 181 | #define RWMF BIT(24) 182 | #define LSIRDY BIT(1) 183 | #define LSION BIT(0) 184 | reg CFGR2; 185 | #define R_PREDIV1(v) R_BITS(v, 0, 3) 186 | #define W_PREDIV1(v, x) W_BITS(v, x, 0, 3) 187 | #define PREDIV1(x) BITS(x, 0, 3) 188 | }; 189 | 190 | CONFIG_AREA(regs_RCC, RCC, 0x40021000); 191 | 192 | #endif 193 | -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/include/stm32/spi.h: -------------------------------------------------------------------------------- 1 | #ifndef _STM32_SPI_H_ 2 | #define _STM32_SPI_H_ 3 | 4 | #include 5 | 6 | struct regs_SPI { 7 | reg CR1; 8 | #define SPI_BIDIMODE BIT(15) 9 | #define SPI_BIDIOE BIT(14) 10 | #define SPI_CRCEN BIT(13) 11 | #define SPI_CRCNEXT BIT(12) 12 | #define SPI_DFF BIT(11) 13 | #define SPI_RXONLY BIT(10) 14 | #define SPI_SSM BIT(9) 15 | #define SPI_SSI BIT(8) 16 | #define SPI_LSBFIRST BIT(7) 17 | #define SPI_SPE BIT(6) 18 | #define SPI_R_BR(v) R_BITS(v, 3, 5) 19 | #define SPI_W_BR(v, x) W_BITS(v, x, 3, 5) 20 | #define SPI_BR(x) BITS(x, 3, 5) 21 | #define SPI_MSTR BIT(2) 22 | #define SPI_CPOL BIT(1) 23 | #define SPI_CPHA BIT(0) 24 | reg CR2; 25 | #define SPI_TXEIE BIT(7) 26 | #define SPI_RXNEIE BIT(6) 27 | #define SPI_ERRIE BIT(5) 28 | #define SPI_SSOE BIT(2) 29 | #define SPI_TXDMAEN BIT(1) 30 | #define SPI_RXDMAEN BIT(0) 31 | reg SR; 32 | #define SPI_BSY BIT(7) 33 | #define SPI_OVR BIT(6) 34 | #define SPI_MODF BIT(5) 35 | #define SPI_CRCERR BIT(4) 36 | #define SPI_TXE BIT(1) 37 | #define SPI_RXNE BIT(0) 38 | reg DR; 39 | reg CRCPR; 40 | reg RXCRCR; 41 | reg TXCRCR; 42 | }; 43 | 44 | CONFIG_AREA(regs_SPI, SPI1, 0x40013000); 45 | CONFIG_AREA(regs_SPI, SPI2, 0x40003800); 46 | CONFIG_AREA(regs_SPI, SPI3, 0x40003C00); 47 | 48 | #endif -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/include/stm32/usart.h: -------------------------------------------------------------------------------- 1 | #ifndef _STM32_USART_H_ 2 | #define _STM32_USART_H_ 3 | 4 | #include 5 | 6 | struct regs_USART { 7 | reg SR; 8 | #define USART_CTS BIT(9) 9 | #define USART_LBD BIT(8) 10 | #define USART_TXE BIT(7) 11 | #define USART_TC BIT(6) 12 | #define USART_RXNE BIT(5) 13 | #define USART_IDLE BIT(4) 14 | #define USART_ORE BIT(3) 15 | #define USART_NF BIT(2) 16 | #define USART_FE BIT(1) 17 | #define USART_PE BIT(0) 18 | reg DR; 19 | reg BRR; 20 | reg CR1; 21 | #define USART_OVER8 BIT(15) 22 | #define USART_UE BIT(13) 23 | #define USART_M BIT(12) 24 | #define USART_WAKE BIT(11) 25 | #define USART_PCE BIT(10) 26 | #define USART_PS BIT(9) 27 | #define USART_PEIE BIT(8) 28 | #define USART_TXEIE BIT(7) 29 | #define USART_TCIE BIT(6) 30 | #define USART_RXNEIE BIT(5) 31 | #define USART_IDLEIE BIT(4) 32 | #define USART_TE BIT(3) 33 | #define USART_RE BIT(2) 34 | #define USART_RWU BIT(1) 35 | #define USART_SBK BIT(0) 36 | reg CR2; 37 | #define USART_LINEN BIT(14) 38 | #define USART_R_STOP(v) R_BITS(v, 12, 13) 39 | #define USART_W_STOP(v, x) W_BITS(v, x, 12, 13) 40 | #define USART_STOP(x) BITS(x, 12, 13) 41 | #define USART_CLKEN BIT(11) 42 | #define USART_CPOL BIT(10) 43 | #define USART_CPHA BIT(9) 44 | #define USART_LBCL BIT(8) 45 | #define USART_LBDIE BIT(6) 46 | #define USART_LBDL BIT(5) 47 | #define USART_R_ADD(v) R_BITS(v, 0, 3) 48 | #define USART_W_ADD(v, x) W_BITS(v, x, 0, 3) 49 | #define USART_ADD(x) BITS(x, 0, 3) 50 | reg CR3; 51 | #define USART_ONEBITE BIT(11) 52 | #define USART_CTSIE BIT(10) 53 | #define USART_CTSE BIT(9) 54 | #define USART_RTSE BIT(8) 55 | #define USART_DMAT BIT(7) 56 | #define USART_DMAR BIT(6) 57 | #define USART_SCEN BIT(5) 58 | #define USART_NACK BIT(4) 59 | #define USART_HDSEL BIT(3) 60 | #define USART_IRLP BIT(2) 61 | #define USART_IREN BIT(1) 62 | #define USART_EIE BIT(0 63 | reg GPTR; 64 | }; 65 | 66 | CONFIG_AREA(regs_USART, USART1, 0x40013800); 67 | CONFIG_AREA(regs_USART, USART2, 0x40004400); 68 | CONFIG_AREA(regs_USART, USART3, 0x40004800); 69 | 70 | #endif -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/include/types.h: -------------------------------------------------------------------------------- 1 | #ifndef PICOBIT_ARCH_ARM_CORTEX_M3_TYPES_H 2 | #define PICOBIT_ARCH_ARM_CORTEX_M3_TYPES_H 3 | 4 | /* Define Picobit basic types */ 5 | 6 | typedef unsigned char uint8; 7 | typedef unsigned short uint16; 8 | typedef unsigned int uint32; 9 | 10 | #endif -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/init.s: -------------------------------------------------------------------------------- 1 | .cpu cortex-m3 2 | .syntax unified 3 | .thumb 4 | 5 | .section .vectors, "xa", %progbits 6 | .globl __vector_table 7 | .type __vector_table, %function 8 | __vector_table: 9 | .word __stack_end__ /* initial SP value */ 10 | .word _startup /* next instruction in Thumb mode, fetch from flash */ 11 | 12 | .text 13 | .globl _startup 14 | .type _startup, %function 15 | _startup: 16 | /* Clear BSS */ 17 | eor r0, r0 18 | ldr r2, =__bss_begin__ 19 | ldr r3, =__bss_end__ 20 | 21 | 0: 22 | str r0, [r2], #4 23 | 24 | cmp r3, r2 25 | bhi 0b 26 | 27 | /* Jump to C code */ 28 | bl main 29 | 30 | /* Halt */ 31 | 0: b 0b 32 | 33 | .type __aeabi_unwind_cpp_pr0, %function 34 | .globl __aeabi_unwind_cpp_pr0 35 | __aeabi_unwind_cpp_pr0: 36 | bx lr 37 | -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/lib/common.ld: -------------------------------------------------------------------------------- 1 | OUTPUT_FORMAT(elf32-littlearm) 2 | ENTRY(_startup) 3 | 4 | SECTIONS { 5 | .vectors : { 6 | *(.vectors) 7 | } > vectors 8 | 9 | .text : { 10 | *(.text) 11 | 12 | . = ALIGN(4); 13 | 14 | *(.rodata) 15 | 16 | . = ALIGN(4); 17 | 18 | __text_end__ = .; 19 | } > flash 20 | 21 | .bss : { 22 | __stack_begin__ = .; 23 | 24 | . += 0x100; 25 | 26 | __stack_end__ = .; 27 | 28 | __bss_begin__ = .; 29 | 30 | *(.bss) 31 | *(COMMON) 32 | 33 | . = ALIGN(4); 34 | 35 | __bss_end__ = .; 36 | 37 | __picobit_heap = .; 38 | } > ram 39 | 40 | /DISCARD/ : { 41 | *(.comment) 42 | *(.ARM.attributes) 43 | } 44 | } 45 | -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/lib/stm32f100rb.ld: -------------------------------------------------------------------------------- 1 | MEMORY 2 | { 3 | vectors (RX) : ORIGIN = 0x08000000, LENGTH = 0x100 4 | flash (RX) : ORIGIN = 0x08000100, LENGTH = 0x20000 - 0x100 5 | ram (RWX) : ORIGIN = 0x20000000, LENGTH = 0x2000 6 | } 7 | 8 | INCLUDE common.ld 9 | -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/stdlib-vldiscovery.scm: -------------------------------------------------------------------------------- 1 | (define set-led! 2 | (lambda (value) 3 | (#%set-led! value))) 4 | -------------------------------------------------------------------------------- /vm/arch/host/Kconfig: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stamourv/picobit/bde85aa193964b7151f2d0eb39d47058d4298fc6/vm/arch/host/Kconfig -------------------------------------------------------------------------------- /vm/arch/host/Makefile: -------------------------------------------------------------------------------- 1 | arch-y += entry.c primitives.c 2 | stdlib-y += stdlib.scm 3 | 4 | load-address := \#x8000 5 | 6 | arch-all: picobit-vm 7 | 8 | picobit-vm: $(obj-y) .config 9 | cc $(CFLAGS) -g -o $@ $(obj-y) 10 | -------------------------------------------------------------------------------- /vm/arch/host/entry.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | uint8 ram_mem[RAM_BYTES + VEC_BYTES] = {0}, rom_mem[ROM_BYTES] = {0}; 9 | 10 | void error (char *prim, char *msg) 11 | { 12 | fprintf (stderr, "ERROR: %s: %s\n", prim, msg); 13 | exit (1); 14 | } 15 | 16 | void type_error (char *prim, char *type) 17 | { 18 | fprintf (stderr, "ERROR: %s: An argument of type %s was expected\n", 19 | prim, type); 20 | exit (1); 21 | } 22 | 23 | void write_hex_nibble (int n) 24 | { 25 | putchar ("0123456789ABCDEF"[n]); 26 | } 27 | 28 | void write_hex (uint8 n) 29 | { 30 | write_hex_nibble (n >> 4); 31 | write_hex_nibble (n & 0x0f); 32 | } 33 | 34 | int hex (int c) 35 | { 36 | if (c >= '0' && c <= '9') { 37 | return (c - '0'); 38 | } 39 | 40 | if (c >= 'A' && c <= 'F') { 41 | return (c - 'A' + 10); 42 | } 43 | 44 | if (c >= 'a' && c <= 'f') { 45 | return (c - 'a' + 10); 46 | } 47 | 48 | return -1; 49 | } 50 | 51 | int read_hex_byte (FILE *f) 52 | { 53 | int h1 = hex (fgetc (f)); 54 | int h2 = hex (fgetc (f)); 55 | 56 | if (h1 >= 0 && h2 >= 0) { 57 | return (h1<<4) + h2; 58 | } 59 | 60 | return -1; 61 | } 62 | 63 | int read_hex_file (char *filename) 64 | { 65 | int c; 66 | FILE *f = fopen (filename, "r"); 67 | int result = 0; 68 | int len; 69 | int a, a1, a2; 70 | int t; 71 | int b; 72 | int i; 73 | uint8 sum; 74 | int hi16 = 0; 75 | 76 | for (i=0; i= 0 && adr < ROM_BYTES) { 110 | rom_mem[adr] = b; 111 | } 112 | 113 | a = (a + 1) & 0xffff; 114 | i++; 115 | sum += b; 116 | 117 | goto next0; 118 | } 119 | } else if (t == 1) { 120 | if (len != 0) { 121 | break; 122 | } 123 | } else if (t == 4) { 124 | if (len != 2) { 125 | break; 126 | } 127 | 128 | if ((a1 = read_hex_byte (f)) < 0 || 129 | (a2 = read_hex_byte (f)) < 0) { 130 | break; 131 | } 132 | 133 | sum += a1 + a2; 134 | 135 | hi16 = (a1<<8) + a2; 136 | } else { 137 | break; 138 | } 139 | 140 | if ((b = read_hex_byte (f)) < 0) { 141 | break; 142 | } 143 | 144 | sum = -sum; 145 | 146 | if (sum != b) { 147 | printf ("*** HEX file checksum error (expected 0x%02x)\n", sum); 148 | break; 149 | } 150 | 151 | c = fgetc (f); 152 | 153 | if ((c != '\r') && (c != '\n')) { 154 | break; 155 | } 156 | 157 | if (t == 1) { 158 | result = 1; 159 | break; 160 | } 161 | } 162 | 163 | if (result == 0) { 164 | printf ("*** HEX file syntax error\n"); 165 | } 166 | 167 | fclose (f); 168 | } 169 | 170 | return result; 171 | } 172 | 173 | void usage () 174 | { 175 | printf ("usage: sim file.hex\n"); 176 | exit (1); 177 | } 178 | 179 | int main (int argc, char *argv[]) 180 | { 181 | int errcode = 0; 182 | 183 | if (argc != 2) { 184 | usage (); 185 | } 186 | 187 | if (!read_hex_file (argv[1])) { 188 | printf ("*** Could not read hex file \"%s\"\n", argv[1]); 189 | } else { 190 | if (rom_get (CODE_START+0) != 0xfb || 191 | rom_get (CODE_START+1) != 0xd7) { 192 | printf ("*** The hex file was not compiled with PICOBIT\n"); 193 | } else { 194 | interpreter (); 195 | 196 | #ifdef CONFIG_GC_DEBUG 197 | printf ("**************** memory needed = %d\n", max_live + 1); 198 | #endif 199 | } 200 | } 201 | 202 | return errcode; 203 | } 204 | -------------------------------------------------------------------------------- /vm/arch/host/include/memory.h: -------------------------------------------------------------------------------- 1 | #ifndef PICOBIT_ARCH_HOST_MEMORY_H 2 | #define PICOBIT_ARCH_HOST_MEMORY_H 3 | 4 | #define CODE_START 0x8000 5 | 6 | extern uint8 ram_mem[]; 7 | #define ram_get(a) ram_mem[a] 8 | #define ram_set(a,x) ram_mem[a] = (x) 9 | 10 | #define ROM_BYTES 8192 11 | extern uint8 rom_mem[]; 12 | #define rom_get(a) (rom_mem[a-CODE_START]) 13 | 14 | #endif -------------------------------------------------------------------------------- /vm/arch/host/include/types.h: -------------------------------------------------------------------------------- 1 | #ifndef ARCH_HOST_TYPES_H 2 | #define ARCH_HOST_TYPES_H 3 | 4 | #include 5 | 6 | /** Define Picobit basic types **/ 7 | 8 | typedef uint8_t uint8; 9 | typedef uint16_t uint16; 10 | typedef uint32_t uint32; 11 | 12 | #endif -------------------------------------------------------------------------------- /vm/arch/host/stdlib.scm: -------------------------------------------------------------------------------- 1 | (define light adc) 2 | 3 | (define putchar 4 | (lambda (c) 5 | (#%putchar c 3))) 6 | 7 | (define getchar 8 | (lambda () 9 | (or (#%getchar-wait 0 3) 10 | (getchar)))) 11 | 12 | (define getchar-wait 13 | (lambda (duration) 14 | (#%getchar-wait duration 3))) 15 | 16 | (define sleep 17 | (lambda (duration) 18 | (#%sleep-aux (#%+ (clock) duration)))) 19 | 20 | (define #%sleep-aux 21 | (lambda (wake-up) 22 | (if (< (clock) wake-up) 23 | (#%sleep-aux wake-up) 24 | #f))) 25 | 26 | 27 | (define led2-color 28 | (lambda (state) 29 | (if (eq? state 'red) 30 | (#%led2-color 1) 31 | (#%led2-color 0)))) 32 | 33 | (define display 34 | (lambda (x) 35 | (if (string? x) 36 | (for-each putchar (string->list x)) 37 | (write x)))) 38 | 39 | (define (newline) (#%putchar #\newline 3)) 40 | 41 | (define (displayln x) (display x) (newline)) 42 | 43 | (define write 44 | (lambda (x) 45 | (cond ((string? x) 46 | (begin (#%putchar #\" 3) 47 | (display x) 48 | (#%putchar #\" 3))) 49 | ((number? x) 50 | (display (number->string x))) 51 | ((pair? x) 52 | (begin (#%putchar #\( 3) 53 | (write (car x)) 54 | (#%write-list (cdr x)))) 55 | ((symbol? x) 56 | (display "#")) 57 | ((boolean? x) 58 | (display (if x "#t" "#f"))) 59 | (else 60 | (display "#"))))) 61 | ;; TODO have vectors and co ? 62 | 63 | (define #%write-list 64 | (lambda (lst) 65 | (cond ((null? lst) 66 | (#%putchar #\) 3)) 67 | ((pair? lst) 68 | (begin (#%putchar #\space 3) 69 | (write (car lst)) 70 | (#%write-list (cdr lst)))) 71 | (else 72 | (begin (display " . ") 73 | (write lst) 74 | (#%putchar #\) 3)))))) 75 | 76 | (define pp 77 | (lambda (x) 78 | (write x) 79 | (#%putchar #\newline 3))) 80 | 81 | (define current-time clock) 82 | (define time->seconds (lambda (t) (quotient t 100))) 83 | -------------------------------------------------------------------------------- /vm/core/.gitignore: -------------------------------------------------------------------------------- 1 | gen.dispatch.c -------------------------------------------------------------------------------- /vm/core/Kconfig: -------------------------------------------------------------------------------- 1 | choice 2 | prompt "Bignum precision" 3 | help 4 | Code may be shrinked by omitting arbitrary 5 | precision bignums. 6 | 7 | config BIGNUM_FIXED 8 | bool "Fixed 24-bit" 9 | help 10 | A very small bignum implementation which has a fixed 11 | precision. Currently it is only useful on 8-bit targets, 12 | and bignums are 24 bit long. 13 | 14 | config BIGNUM_LONG 15 | bool "Arbitrary" 16 | help 17 | Arbitrary precision bignums are represented by lists of 18 | 16-bit values, and computations are performed by helper 19 | functions. 20 | endchoice 21 | 22 | config VM_DEBUG 23 | bool "Debug virtual machine" 24 | help 25 | Enable virtual machine trace messages. Each instruction 26 | will be printed before executing. 27 | 28 | config GC_STATISTICS 29 | bool "Collect statistics in garbage collector" 30 | help 31 | Enable measuring various memory allocation statistics. 32 | Currently it is only a maximal number of live objects. 33 | 34 | config GC_STATISTICS_PRIMITIVE 35 | depends on GC_STATISTICS 36 | bool "Export statistics to user program" 37 | help 38 | Add a #%gc-max-live primitive. 39 | 40 | config GC_DEBUG 41 | bool "Debug garbage collector" 42 | help 43 | Enable garbage collector trace messages. 44 | 45 | config GC_AGGRESSIVE 46 | bool "Aggressive GC" 47 | depends on GC_DEBUG 48 | help 49 | Collect garbage before each allocation and not only 50 | when VM has no free memory. 51 | -------------------------------------------------------------------------------- /vm/core/Makefile: -------------------------------------------------------------------------------- 1 | core-y += dispatch.c heap.c gc.c \ 2 | primitives-list.c primitives-numeric.c \ 3 | primitives-util.c primitives-vector.c \ 4 | primitives-control.c 5 | 6 | core-$(CONFIG_BIGNUM_LONG) += bignum_long.c 7 | core-$(CONFIG_BIGNUM_FIXED) += bignum_fixed.c 8 | core-$(CONFIG_DEBUG_STRINGS) += debug.c 9 | -------------------------------------------------------------------------------- /vm/core/bignum_fixed.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | /* 6 | * Implementation of bignums as fixed-precision, 7 | * 24-bit integers. 8 | */ 9 | 10 | uint16 decode_int (obj o) 11 | { 12 | uint16 u; // TODO should be 32, but is lost anyway since this returns a uint16 13 | uint16 h; 14 | uint8 l; 15 | 16 | if (o < MIN_FIXNUM_ENCODING) { 17 | TYPE_ERROR("decode_int.0", "integer"); 18 | } 19 | 20 | if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM))) { 21 | return DECODE_FIXNUM(o); 22 | } 23 | 24 | if (IN_RAM(o)) { 25 | if (!RAM_BIGNUM_P(o)) { 26 | TYPE_ERROR("decode_int.1", "integer"); 27 | } 28 | 29 | u = ram_get_field1 (o); 30 | h = ram_get_field2 (o); 31 | l = ram_get_field3 (o); 32 | } else if (IN_ROM(o)) { 33 | if (!ROM_BIGNUM_P(o)) { 34 | TYPE_ERROR("decode_int.2", "integer"); 35 | } 36 | 37 | u = rom_get_field1 (o); 38 | h = rom_get_field2 (o); 39 | l = rom_get_field3 (o); 40 | } else { 41 | TYPE_ERROR("decode_int.3", "integer"); 42 | } 43 | 44 | if (u >= 128) { // negative 45 | return ((((u - 256) << 8) + h) << 8) + l; // TODO ints are all 16 bits, 24 bits won't work 46 | } 47 | 48 | return (((u << 8) + h) << 8) + l; 49 | } 50 | 51 | obj encode_int (uint16 n) // TODO does not use the full 24 bits 52 | { 53 | if (n >= MIN_FIXNUM && n <= MAX_FIXNUM) { 54 | return ENCODE_FIXNUM(n); 55 | } 56 | 57 | return alloc_ram_cell_init (BIGNUM_FIELD0, n >> 16, n >> 8, n); 58 | } 59 | -------------------------------------------------------------------------------- /vm/core/debug.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | void show_type (obj o) 7 | { 8 | printf("%04x : ", o); 9 | 10 | if (o == OBJ_FALSE) { 11 | printf("#f"); 12 | } else if (o == OBJ_TRUE) { 13 | printf("#t"); 14 | } else if (o == OBJ_NULL) { 15 | printf("()"); 16 | } else if (o < MIN_ROM_ENCODING) { 17 | printf("fixnum"); 18 | } else if (IN_RAM (o)) { 19 | if (RAM_BIGNUM_P(o)) { 20 | printf("ram bignum"); 21 | } else if (RAM_PAIR_P(o)) { 22 | printf("ram pair"); 23 | } else if (RAM_SYMBOL_P(o)) { 24 | printf("ram symbol"); 25 | } else if (RAM_STRING_P(o)) { 26 | printf("ram string"); 27 | } else if (RAM_VECTOR_P(o)) { 28 | printf("ram vector"); 29 | } else if (RAM_CONTINUATION_P(o)) { 30 | printf("ram continuation"); 31 | } else if (RAM_CLOSURE_P(o)) { 32 | printf("ram closure"); 33 | } 34 | } else { // ROM 35 | if (ROM_BIGNUM_P(o)) { 36 | printf("rom bignum"); 37 | } else if (ROM_PAIR_P(o)) { 38 | printf("rom pair"); 39 | } else if (ROM_SYMBOL_P(o)) { 40 | printf("rom symbol"); 41 | } else if (ROM_STRING_P(o)) { 42 | printf("rom string"); 43 | } else if (ROM_VECTOR_P(o)) { 44 | printf("rom vector"); 45 | } else if (ROM_CONTINUATION_P(o)) { 46 | printf("rom continuation"); 47 | } 48 | 49 | // ROM closures don't exist 50 | } 51 | 52 | printf("\n"); 53 | } 54 | 55 | void show_obj (obj o) 56 | { 57 | if (o == OBJ_FALSE) { 58 | printf ("#f"); 59 | } else if (o == OBJ_TRUE) { 60 | printf ("#t"); 61 | } else if (o == OBJ_NULL) { 62 | printf ("()"); 63 | } else if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM))) { 64 | printf ("%d", DECODE_FIXNUM(o)); 65 | } else { 66 | uint8 in_ram; 67 | 68 | if (IN_RAM(o)) { 69 | in_ram = 1; 70 | } else { 71 | in_ram = 0; 72 | } 73 | 74 | if ((in_ram && RAM_BIGNUM_P(o)) || (!in_ram && ROM_BIGNUM_P(o))) { // TODO fix for new bignums, especially for the sign, a -5 is displayed as 251 75 | printf ("%d", decode_int (o)); 76 | } else if ((in_ram && RAM_COMPOSITE_P(o)) || (!in_ram && ROM_COMPOSITE_P(o))) { 77 | obj car; 78 | obj cdr; 79 | 80 | if ((in_ram && RAM_PAIR_P(o)) || (!in_ram && ROM_PAIR_P(o))) { 81 | if (in_ram) { 82 | car = ram_get_car (o); 83 | cdr = ram_get_cdr (o); 84 | } else { 85 | car = rom_get_car (o); 86 | cdr = rom_get_cdr (o); 87 | } 88 | 89 | printf ("("); 90 | 91 | loop: 92 | show_obj (car); 93 | 94 | if (cdr == OBJ_NULL) { 95 | printf (")"); 96 | } else if ((IN_RAM(cdr) && RAM_PAIR_P(cdr)) 97 | || (IN_ROM(cdr) && ROM_PAIR_P(cdr))) { 98 | if (IN_RAM(cdr)) { 99 | car = ram_get_car (cdr); 100 | cdr = ram_get_cdr (cdr); 101 | } else { 102 | car = rom_get_car (cdr); 103 | cdr = rom_get_cdr (cdr); 104 | } 105 | 106 | printf (" "); 107 | goto loop; 108 | } else { 109 | printf (" . "); 110 | show_obj (cdr); 111 | printf (")"); 112 | } 113 | } else if ((in_ram && RAM_SYMBOL_P(o)) || (!in_ram && ROM_SYMBOL_P(o))) { 114 | printf ("#"); 115 | } else if ((in_ram && RAM_STRING_P(o)) || (!in_ram && ROM_STRING_P(o))) { 116 | printf ("#"); 117 | } else if ((in_ram && RAM_VECTOR_P(o)) || (!in_ram && ROM_VECTOR_P(o))) { 118 | printf ("#", o); 119 | } else { 120 | printf ("("); 121 | cdr = ram_get_car (o); 122 | car = ram_get_cdr (o); 123 | // ugly hack, takes advantage of the fact that pairs and 124 | // continuations have the same layout 125 | goto loop; 126 | } 127 | } else { // closure 128 | obj env; 129 | rom_addr pc; 130 | 131 | env = ram_get_car (o); 132 | pc = ram_get_entry (o); 133 | 134 | printf ("{0x%04x ", pc); 135 | show_obj (env); 136 | printf ("}"); 137 | } 138 | } 139 | 140 | fflush (stdout); 141 | } 142 | 143 | void show_state (rom_addr pc) { 144 | printf ("\n"); 145 | printf ("pc=0x%04x bytecode=0x%02x env=", pc, rom_get (pc)); 146 | show_obj (env); 147 | printf (" cont="); 148 | show_obj (cont); 149 | printf ("\n"); 150 | fflush (stdout); 151 | } 152 | -------------------------------------------------------------------------------- /vm/core/heap.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | // these temporary variables are necessary with SIXPIC, or else the shift 5 | // results will be 8 bits values, which is wrong 6 | obj ram_get_car (obj o) 7 | { 8 | uint16 tmp = ram_get_field0 (o) & 0x1f; 9 | return (tmp << 8) | ram_get_field1 (o); 10 | } 11 | 12 | obj rom_get_car (obj o) 13 | { 14 | uint16 tmp = rom_get_field0 (o) & 0x1f; 15 | return (tmp << 8) | rom_get_field1 (o); 16 | } 17 | 18 | obj ram_get_cdr (obj o) 19 | { 20 | uint16 tmp = ram_get_field2 (o) & 0x1f; 21 | return (tmp << 8) | ram_get_field3 (o); 22 | } 23 | 24 | obj rom_get_cdr (obj o) 25 | { 26 | uint16 tmp = rom_get_field2 (o) & 0x1f; 27 | return (tmp << 8) | rom_get_field3 (o); 28 | } 29 | 30 | void ram_set_car (obj o, obj val) 31 | { 32 | ram_set_field0 (o, (val >> 8) | (ram_get_field0 (o) & 0xe0)); 33 | ram_set_field1 (o, val & 0xff); 34 | } 35 | 36 | void ram_set_cdr (obj o, obj val) 37 | { 38 | ram_set_field2 (o, (val >> 8) | (ram_get_field2 (o) & 0xe0)); 39 | ram_set_field3 (o, val & 0xff); 40 | } 41 | 42 | // function entry point 43 | // the temporary variables are necessary with SIXPIC, see above 44 | obj ram_get_entry (obj o) 45 | { 46 | uint16 tmp = ram_get_field2 (o); 47 | return ((tmp << 8) | ram_get_field3 (o)); 48 | } 49 | 50 | obj get_global (uint8 i) 51 | { 52 | // globals occupy the beginning of ram, with 2 globals per word 53 | if (i & 1) { 54 | return ram_get_cdr (MIN_RAM_ENCODING + (i >> 1)); 55 | } else { 56 | return ram_get_car (MIN_RAM_ENCODING + (i >> 1)); 57 | } 58 | } 59 | 60 | void set_global (uint8 i, obj o) 61 | { 62 | if (i & 1) { 63 | ram_set_cdr (MIN_RAM_ENCODING + (i >> 1), o); 64 | } else { 65 | ram_set_car (MIN_RAM_ENCODING + (i >> 1), o); 66 | } 67 | } 68 | 69 | obj cons (obj car, obj cdr) 70 | { 71 | return alloc_ram_cell_init (COMPOSITE_FIELD0 | (car >> 8), 72 | car & 0xff, 73 | PAIR_FIELD2 | (cdr >> 8), 74 | cdr & 0xff); 75 | } 76 | -------------------------------------------------------------------------------- /vm/core/primitives-control.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | PRIMITIVE(return, return, 1) 6 | { 7 | arg2 = ram_get_cdr (cont); 8 | pc = ram_get_entry (arg2); 9 | env = ram_get_car (arg2); 10 | cont = ram_get_car (cont); 11 | arg2 = OBJ_FALSE; 12 | } 13 | 14 | PRIMITIVE_UNSPEC(pop, pop, 0) 15 | { 16 | pop(); 17 | } 18 | 19 | PRIMITIVE(get-cont, get_cont, 0) 20 | { 21 | arg1 = cont; 22 | } 23 | 24 | PRIMITIVE_UNSPEC(graft-to-cont, graft_to_cont, 2) 25 | { 26 | /* arg2 is thunk to call, arg1 is continuation */ 27 | cont = arg1; 28 | 29 | arg1 = arg2; 30 | push_arg1(); 31 | 32 | pop_procedure (); 33 | build_env (handle_arity_and_rest_param (0)); 34 | 35 | env = arg1; 36 | pc = entry; 37 | 38 | arg1 = OBJ_FALSE; 39 | arg2 = OBJ_FALSE; 40 | } 41 | 42 | PRIMITIVE(return-to-cont, return_to_cont, 2) 43 | { 44 | /* arg2 is value to return, arg1 is continuation */ 45 | cont = arg1; 46 | arg1 = arg2; 47 | 48 | arg2 = ram_get_cdr(cont); 49 | 50 | pc = ram_get_entry(arg2); 51 | 52 | env = ram_get_car (arg2); 53 | cont = ram_get_car (cont); 54 | 55 | arg2 = OBJ_FALSE; 56 | } 57 | -------------------------------------------------------------------------------- /vm/core/primitives-list.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | PRIMITIVE(pair?, pair_p, 1) 5 | { 6 | if (IN_RAM(arg1)) { 7 | arg1 = encode_bool (RAM_PAIR_P(arg1)); 8 | } else if (IN_ROM(arg1)) { 9 | arg1 = encode_bool (ROM_PAIR_P(arg1)); 10 | } else { 11 | arg1 = OBJ_FALSE; 12 | } 13 | } 14 | 15 | PRIMITIVE(cons, cons, 2) 16 | { 17 | arg1 = cons (arg1, arg2); 18 | arg2 = OBJ_FALSE; 19 | } 20 | 21 | PRIMITIVE(car, car, 1) 22 | { 23 | if (IN_RAM(arg1)) { 24 | if (!RAM_PAIR_P(arg1)) { 25 | TYPE_ERROR("car.0", "pair"); 26 | } 27 | 28 | arg1 = ram_get_car (arg1); 29 | } else if (IN_ROM(arg1)) { 30 | if (!ROM_PAIR_P(arg1)) { 31 | TYPE_ERROR("car.1", "pair"); 32 | } 33 | 34 | arg1 = rom_get_car (arg1); 35 | } else { 36 | TYPE_ERROR("car.2", "pair"); 37 | } 38 | } 39 | 40 | PRIMITIVE(cdr, cdr, 1) 41 | { 42 | if (IN_RAM(arg1)) { 43 | if (!RAM_PAIR_P(arg1)) { 44 | TYPE_ERROR("cdr.0", "pair"); 45 | } 46 | 47 | arg1 = ram_get_cdr (arg1); 48 | } else if (IN_ROM(arg1)) { 49 | if (!ROM_PAIR_P(arg1)) { 50 | TYPE_ERROR("cdr.1", "pair"); 51 | } 52 | 53 | arg1 = rom_get_cdr (arg1); 54 | } else { 55 | TYPE_ERROR("cdr.2", "pair"); 56 | } 57 | } 58 | 59 | PRIMITIVE_UNSPEC(set-car!, set_car_bang, 2) 60 | { 61 | if (IN_RAM(arg1)) { 62 | if (!RAM_PAIR_P(arg1)) { 63 | TYPE_ERROR("set-car!.0", "pair"); 64 | } 65 | 66 | ram_set_car (arg1, arg2); 67 | arg1 = OBJ_FALSE; 68 | arg2 = OBJ_FALSE; 69 | } else { 70 | TYPE_ERROR("set-car!.1", "pair"); 71 | } 72 | } 73 | 74 | PRIMITIVE_UNSPEC(set-cdr!, set_cdr_bang, 2) 75 | { 76 | if (IN_RAM(arg1)) { 77 | if (!RAM_PAIR_P(arg1)) { 78 | TYPE_ERROR("set-cdr!.0", "pair"); 79 | } 80 | 81 | ram_set_cdr (arg1, arg2); 82 | arg1 = OBJ_FALSE; 83 | arg2 = OBJ_FALSE; 84 | } else { 85 | TYPE_ERROR("set-cdr!.1", "pair"); 86 | } 87 | } 88 | 89 | PRIMITIVE(null?, null_p, 1) 90 | { 91 | arg1 = encode_bool (arg1 == OBJ_NULL); 92 | } 93 | -------------------------------------------------------------------------------- /vm/core/primitives-numeric.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | PRIMITIVE(number?, number_p, 1) 6 | { 7 | if (arg1 >= MIN_FIXNUM_ENCODING 8 | && arg1 <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM))) { 9 | arg1 = OBJ_TRUE; 10 | } else { 11 | if (IN_RAM(arg1)) { 12 | arg1 = encode_bool (RAM_BIGNUM_P(arg1)); 13 | } else if (IN_ROM(arg1)) { 14 | arg1 = encode_bool (ROM_BIGNUM_P(arg1)); 15 | } else { 16 | arg1 = OBJ_FALSE; 17 | } 18 | } 19 | } 20 | 21 | void decode_2_int_args () { 22 | a1 = decode_int (arg1); 23 | a2 = decode_int (arg2); 24 | } 25 | 26 | PRIMITIVE(=, equal, 2) 27 | { 28 | #ifdef CONFIG_BIGNUM_LONG 29 | arg1 = encode_bool(cmp (arg1, arg2) == 1); 30 | #else 31 | decode_2_int_args (); 32 | arg1 = encode_bool(a1 == a2); 33 | #endif 34 | arg2 = OBJ_FALSE; 35 | } 36 | 37 | PRIMITIVE(#%+, add, 2) 38 | { 39 | #ifdef CONFIG_BIGNUM_LONG 40 | arg1 = add (arg1, arg2); 41 | #else 42 | decode_2_int_args (); 43 | arg1 = encode_int (a1 + a2); 44 | #endif 45 | arg2 = OBJ_FALSE; 46 | } 47 | 48 | PRIMITIVE(#%-, sub, 2) 49 | { 50 | #ifdef CONFIG_BIGNUM_LONG 51 | arg1 = sub (arg1, arg2); 52 | #else 53 | decode_2_int_args (); 54 | arg1 = encode_int (a1 - a2); 55 | #endif 56 | arg2 = OBJ_FALSE; 57 | } 58 | 59 | PRIMITIVE(#%mul-non-neg, mul_non_neg, 2) 60 | { 61 | #ifdef CONFIG_BIGNUM_LONG 62 | arg1 = mulnonneg (arg1, arg2); 63 | #else 64 | decode_2_int_args (); 65 | arg1 = encode_int (a1 * a2); 66 | #endif 67 | arg2 = OBJ_FALSE; 68 | } 69 | 70 | PRIMITIVE(#%div-non-neg, div_non_neg, 2) 71 | { 72 | #ifdef CONFIG_BIGNUM_LONG 73 | if (obj_eq(arg2, ZERO)) { 74 | ERROR("quotient", "divide by 0"); 75 | } 76 | 77 | arg1 = divnonneg (arg1, arg2); 78 | #else 79 | decode_2_int_args (); 80 | 81 | if (a2 == 0) { 82 | ERROR("quotient", "divide by 0"); 83 | } 84 | 85 | arg1 = encode_int (a1 / a2); 86 | #endif 87 | 88 | arg2 = OBJ_FALSE; 89 | } 90 | 91 | PRIMITIVE(#%rem-non-neg, rem_non_neg, 2) 92 | { 93 | #ifdef CONFIG_BIGNUM_LONG 94 | if (obj_eq(arg2, ZERO)) { 95 | ERROR("remainder", "divide by 0"); 96 | } 97 | 98 | arg3 = divnonneg (arg1, arg2); 99 | arg4 = mulnonneg (arg2, arg3); 100 | arg1 = sub(arg1, arg4); 101 | arg3 = OBJ_FALSE; 102 | arg4 = OBJ_FALSE; 103 | #else 104 | decode_2_int_args (); 105 | 106 | if (a2 == 0) { 107 | ERROR("remainder", "divide by 0"); 108 | } 109 | 110 | arg1 = encode_int (a1 % a2); 111 | #endif 112 | 113 | arg2 = OBJ_FALSE; 114 | } 115 | 116 | PRIMITIVE(<, lt, 2) 117 | { 118 | #ifdef CONFIG_BIGNUM_LONG 119 | arg1 = encode_bool(cmp (arg1, arg2) < 1); 120 | #else 121 | decode_2_int_args (); 122 | arg1 = encode_bool(a1 < a2); 123 | #endif 124 | arg2 = OBJ_FALSE; 125 | } 126 | 127 | PRIMITIVE(>, gt, 2) 128 | { 129 | #ifdef CONFIG_BIGNUM_LONG 130 | arg1 = encode_bool(cmp (arg1, arg2) > 1); 131 | #else 132 | decode_2_int_args (); 133 | arg1 = encode_bool(a1 > a2); 134 | #endif 135 | arg2 = OBJ_FALSE; 136 | } 137 | 138 | PRIMITIVE(bitwise-ior, bitwise_ior, 2) 139 | { 140 | #ifdef CONFIG_BIGNUM_LONG 141 | arg1 = bitwise_ior(arg1, arg2); 142 | #else 143 | decode_2_int_args (); 144 | arg1 = encode_int (a1 | a2); 145 | #endif 146 | arg2 = OBJ_FALSE; 147 | } 148 | 149 | PRIMITIVE(bitwise-xor, bitwise_xor, 2) 150 | { 151 | #ifdef CONFIG_BIGNUM_LONG 152 | arg1 = bitwise_xor(arg1, arg2); 153 | #else 154 | decode_2_int_args (); 155 | arg1 = encode_int (a1 ^ a2); 156 | #endif 157 | arg2 = OBJ_FALSE; 158 | } 159 | 160 | // TODO add bitwise-and and bitwise-not 161 | -------------------------------------------------------------------------------- /vm/core/primitives-util.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | PRIMITIVE(eq?, eq_p, 2) 6 | { 7 | arg1 = encode_bool (arg1 == arg2); 8 | arg2 = OBJ_FALSE; 9 | } 10 | 11 | PRIMITIVE(not, not, 1) 12 | { 13 | arg1 = encode_bool (arg1 == OBJ_FALSE); 14 | } 15 | 16 | PRIMITIVE(symbol?, symbol_p, 1) 17 | { 18 | if (IN_RAM(arg1)) { 19 | arg1 = encode_bool (RAM_SYMBOL_P(arg1)); 20 | } else if (IN_ROM(arg1)) { 21 | arg1 = encode_bool (ROM_SYMBOL_P(arg1)); 22 | } else { 23 | arg1 = OBJ_FALSE; 24 | } 25 | } 26 | 27 | PRIMITIVE(boolean?, boolean_p, 1) 28 | { 29 | arg1 = encode_bool (arg1 < 2); 30 | } 31 | 32 | PRIMITIVE(string?, string_p, 1) 33 | { 34 | if (IN_RAM(arg1)) { 35 | arg1 = encode_bool (RAM_STRING_P(arg1)); 36 | } else if (IN_ROM(arg1)) { 37 | arg1 = encode_bool (ROM_STRING_P(arg1)); 38 | } else { 39 | arg1 = OBJ_FALSE; 40 | } 41 | } 42 | 43 | PRIMITIVE(string->list, string2list, 1) 44 | { 45 | if (IN_RAM(arg1)) { 46 | if (!RAM_STRING_P(arg1)) { 47 | TYPE_ERROR("string->list.0", "string"); 48 | } 49 | 50 | arg1 = ram_get_car (arg1); 51 | } else if (IN_ROM(arg1)) { 52 | if (!ROM_STRING_P(arg1)) { 53 | TYPE_ERROR("string->list.1", "string"); 54 | } 55 | 56 | arg1 = rom_get_car (arg1); 57 | } else { 58 | TYPE_ERROR("string->list.2", "string"); 59 | } 60 | } 61 | 62 | PRIMITIVE(list->string, list2string, 1) 63 | { 64 | arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | ((arg1 & 0x1f00) >> 8), 65 | arg1 & 0xff, 66 | STRING_FIELD2, 67 | 0); 68 | } 69 | -------------------------------------------------------------------------------- /vm/core/primitives-vector.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | PRIMITIVE(u8vector?, u8vector_p, 1) 7 | { 8 | if (IN_RAM(arg1)) { 9 | arg1 = encode_bool (RAM_VECTOR_P(arg1)); 10 | } else if (IN_ROM(arg1)) { 11 | arg1 = encode_bool (ROM_VECTOR_P(arg1)); 12 | } else { 13 | arg1 = OBJ_FALSE; 14 | } 15 | } 16 | 17 | PRIMITIVE(#%make-u8vector, make_u8vector, 1) 18 | { 19 | a1 = decode_int (arg1); // arg1 is length 20 | // TODO adapt for the new bignums 21 | 22 | arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | (a1 >> 8), 23 | a1 & 0xff, 24 | VECTOR_FIELD2, 25 | 0); // will be filled in later 26 | arg2 = alloc_vec_cell (a1, arg1); 27 | ram_set_cdr(arg1, arg2); 28 | arg2 = OBJ_FALSE; 29 | } 30 | 31 | PRIMITIVE(u8vector-ref, u8vector_ref, 2) 32 | { 33 | a2 = decode_int (arg2); 34 | 35 | // TODO adapt for the new bignums 36 | if (IN_RAM(arg1)) { 37 | if (!RAM_VECTOR_P(arg1)) { 38 | TYPE_ERROR("u8vector-ref.0", "vector"); 39 | } 40 | 41 | if (ram_get_car (arg1) <= a2) { 42 | ERROR("u8vector-ref.0", "vector index invalid"); 43 | } 44 | 45 | arg1 = VEC_TO_RAM_OBJ(ram_get_cdr (arg1)); 46 | } else if (IN_ROM(arg1)) { 47 | if (!ROM_VECTOR_P(arg1)) { 48 | TYPE_ERROR("u8vector-ref.1", "vector"); 49 | } 50 | 51 | if (rom_get_car (arg1) <= a2) { 52 | ERROR("u8vector-ref.1", "vector index invalid"); 53 | } 54 | 55 | arg1 = rom_get_cdr (arg1); 56 | 57 | while (a2--) { 58 | arg1 = rom_get_cdr (arg1); 59 | } 60 | 61 | // the contents are already encoded as fixnums 62 | arg1 = rom_get_car (arg1); 63 | arg2 = OBJ_FALSE; 64 | arg3 = OBJ_FALSE; 65 | arg4 = OBJ_FALSE; 66 | return; 67 | } else { 68 | TYPE_ERROR("u8vector-ref.2", "vector"); 69 | } 70 | 71 | arg1 += (a2 >> 2); 72 | a2 %= 4; 73 | 74 | arg1 = encode_int (ram_get (OBJ_TO_RAM_ADDR(arg1, a2))); 75 | 76 | arg2 = OBJ_FALSE; 77 | arg3 = OBJ_FALSE; 78 | arg4 = OBJ_FALSE; 79 | } 80 | 81 | PRIMITIVE_UNSPEC(u8vector-set!, u8vector_set, 3) 82 | // TODO a lot in common with ref, abstract that 83 | { 84 | a2 = decode_int (arg2); // TODO adapt for bignums 85 | a3 = decode_int (arg3); 86 | 87 | if (a3 > 255) { 88 | ERROR("u8vector-set!", "byte vectors can only contain bytes"); 89 | } 90 | 91 | if (IN_RAM(arg1)) { 92 | if (!RAM_VECTOR_P(arg1)) { 93 | TYPE_ERROR("u8vector-set!.0", "vector"); 94 | } 95 | 96 | if (ram_get_car (arg1) <= a2) { 97 | ERROR("u8vector-set!", "vector index invalid"); 98 | } 99 | 100 | arg1 = VEC_TO_RAM_OBJ(ram_get_cdr (arg1)); 101 | } else { 102 | TYPE_ERROR("u8vector-set!.1", "vector"); 103 | } 104 | 105 | arg1 += (a2 >> 2); 106 | a2 %= 4; 107 | 108 | ram_set (OBJ_TO_RAM_ADDR(arg1, a2), a3); 109 | 110 | arg1 = OBJ_FALSE; 111 | arg2 = OBJ_FALSE; 112 | arg3 = OBJ_FALSE; 113 | } 114 | 115 | PRIMITIVE(u8vector-length, u8vector_length, 1) 116 | { 117 | if (IN_RAM(arg1)) { 118 | if (!RAM_VECTOR_P(arg1)) { 119 | TYPE_ERROR("u8vector-length.0", "vector"); 120 | } 121 | 122 | arg1 = encode_int (ram_get_car (arg1)); 123 | } else if (IN_ROM(arg1)) { 124 | if (!ROM_VECTOR_P(arg1)) { 125 | TYPE_ERROR("u8vector-length.1", "vector"); 126 | } 127 | 128 | arg1 = encode_int (rom_get_car (arg1)); 129 | } else { 130 | TYPE_ERROR("u8vector-length.2", "vector"); 131 | } 132 | } 133 | -------------------------------------------------------------------------------- /vm/include/.gitignore: -------------------------------------------------------------------------------- 1 | config 2 | generated 3 | gen.primitives.h -------------------------------------------------------------------------------- /vm/include/bignum.h: -------------------------------------------------------------------------------- 1 | #ifndef PICOBIT_BIGNUM_H 2 | #define PICOBIT_BIGNUM_H 3 | 4 | #include 5 | 6 | uint16 decode_int (obj o); 7 | obj encode_int (uint16 n); 8 | 9 | #ifdef CONFIG_BIGNUM_LONG 10 | 11 | 12 | typedef obj integer; 13 | 14 | /* 15 | * A `digit' is a numeric representation of one entry 16 | * of a bignum linked list. A `two_digit` is a numeric 17 | * representation for the cases where a result of 18 | * an operation is wider than a `digit'. 19 | */ 20 | typedef uint16 digit; 21 | typedef uint32 two_digit; 22 | 23 | #define digit_width (sizeof(digit) * 8) 24 | 25 | #define obj_eq(x,y) ((x) == (y)) 26 | #define integer_hi_set(x,y) ram_set_car (x, y) 27 | 28 | integer make_integer (digit lo, integer hi); 29 | integer integer_hi (integer x); 30 | digit integer_lo (integer x); 31 | 32 | integer norm (obj prefix, integer n); 33 | uint8 negp (integer x); 34 | uint8 cmp (integer x, integer y); 35 | uint16 integer_length (integer x); 36 | integer shr (integer x); 37 | integer negative_carry (integer carry); 38 | integer shl (integer x); 39 | integer shift_left (integer x, uint16 n); 40 | integer add (integer x, integer y); 41 | integer invert (integer x); 42 | integer sub (integer x, integer y); 43 | integer neg (integer x); 44 | integer scale (digit n, integer x); 45 | integer mulnonneg (integer x, integer y); 46 | integer divnonneg (integer x, integer y); 47 | integer bitwise_xor (integer x, integer y); 48 | integer bitwise_ior (integer x, integer y); 49 | 50 | void bignum_gc_init(); 51 | void bignum_gc_mark(); 52 | 53 | #endif 54 | 55 | #endif 56 | -------------------------------------------------------------------------------- /vm/include/debug.h: -------------------------------------------------------------------------------- 1 | #ifndef PICOBIT_DEBUG_H 2 | #define PICOBIT_DEBUG_H 3 | 4 | #if defined(CONFIG_VM_DEBUG) || defined(CONFIG_GC_DEBUG) 5 | #include 6 | #endif 7 | 8 | #ifdef CONFIG_VM_DEBUG 9 | #define IF_TRACE(x) x 10 | #else 11 | #define IF_TRACE(x) 12 | #endif 13 | 14 | #ifdef CONFIG_GC_DEBUG 15 | #define IF_GC_TRACE(x) x 16 | #else 17 | #define IF_GC_TRACE(x) 18 | #endif 19 | 20 | #ifdef CONFIG_DEBUG_STRINGS 21 | void show_type (obj o); 22 | void show_obj (obj o); 23 | void show_state (rom_addr pc); 24 | #else 25 | #define show_type(o) 26 | #define show_obj(o) 27 | #define show_state(pc) 28 | #endif 29 | 30 | #endif 31 | -------------------------------------------------------------------------------- /vm/include/dispatch.h: -------------------------------------------------------------------------------- 1 | #ifndef PICOBIT_DISPATCH_H 2 | #define PICOBIT_DISPATCH_H 3 | 4 | #include 5 | #include 6 | 7 | #define FETCH_NEXT_BYTECODE() bytecode = rom_get (pc++) 8 | 9 | #define PUSH_CONSTANT1 0x0 10 | #define PUSH_CONSTANT2 0x1 11 | #define PUSH_STACK1 0x2 12 | #define PUSH_STACK2 0x3 13 | #define PUSH_GLOBAL 0x4 14 | #define SET_GLOBAL 0x5 15 | #define CALL 0x6 16 | #define JUMP 0x7 17 | #define JUMP_TOPLEVEL_REL4 0x8 18 | #define GOTO_IF_FALSE_REL4 0x9 19 | #define PUSH_CONSTANT_LONG 0xa 20 | #define LABEL_INSTR 0xb 21 | 22 | #define PRIM1 0xc 23 | #define PRIM2 0xd 24 | #define PRIM3 0xe 25 | #define PRIM4 0xf 26 | 27 | void push_arg1 (); 28 | obj pop (); 29 | void pop_procedure (); 30 | uint8 handle_arity_and_rest_param (uint8 na); 31 | void build_env (uint8 na); 32 | void save_cont (); 33 | void interpreter (); 34 | 35 | #endif 36 | -------------------------------------------------------------------------------- /vm/include/gc.h: -------------------------------------------------------------------------------- 1 | #ifndef PICOBIT_GC_H 2 | #define PICOBIT_GC_H 3 | 4 | /* TODO explain what each tag means, with 1-2 mark bits. 5 | Currently, they're described in IFL paper. */ 6 | #define GC_TAG_0_LEFT (1<<5) 7 | #define GC_TAG_1_LEFT (2<<5) 8 | #define GC_TAG_UNMARKED (0<<5) 9 | 10 | /* Number of object fields of objects in ram */ 11 | #ifdef LESS_MACROS 12 | uint8 HAS_2_OBJECT_FIELDS(uint16 visit) 13 | { 14 | return (RAM_PAIR_P(visit) || RAM_CONTINUATION_P(visit)); 15 | } 16 | 17 | #ifdef CONFIG_BIGNUM_LONG 18 | uint8 HAS_1_OBJECT_FIELD(uint16 visit) 19 | { 20 | return (RAM_COMPOSITE_P(visit) || RAM_CLOSURE_P(visit) || RAM_BIGNUM_P(visit)); 21 | } 22 | #else 23 | uint8 HAS_1_OBJECT_FIELD(uint16 visit) 24 | { 25 | return (RAM_COMPOSITE_P(visit) || RAM_CLOSURE_P(visit)); 26 | } 27 | #endif 28 | 29 | #else 30 | #define HAS_2_OBJECT_FIELDS(visit) (RAM_PAIR_P(visit) || RAM_CONTINUATION_P(visit)) 31 | #ifdef CONFIG_BIGNUM_LONG 32 | #define HAS_1_OBJECT_FIELD(visit) (RAM_COMPOSITE_P(visit) \ 33 | || RAM_CLOSURE_P(visit) || RAM_BIGNUM_P(visit)) 34 | #else 35 | #define HAS_1_OBJECT_FIELD(visit) (RAM_COMPOSITE_P(visit) || RAM_CLOSURE_P(visit)) 36 | #endif 37 | #endif 38 | // all composites except pairs and continuations have 1 object field 39 | 40 | #ifdef CONFIG_GC_DEBUG 41 | extern int max_live; 42 | #endif 43 | 44 | void init_ram_heap (); 45 | 46 | void mark (obj temp); 47 | void sweep (); 48 | void gc (); 49 | 50 | obj alloc_ram_cell (); 51 | obj alloc_ram_cell_init (uint8 f0, uint8 f1, uint8 f2, uint8 f3); 52 | obj alloc_vec_cell (uint16 n, obj from); 53 | 54 | #endif 55 | -------------------------------------------------------------------------------- /vm/include/heap.h: -------------------------------------------------------------------------------- 1 | #ifndef PICOBIT_HEAP_H 2 | #define PICOBIT_HEAP_H 3 | 4 | /* 5 | * Address space layout. 6 | * For details, see IFL paper. Pointer in README. 7 | * 8 | * Vector space is in RAM too, but separate from the regular heap 9 | * (address spaces are disjoint). 10 | * It can reuse helper functions (ram_get_car, etc.) defined for the 11 | * regular heap. 12 | * On the target device, vector space should be right after the 13 | * regular heap. 14 | * 15 | * Boundaries between zones can be changed to better fit a target 16 | * sytems's or an application's needs. 17 | * Some invariants must be respected: 18 | * - the order of the zones must not change 19 | * - these constants must be kept in sync with the compiler's 20 | * (in encoding.rkt) 21 | * - -1 and 0 must be fixnums, otherwise bignums won't work 22 | * - vector space can overlap with ram, rom, and constant encodings 23 | * but all other zones must be distinct 24 | * - the largest encoding is bounded by the pointer size in the 25 | * object layout 26 | */ 27 | 28 | #include 29 | 30 | #define MAX_VEC_ENCODING 8191 31 | #define MIN_VEC_ENCODING 0 32 | #define VEC_BYTES ((MAX_VEC_ENCODING - MIN_VEC_ENCODING + 1)*4) 33 | 34 | #define MAX_RAM_ENCODING 8191 35 | #define MIN_RAM_ENCODING 1280 36 | #define RAM_BYTES ((MAX_RAM_ENCODING - MIN_RAM_ENCODING + 1)*4) 37 | 38 | #define MIN_FIXNUM_ENCODING 3 39 | #define MIN_FIXNUM -1 40 | #define MAX_FIXNUM 256 41 | #define MIN_ROM_ENCODING (MIN_FIXNUM_ENCODING + MAX_FIXNUM - MIN_FIXNUM + 1) 42 | 43 | #define ZERO ENCODE_FIXNUM(0) 44 | #define NEG1 (ZERO-1) 45 | #define POS1 (ZERO+1) 46 | 47 | #ifdef LESS_MACROS 48 | uint16 OBJ_TO_RAM_ADDR(uint16 o, uint8 f) 49 | { 50 | return ((((o) - MIN_RAM_ENCODING) << 2) + (f)); 51 | } 52 | uint16 OBJ_TO_ROM_ADDR(uint16 o, uint8 f) 53 | { 54 | return ((((o) - MIN_ROM_ENCODING) << 2) + (CODE_START + 4 + (f))); 55 | } 56 | uint16 VEC_TO_RAM_OBJ(uint16 o) 57 | { 58 | return o + MAX_RAM_ENCODING; 59 | } 60 | uint16 RAM_TO_VEC_OBJ(uint16 o) 61 | { 62 | return o - MAX_RAM_ENCODING; 63 | } 64 | #else 65 | #define OBJ_TO_RAM_ADDR(o,f) ((((o) - MIN_RAM_ENCODING) << 2) + (f)) 66 | #define OBJ_TO_ROM_ADDR(o,f) ((((o) - MIN_ROM_ENCODING) << 2) + (CODE_START + 4 + (f))) 67 | #define VEC_TO_RAM_OBJ(o) ((o) + MAX_RAM_ENCODING + 1) 68 | #define RAM_TO_VEC_OBJ(o) ((o) - MAX_RAM_ENCODING - 1) 69 | #endif 70 | 71 | #ifdef LESS_MACROS 72 | uint8 ram_get_field0(uint16 o) 73 | { 74 | return ram_get (OBJ_TO_RAM_ADDR(o,0)); 75 | } 76 | void ram_set_field0(uint16 o, uint8 val) 77 | { 78 | ram_set (OBJ_TO_RAM_ADDR(o,0), val); 79 | } 80 | uint8 rom_get_field0(uint16 o) 81 | { 82 | return rom_get (OBJ_TO_ROM_ADDR(o,0)); 83 | } 84 | #else 85 | #define ram_get_field0(o) ram_get (OBJ_TO_RAM_ADDR(o,0)) 86 | #define ram_set_field0(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val) 87 | #define rom_get_field0(o) rom_get (OBJ_TO_ROM_ADDR(o,0)) 88 | #endif 89 | 90 | #ifdef LESS_MACROS 91 | uint8 ram_get_gc_tags(uint16 o) 92 | { 93 | return (ram_get_field0(o) & 0x60); 94 | } 95 | uint8 ram_get_gc_tag0(uint16 o) 96 | { 97 | return (ram_get_field0(o) & 0x20); 98 | } 99 | uint8 ram_get_gc_tag1(uint16 o) 100 | { 101 | return (ram_get_field0(o) & 0x40); 102 | } 103 | void ram_set_gc_tags(uint16 o, uint8 tags) 104 | { 105 | ram_set_field0(o,(ram_get_field0(o) & 0x9f) | (tags)); 106 | } 107 | void ram_set_gc_tag0(uint16 o, uint8 tag) 108 | { 109 | ram_set_field0(o,(ram_get_field0(o) & 0xdf) | (tag)); 110 | } 111 | void ram_set_gc_tag1(uint16 o, uint8 tag) 112 | { 113 | ram_set_field0(o,(ram_get_field0(o) & 0xbf) | (tag)); 114 | } 115 | #else 116 | #define ram_get_gc_tags(o) (ram_get_field0(o) & 0x60) 117 | #define ram_get_gc_tag0(o) (ram_get_field0(o) & 0x20) 118 | #define ram_get_gc_tag1(o) (ram_get_field0(o) & 0x40) 119 | #define ram_set_gc_tags(o,tags) \ 120 | (ram_set_field0(o,(ram_get_field0(o) & 0x9f) | (tags))) 121 | #define ram_set_gc_tag0(o,tag) \ 122 | ram_set_field0(o,(ram_get_field0(o) & 0xdf) | (tag)) 123 | #define ram_set_gc_tag1(o,tag) \ 124 | ram_set_field0(o,(ram_get_field0(o) & 0xbf) | (tag)) 125 | #endif 126 | 127 | #ifdef LESS_MACROS 128 | uint8 ram_get_field1(uint16 o) 129 | { 130 | return ram_get (OBJ_TO_RAM_ADDR(o,1)); 131 | } 132 | uint8 ram_get_field2(uint16 o) 133 | { 134 | return ram_get (OBJ_TO_RAM_ADDR(o,2)); 135 | } 136 | uint8 ram_get_field3(uint16 o) 137 | { 138 | return ram_get (OBJ_TO_RAM_ADDR(o,3)); 139 | } 140 | void ram_set_field1(uint16 o, uint8 val) 141 | { 142 | ram_set (OBJ_TO_RAM_ADDR(o,1), val); 143 | } 144 | void ram_set_field2(uint16 o, uint8 val) 145 | { 146 | ram_set (OBJ_TO_RAM_ADDR(o,2), val); 147 | } 148 | void ram_set_field3(uint16 o, uint8 val) 149 | { 150 | ram_set (OBJ_TO_RAM_ADDR(o,3), val); 151 | } 152 | uint8 rom_get_field1(uint16 o) 153 | { 154 | return rom_get (OBJ_TO_ROM_ADDR(o,1)); 155 | } 156 | uint8 rom_get_field2(uint16 o) 157 | { 158 | return rom_get (OBJ_TO_ROM_ADDR(o,2)); 159 | } 160 | uint8 rom_get_field3(uint16 o) 161 | { 162 | return rom_get (OBJ_TO_ROM_ADDR(o,3)); 163 | } 164 | #else 165 | #define ram_get_field1(o) ram_get (OBJ_TO_RAM_ADDR(o,1)) 166 | #define ram_get_field2(o) ram_get (OBJ_TO_RAM_ADDR(o,2)) 167 | #define ram_get_field3(o) ram_get (OBJ_TO_RAM_ADDR(o,3)) 168 | #define ram_set_field1(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val) 169 | #define ram_set_field2(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val) 170 | #define ram_set_field3(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val) 171 | #define rom_get_field1(o) rom_get (OBJ_TO_ROM_ADDR(o,1)) 172 | #define rom_get_field2(o) rom_get (OBJ_TO_ROM_ADDR(o,2)) 173 | #define rom_get_field3(o) rom_get (OBJ_TO_ROM_ADDR(o,3)) 174 | #endif 175 | 176 | obj cons (obj car, obj cdr); 177 | 178 | obj ram_get_car (obj o); 179 | obj rom_get_car (obj o); 180 | obj ram_get_cdr (obj o); 181 | obj rom_get_cdr (obj o); 182 | void ram_set_car (obj o, obj val); 183 | void ram_set_cdr (obj o, obj val); 184 | 185 | obj ram_get_entry (obj o); 186 | 187 | obj get_global (uint8 i); 188 | void set_global (uint8 i, obj o); 189 | 190 | #endif 191 | -------------------------------------------------------------------------------- /vm/include/object.h: -------------------------------------------------------------------------------- 1 | #ifndef PICOBIT_OBJECT_H 2 | #define PICOBIT_OBJECT_H 3 | 4 | /* 5 | OBJECT ENCODING: 6 | 7 | #f 0 8 | #t 1 9 | () 2 10 | fixnum n MIN_FIXNUM -> 3 ... MAX_FIXNUM -> 3 + (MAX_FIXNUM-MIN_FIXNUM) 11 | rom object 4 + (MAX_FIXNUM-MIN_FIXNUM) ... MIN_RAM_ENCODING-1 12 | ram object MIN_RAM_ENCODING ... MAX_RAM_ENCODING 13 | u8vector MIN_VEC_ENCODING ... 8191 14 | 15 | layout of memory allocated objects: 16 | 17 | Gs represent mark bits used by the gc 18 | 19 | ifdef CONFIG_BIGNUM_LONG 20 | bignum n 00G***** **next** hhhhhhhh llllllll (16 bit digit) 21 | TODO what to do with the gc tags for the bignums ? will this work ? 22 | TODO since bignums have only 1 field, only one gc tag is should be enough 23 | (only one is used anyway), so no conflict with closures 24 | 25 | ifndef CONFIG_BIGNUM_LONG 26 | bignum n 00000000 uuuuuuuu hhhhhhhh llllllll (24 bit signed integer) 27 | TODO doesn't work properly for the moment. only 16 bits are usable now 28 | 29 | pair 1GGaaaaa aaaaaaaa 000ddddd dddddddd 30 | a is car 31 | d is cdr 32 | gives an address space of 2^13 * 4 = 32k divided between simple objects, 33 | rom, ram and vectors 34 | 35 | symbol 1GG00000 00000000 00100000 00000000 36 | 37 | string 1GG***** *chars** 01000000 00000000 38 | 39 | u8vector 1GGxxxxx xxxxxxxx 011yyyyy yyyyyyyy 40 | x is length of the vector, in bytes (stored raw, not encoded as an object) 41 | y is pointer to the elements themselves (stored in vector space) 42 | 43 | closure 01Gxxxxx xxxxxxxx aaaaaaaa aaaaaaaa 44 | 0x5ff procedure has n parameters (no rest parameter) 59 | n = -128 to -1 -> procedure has -n parameters, the last is 60 | a rest parameter 61 | */ 62 | 63 | #define OBJ_FALSE 0 64 | #define OBJ_TRUE 1 65 | #define encode_bool(x) (x) 66 | 67 | #define OBJ_NULL 2 68 | 69 | // fixnum definitions in picobit-vm.h , address space layout section 70 | 71 | #ifdef LESS_MACROS 72 | uint16 ENCODE_FIXNUM(uint16 n) 73 | { 74 | return ((n) + (MIN_FIXNUM_ENCODING - MIN_FIXNUM)); 75 | } 76 | uint8 DECODE_FIXNUM(uint16 o) 77 | { 78 | return ((o) - (MIN_FIXNUM_ENCODING - MIN_FIXNUM)); 79 | } 80 | #else 81 | #define ENCODE_FIXNUM(n) ((n) + (MIN_FIXNUM_ENCODING - MIN_FIXNUM)) 82 | #define DECODE_FIXNUM(o) ((o) - (MIN_FIXNUM_ENCODING - MIN_FIXNUM)) 83 | #endif 84 | 85 | #ifdef LESS_MACROS 86 | uint8 IN_RAM(uint16 o) 87 | { 88 | return ((o) >= MIN_RAM_ENCODING); 89 | } 90 | uint8 IN_ROM(uint16 o) 91 | { 92 | return (!IN_RAM(o) && ((o) >= MIN_ROM_ENCODING)); 93 | } 94 | #else 95 | #define IN_RAM(o) ((o) >= MIN_RAM_ENCODING) 96 | #define IN_ROM(o) (!IN_RAM(o) && ((o) >= MIN_ROM_ENCODING)) 97 | #endif 98 | 99 | // bignum first byte : 00Gxxxxx 100 | #define BIGNUM_FIELD0 0 101 | #ifdef LESS_MACROS 102 | uint8 RAM_BIGNUM_P(uint16 o) 103 | { 104 | return ((ram_get_field0 (o) & 0xc0) == BIGNUM_FIELD0); 105 | } 106 | uint8 ROM_BIGNUM_P(uint16 o) 107 | { 108 | return ((rom_get_field0 (o) & 0xc0) == BIGNUM_FIELD0); 109 | } 110 | #else 111 | #define RAM_BIGNUM_P(o) ((ram_get_field0 (o) & 0xc0) == BIGNUM_FIELD0) 112 | #define ROM_BIGNUM_P(o) ((rom_get_field0 (o) & 0xc0) == BIGNUM_FIELD0) 113 | #endif 114 | 115 | // composite first byte : 1GGxxxxx 116 | #define COMPOSITE_FIELD0 0x80 117 | #ifdef LESS_MACROS 118 | uint8 RAM_COMPOSITE_P(uint16 o) 119 | { 120 | return ((ram_get_field0 (o) & 0x80) == COMPOSITE_FIELD0); 121 | } 122 | uint8 ROM_COMPOSITE_P(uint16 o) 123 | { 124 | return ((rom_get_field0 (o) & 0x80) == COMPOSITE_FIELD0); 125 | } 126 | #else 127 | #define RAM_COMPOSITE_P(o) ((ram_get_field0 (o) & 0x80) == COMPOSITE_FIELD0) 128 | #define ROM_COMPOSITE_P(o) ((rom_get_field0 (o) & 0x80) == COMPOSITE_FIELD0) 129 | #endif 130 | 131 | // pair third byte : 000xxxxx 132 | #define PAIR_FIELD2 0 133 | #ifdef LESS_MACROS 134 | uint8 RAM_PAIR_P(uint16 o) 135 | { 136 | return (RAM_COMPOSITE_P (o) && ((ram_get_field2 (o) & 0xe0) == PAIR_FIELD2)); 137 | } 138 | uint8 ROM_PAIR_P(uint16 o) 139 | { 140 | return (ROM_COMPOSITE_P (o) && ((rom_get_field2 (o) & 0xe0) == PAIR_FIELD2)); 141 | } 142 | #else 143 | #define RAM_PAIR_P(o) (RAM_COMPOSITE_P (o) && ((ram_get_field2 (o) & 0xe0) == PAIR_FIELD2)) 144 | #define ROM_PAIR_P(o) (ROM_COMPOSITE_P (o) && ((rom_get_field2 (o) & 0xe0) == PAIR_FIELD2)) 145 | #endif 146 | 147 | // symbol third byte : 001xxxxx 148 | #define SYMBOL_FIELD2 0x20 149 | #ifdef LESS_MACROS 150 | uint8 RAM_SYMBOL_P(uint16 o) 151 | { 152 | return (RAM_COMPOSITE_P (o) && ((ram_get_field2 (o) & 0xe0) == SYMBOL_FIELD2)); 153 | } 154 | uint8 ROM_SYMBOL_P(uint16 o) 155 | { 156 | return (ROM_COMPOSITE_P (o) && ((rom_get_field2 (o) & 0xe0) == SYMBOL_FIELD2)); 157 | } 158 | #else 159 | #define RAM_SYMBOL_P(o) (RAM_COMPOSITE_P (o) && ((ram_get_field2 (o) & 0xe0) == SYMBOL_FIELD2)) 160 | #define ROM_SYMBOL_P(o) (ROM_COMPOSITE_P (o) && ((rom_get_field2 (o) & 0xe0) == SYMBOL_FIELD2)) 161 | #endif 162 | 163 | // string third byte : 010xxxxx 164 | #define STRING_FIELD2 0x40 165 | #ifdef LESS_MACROS 166 | uint8 RAM_STRING_P(uint16 o) 167 | { 168 | return (RAM_COMPOSITE_P (o) && ((ram_get_field2 (o) & 0xe0) == STRING_FIELD2)); 169 | } 170 | uint8 ROM_STRING_P(uint16 o) 171 | { 172 | return (ROM_COMPOSITE_P (o) && ((rom_get_field2 (o) & 0xe0) == STRING_FIELD2)); 173 | } 174 | #else 175 | #define RAM_STRING_P(o) (RAM_COMPOSITE_P (o) && ((ram_get_field2 (o) & 0xe0) == STRING_FIELD2)) 176 | #define ROM_STRING_P(o) (ROM_COMPOSITE_P (o) && ((rom_get_field2 (o) & 0xe0) == STRING_FIELD2)) 177 | #endif 178 | 179 | // u8vector third byte : 011xxxxx 180 | #define VECTOR_FIELD2 0x60 181 | #ifdef LESS_MACROS 182 | uint8 RAM_VECTOR_P(uint16 o) 183 | { 184 | return (RAM_COMPOSITE_P (o) && ((ram_get_field2 (o) & 0xe0) == VECTOR_FIELD2)); 185 | } 186 | uint8 ROM_VECTOR_P(uint16 o) 187 | { 188 | return (ROM_COMPOSITE_P (o) && ((rom_get_field2 (o) & 0xe0) == VECTOR_FIELD2)); 189 | } 190 | #else 191 | #define RAM_VECTOR_P(o) (RAM_COMPOSITE_P (o) && ((ram_get_field2 (o) & 0xe0) == VECTOR_FIELD2)) 192 | #define ROM_VECTOR_P(o) (ROM_COMPOSITE_P (o) && ((rom_get_field2 (o) & 0xe0) == VECTOR_FIELD2)) 193 | #endif 194 | 195 | // continuation third byte : 100xxxxx 196 | #define CONTINUATION_FIELD2 0x80 197 | #ifdef LESS_MACROS 198 | uint8 RAM_CONTINUATION_P(uint16 o) 199 | { 200 | return (RAM_COMPOSITE_P (o) && ((ram_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2)); 201 | } 202 | uint8 ROM_CONTINUATION_P(uint16 o) 203 | { 204 | return (ROM_COMPOSITE_P (o) && ((rom_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2)); 205 | } 206 | #else 207 | #define RAM_CONTINUATION_P(o) (RAM_COMPOSITE_P (o) && ((ram_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2)) 208 | #define ROM_CONTINUATION_P(o) (ROM_COMPOSITE_P (o) && ((rom_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2)) 209 | #endif 210 | 211 | // closure first byte : 01Gxxxxx 212 | // closures are only found in RAM 213 | #define CLOSURE_FIELD0 0x40 214 | #ifdef LESS_MACROS 215 | uint8 RAM_CLOSURE_P(uint16 o) 216 | { 217 | return ((ram_get_field0 (o) & 0xc0) == CLOSURE_FIELD0); 218 | } 219 | #else 220 | #define RAM_CLOSURE_P(o) ((ram_get_field0 (o) & 0xc0) == CLOSURE_FIELD0) 221 | #endif 222 | 223 | #endif 224 | -------------------------------------------------------------------------------- /vm/include/picobit.h: -------------------------------------------------------------------------------- 1 | #ifndef PICOBIT_PICOBIT_H 2 | #define PICOBIT_PICOBIT_H 3 | 4 | #include 5 | 6 | #include 7 | 8 | /* Picobit complex types */ 9 | 10 | typedef uint8 word; 11 | 12 | typedef uint16 ram_addr; 13 | typedef uint16 rom_addr; 14 | 15 | typedef uint16 obj; /* Only 13 bits are used in pointers */ 16 | 17 | #if defined(__GNUC__) 18 | #define NORETURN __attribute__((noreturn)) 19 | #else 20 | #define NORETURN 21 | #endif /* defined(__GNUC__) */ 22 | 23 | #include 24 | #include 25 | 26 | /* GC roots set. */ 27 | 28 | extern obj cont, env; 29 | extern obj arg1, arg2, arg3, arg4; 30 | 31 | /* Interpreter variables. */ 32 | 33 | extern rom_addr pc, entry; 34 | extern uint8 glovars; 35 | 36 | #ifdef CONFIG_ERROR_HANDLING 37 | 38 | #define ERROR(prim, msg) error (prim, msg) 39 | #define TYPE_ERROR(prim, type) type_error (prim, type) 40 | void error (char *prim, char *msg) NORETURN; 41 | void type_error (char *prim, char *type) NORETURN; 42 | 43 | #else 44 | 45 | void halt_with_error () NORETURN; 46 | #define ERROR(prim, msg) halt_with_error() 47 | #define TYPE_ERROR(prim, type) halt_with_error() 48 | 49 | #endif /* CONFIG_ERROR_HANDLING */ 50 | 51 | #endif 52 | -------------------------------------------------------------------------------- /vm/include/primitives.h: -------------------------------------------------------------------------------- 1 | #ifndef PICOBIT_PRIMITIVES_H 2 | #define PICOBIT_PRIMITIVES_H 3 | 4 | #ifdef CONFIG_DEBUG_STRINGS 5 | extern const char* const primitive_names[]; 6 | #endif /* CONFIG_DEBUG_STRINGS */ 7 | 8 | /* For the primitive scanning pass. */ 9 | #ifndef NO_PRIMITIVE_EXPAND 10 | 11 | #define PRIMITIVE(scheme_name, c_name, args) \ 12 | void prim_ ## c_name () 13 | 14 | #define PRIMITIVE_UNSPEC PRIMITIVE 15 | 16 | #endif /* NO_PRIMITIVE_EXPAND */ 17 | 18 | /* Temporary storage for primitives */ 19 | extern obj a1, a2, a3; 20 | 21 | void decode_2_int_args (); 22 | void push_arg1 (); 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /vm/kconfig/.gitignore: -------------------------------------------------------------------------------- 1 | # 2 | # Generated files 3 | # 4 | config* 5 | lex.*.c 6 | *.tab.c 7 | *.tab.h 8 | zconf.hash.c 9 | *.moc 10 | lkc_defs.h 11 | gconf.glade.h 12 | *.pot 13 | *.mo 14 | 15 | # 16 | # configuration programs 17 | # 18 | conf 19 | mconf 20 | nconf 21 | qconf 22 | gconf 23 | kxgettext 24 | -------------------------------------------------------------------------------- /vm/kconfig/Makefile: -------------------------------------------------------------------------------- 1 | CC := gcc 2 | LDFLAGS := -s 3 | CFLAGS := -g -O2 --std=gnu99 -Wall 4 | 5 | all: conf nconf 6 | 7 | conf: conf.o zconf.tab.o 8 | $(CC) $(LDFLAGS) -o $@ $^ $(LIBS) 9 | 10 | nconf: nconf.o nconf.gui.o zconf.tab.o 11 | $(CC) $(LDFLAGS) -o $@ $^ $(LIBS) -lncurses -lmenu -lpanel 12 | 13 | zconf.tab.o: zconf.tab.c zconf.hash.c lex.zconf.c 14 | 15 | ifeq (${GENERATE_PARSER}, 1) 16 | 17 | %.tab.c: %.y 18 | bison -l -b $* -p $(notdir $*) $< 19 | 20 | lex.%.c: %.l 21 | flex -L -P$(notdir $*) -o$@ $< 22 | 23 | %.hash.c: %.gperf 24 | gperf < $< > $@ 25 | else 26 | 27 | %.c: %.c_shipped 28 | cp $< $@ 29 | 30 | endif 31 | 32 | clean: 33 | rm -f zconf.tab.c zconf.hash.c lex.zconf.c zconf.tab.o conf.o conf nconf nconf.o nconf.gui.o 34 | 35 | -------------------------------------------------------------------------------- /vm/kconfig/expr.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2002 Roman Zippel 3 | * Released under the terms of the GNU GPL v2.0. 4 | */ 5 | 6 | #ifndef EXPR_H 7 | #define EXPR_H 8 | 9 | #ifdef __cplusplus 10 | extern "C" { 11 | #endif 12 | 13 | #include 14 | #ifndef __cplusplus 15 | #include 16 | #endif 17 | 18 | struct file { 19 | struct file *next; 20 | struct file *parent; 21 | const char *name; 22 | int lineno; 23 | int flags; 24 | }; 25 | 26 | #define FILE_BUSY 0x0001 27 | #define FILE_SCANNED 0x0002 28 | 29 | typedef enum tristate { 30 | no, mod, yes 31 | } tristate; 32 | 33 | enum expr_type { 34 | E_NONE, E_OR, E_AND, E_NOT, E_EQUAL, E_UNEQUAL, E_LIST, E_SYMBOL, E_RANGE 35 | }; 36 | 37 | union expr_data { 38 | struct expr *expr; 39 | struct symbol *sym; 40 | }; 41 | 42 | struct expr { 43 | enum expr_type type; 44 | union expr_data left, right; 45 | }; 46 | 47 | #define EXPR_OR(dep1, dep2) (((dep1)>(dep2))?(dep1):(dep2)) 48 | #define EXPR_AND(dep1, dep2) (((dep1)<(dep2))?(dep1):(dep2)) 49 | #define EXPR_NOT(dep) (2-(dep)) 50 | 51 | #define expr_list_for_each_sym(l, e, s) \ 52 | for (e = (l); e && (s = e->right.sym); e = e->left.expr) 53 | 54 | struct expr_value { 55 | struct expr *expr; 56 | tristate tri; 57 | }; 58 | 59 | struct symbol_value { 60 | void *val; 61 | tristate tri; 62 | }; 63 | 64 | enum symbol_type { 65 | S_UNKNOWN, S_BOOLEAN, S_TRISTATE, S_INT, S_HEX, S_STRING, S_OTHER 66 | }; 67 | 68 | /* enum values are used as index to symbol.def[] */ 69 | enum { 70 | S_DEF_USER, /* main user value */ 71 | S_DEF_AUTO, /* values read from auto.conf */ 72 | S_DEF_DEF3, /* Reserved for UI usage */ 73 | S_DEF_DEF4, /* Reserved for UI usage */ 74 | S_DEF_COUNT 75 | }; 76 | 77 | struct symbol { 78 | struct symbol *next; 79 | char *name; 80 | enum symbol_type type; 81 | struct symbol_value curr; 82 | struct symbol_value def[S_DEF_COUNT]; 83 | tristate visible; 84 | int flags; 85 | struct property *prop; 86 | struct expr_value dir_dep; 87 | struct expr_value rev_dep; 88 | }; 89 | 90 | #define for_all_symbols(i, sym) for (i = 0; i < SYMBOL_HASHSIZE; i++) for (sym = symbol_hash[i]; sym; sym = sym->next) if (sym->type != S_OTHER) 91 | 92 | #define SYMBOL_CONST 0x0001 /* symbol is const */ 93 | #define SYMBOL_CHECK 0x0008 /* used during dependency checking */ 94 | #define SYMBOL_CHOICE 0x0010 /* start of a choice block (null name) */ 95 | #define SYMBOL_CHOICEVAL 0x0020 /* used as a value in a choice block */ 96 | #define SYMBOL_VALID 0x0080 /* set when symbol.curr is calculated */ 97 | #define SYMBOL_OPTIONAL 0x0100 /* choice is optional - values can be 'n' */ 98 | #define SYMBOL_WRITE 0x0200 /* ? */ 99 | #define SYMBOL_CHANGED 0x0400 /* ? */ 100 | #define SYMBOL_AUTO 0x1000 /* value from environment variable */ 101 | #define SYMBOL_CHECKED 0x2000 /* used during dependency checking */ 102 | #define SYMBOL_WARNED 0x8000 /* warning has been issued */ 103 | 104 | /* Set when symbol.def[] is used */ 105 | #define SYMBOL_DEF 0x10000 /* First bit of SYMBOL_DEF */ 106 | #define SYMBOL_DEF_USER 0x10000 /* symbol.def[S_DEF_USER] is valid */ 107 | #define SYMBOL_DEF_AUTO 0x20000 /* symbol.def[S_DEF_AUTO] is valid */ 108 | #define SYMBOL_DEF3 0x40000 /* symbol.def[S_DEF_3] is valid */ 109 | #define SYMBOL_DEF4 0x80000 /* symbol.def[S_DEF_4] is valid */ 110 | 111 | #define SYMBOL_MAXLENGTH 256 112 | #define SYMBOL_HASHSIZE 9973 113 | 114 | /* A property represent the config options that can be associated 115 | * with a config "symbol". 116 | * Sample: 117 | * config FOO 118 | * default y 119 | * prompt "foo prompt" 120 | * select BAR 121 | * config BAZ 122 | * int "BAZ Value" 123 | * range 1..255 124 | */ 125 | enum prop_type { 126 | P_UNKNOWN, 127 | P_PROMPT, /* prompt "foo prompt" or "BAZ Value" */ 128 | P_COMMENT, /* text associated with a comment */ 129 | P_MENU, /* prompt associated with a menuconfig option */ 130 | P_DEFAULT, /* default y */ 131 | P_CHOICE, /* choice value */ 132 | P_SELECT, /* select BAR */ 133 | P_RANGE, /* range 7..100 (for a symbol) */ 134 | P_ENV, /* value from environment variable */ 135 | P_SYMBOL, /* where a symbol is defined */ 136 | }; 137 | 138 | struct property { 139 | struct property *next; /* next property - null if last */ 140 | struct symbol *sym; /* the symbol for which the property is associated */ 141 | enum prop_type type; /* type of property */ 142 | const char *text; /* the prompt value - P_PROMPT, P_MENU, P_COMMENT */ 143 | struct expr_value visible; 144 | struct expr *expr; /* the optional conditional part of the property */ 145 | struct menu *menu; /* the menu the property are associated with 146 | * valid for: P_SELECT, P_RANGE, P_CHOICE, 147 | * P_PROMPT, P_DEFAULT, P_MENU, P_COMMENT */ 148 | struct file *file; /* what file was this property defined */ 149 | int lineno; /* what lineno was this property defined */ 150 | }; 151 | 152 | #define for_all_properties(sym, st, tok) \ 153 | for (st = sym->prop; st; st = st->next) \ 154 | if (st->type == (tok)) 155 | #define for_all_defaults(sym, st) for_all_properties(sym, st, P_DEFAULT) 156 | #define for_all_choices(sym, st) for_all_properties(sym, st, P_CHOICE) 157 | #define for_all_prompts(sym, st) \ 158 | for (st = sym->prop; st; st = st->next) \ 159 | if (st->text) 160 | 161 | struct menu { 162 | struct menu *next; 163 | struct menu *parent; 164 | struct menu *list; 165 | struct symbol *sym; 166 | struct property *prompt; 167 | struct expr *visibility; 168 | struct expr *dep; 169 | unsigned int flags; 170 | char *help; 171 | struct file *file; 172 | int lineno; 173 | void *data; 174 | }; 175 | 176 | #define MENU_CHANGED 0x0001 177 | #define MENU_ROOT 0x0002 178 | 179 | #ifndef SWIG 180 | 181 | extern struct file *file_list; 182 | extern struct file *current_file; 183 | struct file *lookup_file(const char *name); 184 | 185 | extern struct symbol symbol_yes, symbol_no, symbol_mod; 186 | extern struct symbol *modules_sym; 187 | extern struct symbol *sym_defconfig_list; 188 | extern int cdebug; 189 | struct expr *expr_alloc_symbol(struct symbol *sym); 190 | struct expr *expr_alloc_one(enum expr_type type, struct expr *ce); 191 | struct expr *expr_alloc_two(enum expr_type type, struct expr *e1, struct expr *e2); 192 | struct expr *expr_alloc_comp(enum expr_type type, struct symbol *s1, struct symbol *s2); 193 | struct expr *expr_alloc_and(struct expr *e1, struct expr *e2); 194 | struct expr *expr_alloc_or(struct expr *e1, struct expr *e2); 195 | struct expr *expr_copy(const struct expr *org); 196 | void expr_free(struct expr *e); 197 | int expr_eq(struct expr *e1, struct expr *e2); 198 | void expr_eliminate_eq(struct expr **ep1, struct expr **ep2); 199 | tristate expr_calc_value(struct expr *e); 200 | struct expr *expr_eliminate_yn(struct expr *e); 201 | struct expr *expr_trans_bool(struct expr *e); 202 | struct expr *expr_eliminate_dups(struct expr *e); 203 | struct expr *expr_transform(struct expr *e); 204 | int expr_contains_symbol(struct expr *dep, struct symbol *sym); 205 | bool expr_depends_symbol(struct expr *dep, struct symbol *sym); 206 | struct expr *expr_extract_eq_and(struct expr **ep1, struct expr **ep2); 207 | struct expr *expr_extract_eq_or(struct expr **ep1, struct expr **ep2); 208 | void expr_extract_eq(enum expr_type type, struct expr **ep, struct expr **ep1, struct expr **ep2); 209 | struct expr *expr_trans_compare(struct expr *e, enum expr_type type, struct symbol *sym); 210 | struct expr *expr_simplify_unmet_dep(struct expr *e1, struct expr *e2); 211 | 212 | void expr_fprint(struct expr *e, FILE *out); 213 | struct gstr; /* forward */ 214 | void expr_gstr_print(struct expr *e, struct gstr *gs); 215 | 216 | static inline int expr_is_yes(struct expr *e) 217 | { 218 | return !e || (e->type == E_SYMBOL && e->left.sym == &symbol_yes); 219 | } 220 | 221 | static inline int expr_is_no(struct expr *e) 222 | { 223 | return e && (e->type == E_SYMBOL && e->left.sym == &symbol_no); 224 | } 225 | #endif 226 | 227 | #ifdef __cplusplus 228 | } 229 | #endif 230 | 231 | #endif /* EXPR_H */ 232 | -------------------------------------------------------------------------------- /vm/kconfig/lex.backup: -------------------------------------------------------------------------------- 1 | No backing up. 2 | -------------------------------------------------------------------------------- /vm/kconfig/lkc.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2002 Roman Zippel 3 | * Released under the terms of the GNU GPL v2.0. 4 | */ 5 | 6 | #ifndef LKC_H 7 | #define LKC_H 8 | 9 | #include "expr.h" 10 | 11 | #ifndef KBUILD_NO_NLS 12 | # include 13 | #else 14 | static inline const char *gettext(const char *txt) { return txt; } 15 | static inline void textdomain(const char *domainname) {} 16 | static inline void bindtextdomain(const char *name, const char *dir) {} 17 | static inline char *bind_textdomain_codeset(const char *dn, char *c) { return c; } 18 | #endif 19 | 20 | #ifdef __cplusplus 21 | extern "C" { 22 | #endif 23 | 24 | #ifdef LKC_DIRECT_LINK 25 | #define P(name,type,arg) extern type name arg 26 | #else 27 | #include "lkc_defs.h" 28 | #define P(name,type,arg) extern type (*name ## _p) arg 29 | #endif 30 | #include "lkc_proto.h" 31 | #undef P 32 | 33 | #define SRCTREE "srctree" 34 | 35 | #ifndef PACKAGE 36 | #define PACKAGE "linux" 37 | #endif 38 | 39 | #define LOCALEDIR "/usr/share/locale" 40 | 41 | #define _(text) gettext(text) 42 | #define N_(text) (text) 43 | 44 | #ifndef CONFIG_ 45 | #define CONFIG_ "CONFIG_" 46 | #endif 47 | 48 | #define TF_COMMAND 0x0001 49 | #define TF_PARAM 0x0002 50 | #define TF_OPTION 0x0004 51 | 52 | enum conf_def_mode { 53 | def_default, 54 | def_yes, 55 | def_mod, 56 | def_no, 57 | def_random 58 | }; 59 | 60 | #define T_OPT_MODULES 1 61 | #define T_OPT_DEFCONFIG_LIST 2 62 | #define T_OPT_ENV 3 63 | 64 | struct kconf_id { 65 | int name; 66 | int token; 67 | unsigned int flags; 68 | enum symbol_type stype; 69 | }; 70 | 71 | #ifdef YYDEBUG 72 | extern int zconfdebug; 73 | #endif 74 | 75 | int zconfparse(void); 76 | void zconfdump(FILE *out); 77 | void zconf_starthelp(void); 78 | FILE *zconf_fopen(const char *name); 79 | void zconf_initscan(const char *name); 80 | void zconf_nextfile(const char *name); 81 | int zconf_lineno(void); 82 | const char *zconf_curname(void); 83 | 84 | /* conf.c */ 85 | void xfgets(char *str, int size, FILE *in); 86 | 87 | /* confdata.c */ 88 | const char *conf_get_configname(void); 89 | const char *conf_get_autoconfig_name(void); 90 | char *conf_get_default_confname(void); 91 | void sym_set_change_count(int count); 92 | void sym_add_change_count(int count); 93 | void conf_set_all_new_symbols(enum conf_def_mode mode); 94 | 95 | /* confdata.c and expr.c */ 96 | static inline void xfwrite(const void *str, size_t len, size_t count, FILE *out) 97 | { 98 | if (fwrite(str, len, count, out) < count) 99 | fprintf(stderr, "\nError in writing or end of file.\n"); 100 | } 101 | 102 | /* kconfig_load.c */ 103 | void kconfig_load(void); 104 | 105 | /* menu.c */ 106 | void _menu_init(void); 107 | void menu_warn(struct menu *menu, const char *fmt, ...); 108 | struct menu *menu_add_menu(void); 109 | void menu_end_menu(void); 110 | void menu_add_entry(struct symbol *sym); 111 | void menu_end_entry(void); 112 | void menu_add_dep(struct expr *dep); 113 | void menu_add_visibility(struct expr *dep); 114 | struct property *menu_add_prop(enum prop_type type, char *prompt, struct expr *expr, struct expr *dep); 115 | struct property *menu_add_prompt(enum prop_type type, char *prompt, struct expr *dep); 116 | void menu_add_expr(enum prop_type type, struct expr *expr, struct expr *dep); 117 | void menu_add_symbol(enum prop_type type, struct symbol *sym, struct expr *dep); 118 | void menu_add_option(int token, char *arg); 119 | void menu_finalize(struct menu *parent); 120 | void menu_set_type(int type); 121 | 122 | /* util.c */ 123 | struct file *file_lookup(const char *name); 124 | int file_write_dep(const char *name); 125 | 126 | struct gstr { 127 | size_t len; 128 | char *s; 129 | /* 130 | * when max_width is not zero long lines in string s (if any) get 131 | * wrapped not to exceed the max_width value 132 | */ 133 | int max_width; 134 | }; 135 | struct gstr str_new(void); 136 | struct gstr str_assign(const char *s); 137 | void str_free(struct gstr *gs); 138 | void str_append(struct gstr *gs, const char *s); 139 | void str_printf(struct gstr *gs, const char *fmt, ...); 140 | const char *str_get(struct gstr *gs); 141 | 142 | /* symbol.c */ 143 | extern struct expr *sym_env_list; 144 | 145 | void sym_init(void); 146 | void sym_clear_all_valid(void); 147 | void sym_set_all_changed(void); 148 | void sym_set_changed(struct symbol *sym); 149 | struct symbol *sym_choice_default(struct symbol *sym); 150 | const char *sym_get_string_default(struct symbol *sym); 151 | struct symbol *sym_check_deps(struct symbol *sym); 152 | struct property *prop_alloc(enum prop_type type, struct symbol *sym); 153 | struct symbol *prop_get_symbol(struct property *prop); 154 | struct property *sym_get_env_prop(struct symbol *sym); 155 | 156 | static inline tristate sym_get_tristate_value(struct symbol *sym) 157 | { 158 | return sym->curr.tri; 159 | } 160 | 161 | 162 | static inline struct symbol *sym_get_choice_value(struct symbol *sym) 163 | { 164 | return (struct symbol *)sym->curr.val; 165 | } 166 | 167 | static inline bool sym_set_choice_value(struct symbol *ch, struct symbol *chval) 168 | { 169 | return sym_set_tristate_value(chval, yes); 170 | } 171 | 172 | static inline bool sym_is_choice(struct symbol *sym) 173 | { 174 | return sym->flags & SYMBOL_CHOICE ? true : false; 175 | } 176 | 177 | static inline bool sym_is_choice_value(struct symbol *sym) 178 | { 179 | return sym->flags & SYMBOL_CHOICEVAL ? true : false; 180 | } 181 | 182 | static inline bool sym_is_optional(struct symbol *sym) 183 | { 184 | return sym->flags & SYMBOL_OPTIONAL ? true : false; 185 | } 186 | 187 | static inline bool sym_has_value(struct symbol *sym) 188 | { 189 | return sym->flags & SYMBOL_DEF_USER ? true : false; 190 | } 191 | 192 | #ifdef __cplusplus 193 | } 194 | #endif 195 | 196 | #endif /* LKC_H */ 197 | -------------------------------------------------------------------------------- /vm/kconfig/lkc_proto.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | /* confdata.c */ 4 | P(conf_parse,void,(const char *name)); 5 | P(conf_read,int,(const char *name)); 6 | P(conf_read_simple,int,(const char *name, int)); 7 | P(conf_write_defconfig,int,(const char *name)); 8 | P(conf_write,int,(const char *name)); 9 | P(conf_write_autoconf,int,(void)); 10 | P(conf_get_changed,bool,(void)); 11 | P(conf_set_changed_callback, void,(void (*fn)(void))); 12 | P(conf_set_message_callback, void,(void (*fn)(const char *fmt, va_list ap))); 13 | 14 | /* menu.c */ 15 | P(rootmenu,struct menu,); 16 | 17 | P(menu_is_visible, bool, (struct menu *menu)); 18 | P(menu_has_prompt, bool, (struct menu *menu)); 19 | P(menu_get_prompt,const char *,(struct menu *menu)); 20 | P(menu_get_root_menu,struct menu *,(struct menu *menu)); 21 | P(menu_get_parent_menu,struct menu *,(struct menu *menu)); 22 | P(menu_has_help,bool,(struct menu *menu)); 23 | P(menu_get_help,const char *,(struct menu *menu)); 24 | P(get_symbol_str, void, (struct gstr *r, struct symbol *sym)); 25 | P(get_relations_str, struct gstr, (struct symbol **sym_arr)); 26 | P(menu_get_ext_help,void,(struct menu *menu, struct gstr *help)); 27 | 28 | /* symbol.c */ 29 | P(symbol_hash,struct symbol *,[SYMBOL_HASHSIZE]); 30 | 31 | P(sym_lookup,struct symbol *,(const char *name, int flags)); 32 | P(sym_find,struct symbol *,(const char *name)); 33 | P(sym_expand_string_value,const char *,(const char *in)); 34 | P(sym_re_search,struct symbol **,(const char *pattern)); 35 | P(sym_type_name,const char *,(enum symbol_type type)); 36 | P(sym_calc_value,void,(struct symbol *sym)); 37 | P(sym_get_type,enum symbol_type,(struct symbol *sym)); 38 | P(sym_tristate_within_range,bool,(struct symbol *sym,tristate tri)); 39 | P(sym_set_tristate_value,bool,(struct symbol *sym,tristate tri)); 40 | P(sym_toggle_tristate_value,tristate,(struct symbol *sym)); 41 | P(sym_string_valid,bool,(struct symbol *sym, const char *newval)); 42 | P(sym_string_within_range,bool,(struct symbol *sym, const char *str)); 43 | P(sym_set_string_value,bool,(struct symbol *sym, const char *newval)); 44 | P(sym_is_changable,bool,(struct symbol *sym)); 45 | P(sym_get_choice_prop,struct property *,(struct symbol *sym)); 46 | P(sym_get_default_prop,struct property *,(struct symbol *sym)); 47 | P(sym_get_string_value,const char *,(struct symbol *sym)); 48 | 49 | P(prop_get_type_name,const char *,(enum prop_type type)); 50 | 51 | /* expr.c */ 52 | P(expr_compare_type,int,(enum expr_type t1, enum expr_type t2)); 53 | P(expr_print,void,(struct expr *e, void (*fn)(void *, struct symbol *, const char *), void *data, int prevtoken)); 54 | -------------------------------------------------------------------------------- /vm/kconfig/nconf.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2008 Nir Tzachar 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include 19 | #include 20 | #include 21 | #include 22 | 23 | #include 24 | #include 25 | #include 26 | 27 | #include "ncurses.h" 28 | 29 | #define max(a, b) ({\ 30 | typeof(a) _a = a;\ 31 | typeof(b) _b = b;\ 32 | _a > _b ? _a : _b; }) 33 | 34 | #define min(a, b) ({\ 35 | typeof(a) _a = a;\ 36 | typeof(b) _b = b;\ 37 | _a < _b ? _a : _b; }) 38 | 39 | typedef enum { 40 | NORMAL = 1, 41 | MAIN_HEADING, 42 | MAIN_MENU_BOX, 43 | MAIN_MENU_FORE, 44 | MAIN_MENU_BACK, 45 | MAIN_MENU_GREY, 46 | MAIN_MENU_HEADING, 47 | SCROLLWIN_TEXT, 48 | SCROLLWIN_HEADING, 49 | SCROLLWIN_BOX, 50 | DIALOG_TEXT, 51 | DIALOG_MENU_FORE, 52 | DIALOG_MENU_BACK, 53 | DIALOG_BOX, 54 | INPUT_BOX, 55 | INPUT_HEADING, 56 | INPUT_TEXT, 57 | INPUT_FIELD, 58 | FUNCTION_TEXT, 59 | FUNCTION_HIGHLIGHT, 60 | ATTR_MAX 61 | } attributes_t; 62 | extern attributes_t attributes[]; 63 | 64 | typedef enum { 65 | F_HELP = 1, 66 | F_SYMBOL = 2, 67 | F_INSTS = 3, 68 | F_CONF = 4, 69 | F_BACK = 5, 70 | F_SAVE = 6, 71 | F_LOAD = 7, 72 | F_SEARCH = 8, 73 | F_EXIT = 9, 74 | } function_key; 75 | 76 | void set_colors(void); 77 | 78 | /* this changes the windows attributes !!! */ 79 | void print_in_middle(WINDOW *win, 80 | int starty, 81 | int startx, 82 | int width, 83 | const char *string, 84 | chtype color); 85 | int get_line_length(const char *line); 86 | int get_line_no(const char *text); 87 | const char *get_line(const char *text, int line_no); 88 | void fill_window(WINDOW *win, const char *text); 89 | int btn_dialog(WINDOW *main_window, const char *msg, int btn_num, ...); 90 | int dialog_inputbox(WINDOW *main_window, 91 | const char *title, const char *prompt, 92 | const char *init, char *result, int result_len); 93 | void refresh_all_windows(WINDOW *main_window); 94 | void show_scroll_win(WINDOW *main_window, 95 | const char *title, 96 | const char *text); 97 | -------------------------------------------------------------------------------- /vm/kconfig/util.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2002-2005 Roman Zippel 3 | * Copyright (C) 2002-2005 Sam Ravnborg 4 | * 5 | * Released under the terms of the GNU GPL v2.0. 6 | */ 7 | 8 | #include 9 | #include "lkc.h" 10 | 11 | /* file already present in list? If not add it */ 12 | struct file *file_lookup(const char *name) 13 | { 14 | struct file *file; 15 | const char *file_name = sym_expand_string_value(name); 16 | 17 | for (file = file_list; file; file = file->next) { 18 | if (!strcmp(name, file->name)) { 19 | free((void *)file_name); 20 | return file; 21 | } 22 | } 23 | 24 | file = malloc(sizeof(*file)); 25 | memset(file, 0, sizeof(*file)); 26 | file->name = file_name; 27 | file->next = file_list; 28 | file_list = file; 29 | return file; 30 | } 31 | 32 | /* write a dependency file as used by kbuild to track dependencies */ 33 | int file_write_dep(const char *name) 34 | { 35 | struct symbol *sym, *env_sym; 36 | struct expr *e; 37 | struct file *file; 38 | FILE *out; 39 | 40 | if (!name) 41 | name = ".kconfig.d"; 42 | out = fopen("..config.tmp", "w"); 43 | if (!out) 44 | return 1; 45 | fprintf(out, "deps_config := \\\n"); 46 | for (file = file_list; file; file = file->next) { 47 | if (file->next) 48 | fprintf(out, "\t%s \\\n", file->name); 49 | else 50 | fprintf(out, "\t%s\n", file->name); 51 | } 52 | fprintf(out, "\n%s: \\\n" 53 | "\t$(deps_config)\n\n", conf_get_autoconfig_name()); 54 | 55 | expr_list_for_each_sym(sym_env_list, e, sym) { 56 | struct property *prop; 57 | const char *value; 58 | 59 | prop = sym_get_env_prop(sym); 60 | env_sym = prop_get_symbol(prop); 61 | if (!env_sym) 62 | continue; 63 | value = getenv(env_sym->name); 64 | if (!value) 65 | value = ""; 66 | fprintf(out, "ifneq \"$(%s)\" \"%s\"\n", env_sym->name, value); 67 | fprintf(out, "%s: FORCE\n", conf_get_autoconfig_name()); 68 | fprintf(out, "endif\n"); 69 | } 70 | 71 | fprintf(out, "\n$(deps_config): ;\n"); 72 | fclose(out); 73 | rename("..config.tmp", name); 74 | return 0; 75 | } 76 | 77 | 78 | /* Allocate initial growable string */ 79 | struct gstr str_new(void) 80 | { 81 | struct gstr gs; 82 | gs.s = malloc(sizeof(char) * 64); 83 | gs.len = 64; 84 | gs.max_width = 0; 85 | strcpy(gs.s, "\0"); 86 | return gs; 87 | } 88 | 89 | /* Allocate and assign growable string */ 90 | struct gstr str_assign(const char *s) 91 | { 92 | struct gstr gs; 93 | gs.s = strdup(s); 94 | gs.len = strlen(s) + 1; 95 | gs.max_width = 0; 96 | return gs; 97 | } 98 | 99 | /* Free storage for growable string */ 100 | void str_free(struct gstr *gs) 101 | { 102 | if (gs->s) 103 | free(gs->s); 104 | gs->s = NULL; 105 | gs->len = 0; 106 | } 107 | 108 | /* Append to growable string */ 109 | void str_append(struct gstr *gs, const char *s) 110 | { 111 | size_t l; 112 | if (s) { 113 | l = strlen(gs->s) + strlen(s) + 1; 114 | if (l > gs->len) { 115 | gs->s = realloc(gs->s, l); 116 | gs->len = l; 117 | } 118 | strcat(gs->s, s); 119 | } 120 | } 121 | 122 | /* Append printf formatted string to growable string */ 123 | void str_printf(struct gstr *gs, const char *fmt, ...) 124 | { 125 | va_list ap; 126 | char s[10000]; /* big enough... */ 127 | va_start(ap, fmt); 128 | vsnprintf(s, sizeof(s), fmt, ap); 129 | str_append(gs, s); 130 | va_end(ap); 131 | } 132 | 133 | /* Retrieve value of growable string */ 134 | const char *str_get(struct gstr *gs) 135 | { 136 | return gs->s; 137 | } 138 | 139 | -------------------------------------------------------------------------------- /vm/kconfig/zconf.gperf: -------------------------------------------------------------------------------- 1 | %language=ANSI-C 2 | %define hash-function-name kconf_id_hash 3 | %define lookup-function-name kconf_id_lookup 4 | %define string-pool-name kconf_id_strings 5 | %compare-strncmp 6 | %enum 7 | %pic 8 | %struct-type 9 | 10 | struct kconf_id; 11 | 12 | static struct kconf_id *kconf_id_lookup(register const char *str, register unsigned int len); 13 | 14 | %% 15 | mainmenu, T_MAINMENU, TF_COMMAND 16 | menu, T_MENU, TF_COMMAND 17 | endmenu, T_ENDMENU, TF_COMMAND 18 | source, T_SOURCE, TF_COMMAND 19 | choice, T_CHOICE, TF_COMMAND 20 | endchoice, T_ENDCHOICE, TF_COMMAND 21 | comment, T_COMMENT, TF_COMMAND 22 | config, T_CONFIG, TF_COMMAND 23 | menuconfig, T_MENUCONFIG, TF_COMMAND 24 | help, T_HELP, TF_COMMAND 25 | if, T_IF, TF_COMMAND|TF_PARAM 26 | endif, T_ENDIF, TF_COMMAND 27 | depends, T_DEPENDS, TF_COMMAND 28 | optional, T_OPTIONAL, TF_COMMAND 29 | default, T_DEFAULT, TF_COMMAND, S_UNKNOWN 30 | prompt, T_PROMPT, TF_COMMAND 31 | tristate, T_TYPE, TF_COMMAND, S_TRISTATE 32 | def_tristate, T_DEFAULT, TF_COMMAND, S_TRISTATE 33 | bool, T_TYPE, TF_COMMAND, S_BOOLEAN 34 | boolean, T_TYPE, TF_COMMAND, S_BOOLEAN 35 | def_bool, T_DEFAULT, TF_COMMAND, S_BOOLEAN 36 | int, T_TYPE, TF_COMMAND, S_INT 37 | hex, T_TYPE, TF_COMMAND, S_HEX 38 | string, T_TYPE, TF_COMMAND, S_STRING 39 | select, T_SELECT, TF_COMMAND 40 | range, T_RANGE, TF_COMMAND 41 | visible, T_VISIBLE, TF_COMMAND 42 | option, T_OPTION, TF_COMMAND 43 | on, T_ON, TF_PARAM 44 | modules, T_OPT_MODULES, TF_OPTION 45 | defconfig_list, T_OPT_DEFCONFIG_LIST,TF_OPTION 46 | env, T_OPT_ENV, TF_OPTION 47 | %% 48 | -------------------------------------------------------------------------------- /vm/kconfig/zconf.l: -------------------------------------------------------------------------------- 1 | %option backup nostdinit noyywrap never-interactive full ecs 2 | %option 8bit backup nodefault perf-report perf-report 3 | %option noinput 4 | %x COMMAND HELP STRING PARAM 5 | %{ 6 | /* 7 | * Copyright (C) 2002 Roman Zippel 8 | * Released under the terms of the GNU GPL v2.0. 9 | */ 10 | 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | 17 | #define LKC_DIRECT_LINK 18 | #include "lkc.h" 19 | 20 | #define START_STRSIZE 16 21 | 22 | static struct { 23 | struct file *file; 24 | int lineno; 25 | } current_pos; 26 | 27 | static char *text; 28 | static int text_size, text_asize; 29 | 30 | struct buffer { 31 | struct buffer *parent; 32 | YY_BUFFER_STATE state; 33 | }; 34 | 35 | struct buffer *current_buf; 36 | 37 | static int last_ts, first_ts; 38 | 39 | static void zconf_endhelp(void); 40 | static void zconf_endfile(void); 41 | 42 | static void new_string(void) 43 | { 44 | text = malloc(START_STRSIZE); 45 | text_asize = START_STRSIZE; 46 | text_size = 0; 47 | *text = 0; 48 | } 49 | 50 | static void append_string(const char *str, int size) 51 | { 52 | int new_size = text_size + size + 1; 53 | if (new_size > text_asize) { 54 | new_size += START_STRSIZE - 1; 55 | new_size &= -START_STRSIZE; 56 | text = realloc(text, new_size); 57 | text_asize = new_size; 58 | } 59 | memcpy(text + text_size, str, size); 60 | text_size += size; 61 | text[text_size] = 0; 62 | } 63 | 64 | static void alloc_string(const char *str, int size) 65 | { 66 | text = malloc(size + 1); 67 | memcpy(text, str, size); 68 | text[size] = 0; 69 | } 70 | %} 71 | 72 | ws [ \n\t] 73 | n [A-Za-z0-9_] 74 | 75 | %% 76 | int str = 0; 77 | int ts, i; 78 | 79 | [ \t]*#.*\n | 80 | [ \t]*\n { 81 | current_file->lineno++; 82 | return T_EOL; 83 | } 84 | [ \t]*#.* 85 | 86 | 87 | [ \t]+ { 88 | BEGIN(COMMAND); 89 | } 90 | 91 | . { 92 | unput(yytext[0]); 93 | BEGIN(COMMAND); 94 | } 95 | 96 | 97 | { 98 | {n}+ { 99 | struct kconf_id *id = kconf_id_lookup(yytext, yyleng); 100 | BEGIN(PARAM); 101 | current_pos.file = current_file; 102 | current_pos.lineno = current_file->lineno; 103 | if (id && id->flags & TF_COMMAND) { 104 | zconflval.id = id; 105 | return id->token; 106 | } 107 | alloc_string(yytext, yyleng); 108 | zconflval.string = text; 109 | return T_WORD; 110 | } 111 | . 112 | \n { 113 | BEGIN(INITIAL); 114 | current_file->lineno++; 115 | return T_EOL; 116 | } 117 | } 118 | 119 | { 120 | "&&" return T_AND; 121 | "||" return T_OR; 122 | "(" return T_OPEN_PAREN; 123 | ")" return T_CLOSE_PAREN; 124 | "!" return T_NOT; 125 | "=" return T_EQUAL; 126 | "!=" return T_UNEQUAL; 127 | \"|\' { 128 | str = yytext[0]; 129 | new_string(); 130 | BEGIN(STRING); 131 | } 132 | \n BEGIN(INITIAL); current_file->lineno++; return T_EOL; 133 | --- /* ignore */ 134 | ({n}|[-/.])+ { 135 | struct kconf_id *id = kconf_id_lookup(yytext, yyleng); 136 | if (id && id->flags & TF_PARAM) { 137 | zconflval.id = id; 138 | return id->token; 139 | } 140 | alloc_string(yytext, yyleng); 141 | zconflval.string = text; 142 | return T_WORD; 143 | } 144 | #.* /* comment */ 145 | \\\n current_file->lineno++; 146 | . 147 | <> { 148 | BEGIN(INITIAL); 149 | } 150 | } 151 | 152 | { 153 | [^'"\\\n]+/\n { 154 | append_string(yytext, yyleng); 155 | zconflval.string = text; 156 | return T_WORD_QUOTE; 157 | } 158 | [^'"\\\n]+ { 159 | append_string(yytext, yyleng); 160 | } 161 | \\.?/\n { 162 | append_string(yytext + 1, yyleng - 1); 163 | zconflval.string = text; 164 | return T_WORD_QUOTE; 165 | } 166 | \\.? { 167 | append_string(yytext + 1, yyleng - 1); 168 | } 169 | \'|\" { 170 | if (str == yytext[0]) { 171 | BEGIN(PARAM); 172 | zconflval.string = text; 173 | return T_WORD_QUOTE; 174 | } else 175 | append_string(yytext, 1); 176 | } 177 | \n { 178 | printf("%s:%d:warning: multi-line strings not supported\n", zconf_curname(), zconf_lineno()); 179 | current_file->lineno++; 180 | BEGIN(INITIAL); 181 | return T_EOL; 182 | } 183 | <> { 184 | BEGIN(INITIAL); 185 | } 186 | } 187 | 188 | { 189 | [ \t]+ { 190 | ts = 0; 191 | for (i = 0; i < yyleng; i++) { 192 | if (yytext[i] == '\t') 193 | ts = (ts & ~7) + 8; 194 | else 195 | ts++; 196 | } 197 | last_ts = ts; 198 | if (first_ts) { 199 | if (ts < first_ts) { 200 | zconf_endhelp(); 201 | return T_HELPTEXT; 202 | } 203 | ts -= first_ts; 204 | while (ts > 8) { 205 | append_string(" ", 8); 206 | ts -= 8; 207 | } 208 | append_string(" ", ts); 209 | } 210 | } 211 | [ \t]*\n/[^ \t\n] { 212 | current_file->lineno++; 213 | zconf_endhelp(); 214 | return T_HELPTEXT; 215 | } 216 | [ \t]*\n { 217 | current_file->lineno++; 218 | append_string("\n", 1); 219 | } 220 | [^ \t\n].* { 221 | while (yyleng) { 222 | if ((yytext[yyleng-1] != ' ') && (yytext[yyleng-1] != '\t')) 223 | break; 224 | yyleng--; 225 | } 226 | append_string(yytext, yyleng); 227 | if (!first_ts) 228 | first_ts = last_ts; 229 | } 230 | <> { 231 | zconf_endhelp(); 232 | return T_HELPTEXT; 233 | } 234 | } 235 | 236 | <> { 237 | if (current_file) { 238 | zconf_endfile(); 239 | return T_EOL; 240 | } 241 | fclose(yyin); 242 | yyterminate(); 243 | } 244 | 245 | %% 246 | void zconf_starthelp(void) 247 | { 248 | new_string(); 249 | last_ts = first_ts = 0; 250 | BEGIN(HELP); 251 | } 252 | 253 | static void zconf_endhelp(void) 254 | { 255 | zconflval.string = text; 256 | BEGIN(INITIAL); 257 | } 258 | 259 | 260 | /* 261 | * Try to open specified file with following names: 262 | * ./name 263 | * $(srctree)/name 264 | * The latter is used when srctree is separate from objtree 265 | * when compiling the kernel. 266 | * Return NULL if file is not found. 267 | */ 268 | FILE *zconf_fopen(const char *name) 269 | { 270 | char *env, fullname[PATH_MAX+1]; 271 | FILE *f; 272 | 273 | f = fopen(name, "r"); 274 | if (!f && name != NULL && name[0] != '/') { 275 | env = getenv(SRCTREE); 276 | if (env) { 277 | sprintf(fullname, "%s/%s", env, name); 278 | f = fopen(fullname, "r"); 279 | } 280 | } 281 | return f; 282 | } 283 | 284 | void zconf_initscan(const char *name) 285 | { 286 | yyin = zconf_fopen(name); 287 | if (!yyin) { 288 | printf("can't find file %s\n", name); 289 | exit(1); 290 | } 291 | 292 | current_buf = malloc(sizeof(*current_buf)); 293 | memset(current_buf, 0, sizeof(*current_buf)); 294 | 295 | current_file = file_lookup(name); 296 | current_file->lineno = 1; 297 | current_file->flags = FILE_BUSY; 298 | } 299 | 300 | void zconf_nextfile(const char *name) 301 | { 302 | struct file *file = file_lookup(name); 303 | struct buffer *buf = malloc(sizeof(*buf)); 304 | memset(buf, 0, sizeof(*buf)); 305 | 306 | current_buf->state = YY_CURRENT_BUFFER; 307 | yyin = zconf_fopen(file->name); 308 | if (!yyin) { 309 | printf("%s:%d: can't open file \"%s\"\n", 310 | zconf_curname(), zconf_lineno(), file->name); 311 | exit(1); 312 | } 313 | yy_switch_to_buffer(yy_create_buffer(yyin, YY_BUF_SIZE)); 314 | buf->parent = current_buf; 315 | current_buf = buf; 316 | 317 | if (file->flags & FILE_BUSY) { 318 | printf("%s:%d: do not source '%s' from itself\n", 319 | zconf_curname(), zconf_lineno(), name); 320 | exit(1); 321 | } 322 | if (file->flags & FILE_SCANNED) { 323 | printf("%s:%d: file '%s' is already sourced from '%s'\n", 324 | zconf_curname(), zconf_lineno(), name, 325 | file->parent->name); 326 | exit(1); 327 | } 328 | file->flags |= FILE_BUSY; 329 | file->lineno = 1; 330 | file->parent = current_file; 331 | current_file = file; 332 | } 333 | 334 | static void zconf_endfile(void) 335 | { 336 | struct buffer *parent; 337 | 338 | current_file->flags |= FILE_SCANNED; 339 | current_file->flags &= ~FILE_BUSY; 340 | current_file = current_file->parent; 341 | 342 | parent = current_buf->parent; 343 | if (parent) { 344 | fclose(yyin); 345 | yy_delete_buffer(YY_CURRENT_BUFFER); 346 | yy_switch_to_buffer(parent->state); 347 | } 348 | free(current_buf); 349 | current_buf = parent; 350 | } 351 | 352 | int zconf_lineno(void) 353 | { 354 | return current_pos.lineno; 355 | } 356 | 357 | const char *zconf_curname(void) 358 | { 359 | return current_pos.file ? current_pos.file->name : ""; 360 | } 361 | -------------------------------------------------------------------------------- /vm/scripts/prim-dispatchgen.awk: -------------------------------------------------------------------------------- 1 | function primgen(primclass, offset) { 2 | if(!pr[offset, "scheme_name"]) 3 | return; 4 | 5 | print "\tcase " primclass " :" 6 | print "#ifdef CONFIG_DEBUG_STRINGS" 7 | print "\t\tIF_TRACE(printf(\" (%s)\\n\", primitive_names[bytecode_lo4 + " offset "]));" 8 | print "#else" 9 | print "\t\tIF_TRACE(printf(\" ()\\n\"));" 10 | print "#endif" 11 | print "" 12 | print "\tswitch (bytecode_lo4) {" 13 | 14 | for(i=offset; i 3) 27 | print "\t\t\targ4 = pop ();" 28 | if(pr[i, "arguments"] > 2) 29 | print "\t\t\targ3 = pop ();" 30 | if(pr[i, "arguments"] > 1) 31 | print "\t\t\targ2 = pop ();" 32 | if(pr[i, "arguments"] > 0) 33 | print "\t\t\targ1 = pop ();" 34 | 35 | print "\t\t\tprim_" pr[i, "c_name"] " ();" 36 | 37 | if(!match(pr[i, "scheme_options"], "unspecified-result")) 38 | print "\t\t\tpush_arg1 ();" 39 | 40 | print "\t\t\tbreak;" 41 | print "" 42 | } 43 | 44 | print "\t}" 45 | print "" 46 | print "\tgoto dispatch;" 47 | print "" 48 | } 49 | 50 | END { 51 | primgen("PRIM1", 0); 52 | primgen("PRIM2", 16); 53 | primgen("PRIM3", 32); 54 | primgen("PRIM4", 48); 55 | } 56 | -------------------------------------------------------------------------------- /vm/scripts/prim-headergen.awk: -------------------------------------------------------------------------------- 1 | END { 2 | print "#include " 3 | print "#include " 4 | print "" 5 | print "#ifdef CONFIG_DEBUG_STRINGS" 6 | print "const char* const primitive_names[] = {" 7 | 8 | for(i=0; i 64) { 21 | print "" >"/dev/stderr" 22 | print " ERROR: More than 64 primitives are defined." >"/dev/stderr" 23 | print " The bytecode cannot reference more than 64 different" >"/dev/stderr" 24 | print " primitives at the moment." >"/dev/stderr" 25 | print "" >"/dev/stderr" 26 | exit 1 27 | } 28 | } 29 | --------------------------------------------------------------------------------