├── .gitignore ├── LICENCE ├── 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 ├── pretty-printer.rkt ├── primitives.rkt ├── reader.rkt ├── scheduling.rkt ├── tree-shaker.rkt └── utilities.rkt ├── p ├── picobit ├── robot ├── robot.bat ├── robot.scm ├── run-tests.rkt ├── tests ├── fail │ ├── compile │ │ ├── define-ordering.expected │ │ ├── define-ordering.scm │ │ ├── unbound.expected │ │ └── unbound.scm │ └── execute │ │ ├── car-number.expected │ │ └── car-number.scm └── 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 │ ├── div.expected │ ├── div.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 │ ├── io.expected │ ├── io.input │ ├── io.scm │ ├── ior.expected │ ├── ior.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 │ ├── 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 │ ├── 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 ├── check-encoding.sh ├── 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 run-tests.rkt 18 | racket 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") 4 | 5 | ;----------------------------------------------------------------------------- 6 | 7 | (provide immutable-var? mutable-var? 8 | toplevel-prc? 9 | toplevel-prc-with-non-rest-correct-calls? 10 | side-effect-less?) 11 | 12 | (define (immutable-var? var) (null? (var-sets var))) 13 | (define (mutable-var? var) (not (immutable-var? var))) 14 | 15 | (define (toplevel-prc? var) 16 | (and (not (mutable-var? var)) 17 | (let ([d (var-defs var)]) 18 | (and (pair? d) 19 | (null? (cdr d)) 20 | (let ([val (child1 (car d))]) 21 | (and (prc? val) 22 | val)))))) 23 | 24 | (define (toplevel-prc-with-non-rest-correct-calls? var) 25 | (let ([prc (toplevel-prc? var)]) 26 | (and prc 27 | (not (prc-rest? prc)) 28 | (andmap (lambda (r) 29 | (let ([parent (node-parent r)]) 30 | (and (call? parent) 31 | (eq? (child1 parent) r) 32 | (= (length (prc-params prc)) 33 | (- (length (node-children parent)) 1))))) 34 | (var-refs var)) 35 | prc))) 36 | 37 | (define (side-effect-less? node) (or (cst? node) (ref? node) (prc? node))) 38 | 39 | ;----------------------------------------------------------------------------- 40 | 41 | ;; Free variable analysis. 42 | 43 | (provide global-fv 44 | non-global-fv 45 | fv) 46 | 47 | (require (except-in racket/set 48 | set? set)) ; to avoid collision with the node type 49 | 50 | ;; varsets are eq? sets 51 | 52 | (define (build-params-varset params) 53 | (list->seteq params)) 54 | 55 | ;; These two are for outside consumption, so they return results as lists. 56 | (define (global-fv node) 57 | (filter var-global? 58 | (set->list (fv node)))) 59 | (define (non-global-fv node) 60 | (filter (lambda (x) (not (var-global? x))) 61 | (set->list (fv node)))) 62 | 63 | (define (fv node) 64 | (match node 65 | [(? cst? node) 66 | (seteq)] ; empty varset 67 | [(ref _ '() var) 68 | (seteq var)] ; singleton varset 69 | [(def _ `(,val) var) 70 | (set-add (fv val) var)] 71 | [(set _ `(,val) var) 72 | (set-add (fv val) var)] 73 | [(prc _ `(,body) params rest? entry-label) 74 | (set-subtract 75 | (fv body) 76 | (build-params-varset params))] 77 | [(or (? if*? node) (? call? node) (? seq? node)) 78 | (apply set-union (map fv (node-children node)))] 79 | [_ 80 | (compiler-error "unknown expression type" node)])) 81 | -------------------------------------------------------------------------------- /compiler/ast.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | (require racket/list) ;; take 5 | (require "utilities.rkt" "env.rkt") 6 | 7 | ;; Syntax-tree node representation. 8 | 9 | (define-struct node (parent children) #:mutable #:transparent) 10 | 11 | (define (child1 node) (car (node-children node))) 12 | (define (child2 node) (cadr (node-children node))) 13 | (define (child3 node) (caddr (node-children node))) 14 | 15 | (define-struct (cst node) (val)) 16 | (define-struct (ref node) (var) #:mutable) 17 | (define-struct (def node) (var)) ; children: (rhs) 18 | (define-struct (set node) (var)) ; children: (rhs) 19 | (define-struct (if* node) ()) ; children: (test then else) 20 | (define-struct (prc node) ; children: (body) 21 | ((params #:mutable) 22 | rest? 23 | (entry-label #:mutable))) 24 | (define-struct (call node) ()) ; children: (op . args) 25 | (define-struct (seq node) ()) ; children: (body ...) 26 | 27 | 28 | (define (extract-ids pattern) 29 | (cond [(pair? pattern) 30 | (cons (car pattern) (extract-ids (cdr pattern)))] 31 | [(symbol? pattern) 32 | (cons pattern '())] 33 | [else 34 | '()])) 35 | 36 | (define (has-rest-param? pattern) 37 | (if (pair? pattern) 38 | (has-rest-param? (cdr pattern)) 39 | (symbol? pattern))) 40 | -------------------------------------------------------------------------------- /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/comp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide comp-none) 4 | (require "utilities.rkt" "ir.rkt" "code-gen.rkt" "ast.rkt" "env.rkt" 5 | "analysis.rkt") 6 | 7 | 8 | (define (comp-none node ctx) 9 | (match node 10 | [(or (? cst? node) (? ref? node) (? prc? node)) 11 | ctx] ; we can drop any of these if we don't care about their value 12 | [(def _ `(,rhs) var) 13 | (if (toplevel-prc-with-non-rest-correct-calls? var) 14 | (comp-prc rhs #f ctx) 15 | (if (var-needed? var) 16 | (let ([ctx2 (comp-push rhs ctx)]) 17 | (gen-set-global (var-id var) ctx2)) 18 | (comp-none rhs ctx)))] 19 | [(set _ `(,rhs) var) 20 | (if (var-needed? var) 21 | (let ((ctx2 (comp-push rhs ctx))) 22 | (gen-set-global (var-id var) ctx2)) 23 | (comp-none rhs ctx))] 24 | [(? if*? node) 25 | (comp-if node 'none ctx)] 26 | [(? call? node) 27 | (comp-call node 'none ctx)] 28 | [(? seq? node) 29 | (comp-seq node 'none ctx)] 30 | [_ 31 | (compiler-error "unknown expression type" node)])) 32 | 33 | (define (comp-tail node ctx) 34 | (match node 35 | [(or (? cst? node) (? ref? node) (? def? node) (? set? node) (? prc? node)) 36 | (gen-return (comp-push node ctx))] 37 | [(? if*? node) 38 | (comp-if node 'tail ctx)] 39 | [(? call? node) 40 | (comp-call node 'tail ctx)] 41 | [(? seq? node) 42 | (comp-seq node 'tail ctx)] 43 | [_ 44 | (compiler-error "unknown expression type" node)])) 45 | 46 | (define (comp-push node ctx) 47 | (match node 48 | [(cst _ '() val) 49 | (gen-push-constant val ctx)] 50 | [(ref _ '() var) 51 | (cond [(not (var-global? var)) 52 | (gen-push-local-var (var-id var) ctx)] 53 | ;; primitive used in a higher-order fashion, eta-expand 54 | [(var-primitive var) => 55 | (lambda (prim) 56 | (comp-push ((primitive-eta-expansion prim)) ctx))] 57 | [(not (null? (var-defs var))) 58 | (define val (child1 (car (var-defs var)))) 59 | (if (and (not (mutable-var? var)) 60 | (cst? val)) ; immutable global, counted as cst 61 | (gen-push-constant (cst-val val) ctx) 62 | (gen-push-global (var-id var) ctx))] 63 | [else 64 | (compiler-error "undefined variable:" (var-id var))])] 65 | [(or (? def? node) (? set? node)) 66 | (gen-push-unspecified (comp-none node ctx))] 67 | [(? if*? node) 68 | (comp-if node 'push ctx)] 69 | [(? prc? node) 70 | (comp-prc node #t ctx)] 71 | [(? call? node) 72 | (comp-call node 'push ctx)] 73 | [(? seq? node) 74 | (comp-seq node 'push ctx)] 75 | [_ 76 | (compiler-error "unknown expression type" node)])) 77 | 78 | (define (comp-if node reason ctx) 79 | (match node 80 | [(if* _ `(,tst ,thn ,els)) 81 | (case reason 82 | [(none push) 83 | (let*-values 84 | ([(rec-comp) (if (eq? reason 'none) comp-none comp-push)] 85 | [(ctx2 label-then) (context-make-label ctx)] 86 | [(ctx3 label-else) (context-make-label ctx2)] 87 | [(ctx4 label-then-join) (context-make-label ctx3)] 88 | [(ctx5 label-else-join) (context-make-label ctx4)] 89 | [(ctx6 label-join) (context-make-label ctx5)] 90 | [(ctx7) (comp-test tst label-then label-else ctx6)] 91 | [(ctx8) (gen-goto 92 | label-else-join 93 | (rec-comp els (context-change-env2 94 | (context-add-bb ctx7 label-else) 95 | #f)))] 96 | [(ctx9) (gen-goto 97 | label-then-join 98 | (rec-comp thn (context-change-env 99 | (context-add-bb ctx8 label-then) 100 | (context-env2 ctx7))))] 101 | [(ctx10) (gen-goto 102 | label-join 103 | (context-add-bb ctx9 label-else-join))] 104 | [(ctx11) (gen-goto 105 | label-join 106 | (context-add-bb ctx10 label-then-join))] 107 | [(ctx12) (context-add-bb ctx11 label-join)]) 108 | ctx12)] 109 | [(tail) 110 | (let*-values 111 | ([(ctx2 label-then) (context-make-label ctx)] 112 | [(ctx3 label-else) (context-make-label ctx2)] 113 | [(ctx4) (comp-test tst label-then label-else ctx3)] 114 | [(ctx5) (comp-tail els 115 | (context-change-env2 116 | (context-add-bb ctx4 label-else) 117 | #f))] 118 | [(ctx6) (comp-tail thn 119 | (context-change-env 120 | (context-add-bb ctx5 label-then) 121 | (context-env2 ctx4)))]) 122 | ctx6)])])) 123 | 124 | (define (comp-seq node reason ctx) 125 | (match node 126 | [(seq _ '()) 127 | (case reason 128 | [(none) ctx] 129 | [(tail) (gen-return (gen-push-unspecified ctx))] 130 | [(push) (gen-push-unspecified ctx)])] 131 | [(seq _ (? list? children)) 132 | (let ([rec-comp (case reason 133 | [(none) comp-none] 134 | [(tail) comp-tail] 135 | [(push) comp-push])]) 136 | (let loop ([lst children] 137 | [ctx ctx]) 138 | (if (null? (cdr lst)) 139 | (rec-comp (car lst) ctx) 140 | (loop (cdr lst) 141 | (comp-none (car lst) ctx)))))])) 142 | 143 | (define (build-closure label-entry vars ctx) 144 | 145 | (define (build vars ctx) 146 | (if (null? vars) 147 | (gen-push-constant '() ctx) 148 | (gen-prim 'cons 149 | 2 150 | #f 151 | (build (cdr vars) 152 | (gen-push-local-var (car vars) ctx))))) 153 | (if (null? vars) 154 | (gen-closure label-entry 155 | (gen-push-constant '() ctx)) 156 | (gen-closure label-entry 157 | (build vars ctx)))) 158 | 159 | (define (comp-prc node closure? ctx) 160 | (let*-values 161 | ([(ctx2 label-entry) (context-make-label ctx)] 162 | [(ctx3 label-continue) (context-make-label ctx2)] 163 | [(body-env) (prc->env node)] 164 | [(ctx4) 165 | (if closure? 166 | (build-closure label-entry (env-closed body-env) ctx3) 167 | ctx3)] 168 | [(ctx5) (gen-goto label-continue ctx4)] 169 | [(ctx6) (gen-entry (length (prc-params node)) 170 | (prc-rest? node) 171 | (context-add-bb 172 | (context-change-env ctx5 173 | body-env) 174 | label-entry))] 175 | [(ctx7) (comp-tail (child1 node) ctx6)]) 176 | (set-prc-entry-label! node label-entry) 177 | (context-add-bb (context-change-env ctx7 (context-env ctx5)) 178 | label-continue))) 179 | 180 | (define (prc->env prc) 181 | (make-env 182 | (let ([params (prc-params prc)]) 183 | (make-stack (length params) (map var-id params))) 184 | (map var-id (non-global-fv prc)))) 185 | 186 | (define (comp-call node reason orig-ctx) 187 | (match node 188 | [(call _ `(,op . ,args)) 189 | (define nargs (length args)) 190 | (define ctx 191 | (for/fold ([ctx orig-ctx]) 192 | ([arg (in-list args)]) 193 | ;; push all the arguments 194 | (comp-push arg ctx))) 195 | ;; generate the call itself 196 | (match op 197 | 198 | [(ref _ '() (? var-primitive var)) ; primitive call 199 | (define id (var-id var)) 200 | (define primitive (var-primitive var)) 201 | (define prim-nargs (primitive-nargs primitive)) 202 | (define result-ctx 203 | (if (not (= nargs prim-nargs)) 204 | (compiler-error 205 | "primitive called with wrong number of arguments" id) 206 | (gen-prim id prim-nargs 207 | (primitive-unspecified-result? primitive) 208 | ctx))) 209 | (define unspecified? (primitive-unspecified-result? primitive)) 210 | (define result 211 | (if unspecified? 212 | (gen-push-unspecified result-ctx) 213 | result-ctx)) 214 | (case reason 215 | [(tail) (gen-return result)] 216 | [(push) result] 217 | [else (if unspecified? 218 | result-ctx 219 | (gen-pop result-ctx))])] 220 | 221 | [(ref _ '() var) 222 | (=> unmatch) 223 | (cond [(toplevel-prc-with-non-rest-correct-calls? var) 224 | => 225 | (lambda (prc) 226 | (case reason 227 | [(tail) (gen-jump-toplevel nargs prc ctx)] 228 | [(push) (gen-call-toplevel nargs prc ctx)] 229 | [else (gen-pop (gen-call-toplevel nargs prc ctx))]))] 230 | [else (unmatch)])] 231 | 232 | [_ 233 | (let ([ctx2 (comp-push op ctx)]) 234 | (case reason 235 | [(tail) (gen-jump nargs ctx2)] 236 | [(push) (gen-call nargs ctx2)] 237 | [else (gen-pop (gen-call nargs ctx2))]))])])) 238 | 239 | (define (comp-test node label-true label-false ctx) 240 | (match node 241 | [(cst _ '() val) 242 | (let ([ctx2 (gen-goto (if val label-true label-false) ctx)]) 243 | (context-change-env2 ctx2 (context-env ctx2)))] 244 | [(or (? ref? node) (? def? node) (? set? node) (? if*? node) 245 | (? call? node) (? seq? node)) 246 | (let* ([ctx2 (comp-push node ctx)] 247 | [ctx3 (gen-goto-if-false label-false label-true ctx2)]) 248 | (context-change-env2 ctx3 (context-env ctx3)))] 249 | [(? prc? node) ; always true 250 | (let ([ctx2 (gen-goto label-true ctx)]) 251 | (context-change-env2 ctx2 (context-env ctx2)))] 252 | [_ 253 | (compiler-error "unknown expression type" node)])) 254 | -------------------------------------------------------------------------------- /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-struct var 10 | (id 11 | global? 12 | (refs #:mutable) 13 | (sets #:mutable) 14 | (defs #:mutable) 15 | (needed? #:mutable) 16 | primitive) 17 | #:transparent) 18 | 19 | (define-struct primitive 20 | (nargs 21 | (constant-folder #:mutable) ; added post-creation 22 | eta-expansion ; for higher-order uses 23 | unspecified-result?) 24 | #:transparent) 25 | 26 | (define allow-forward-references? (make-parameter #t)) 27 | 28 | (define/contract (env-lookup env id) ((mlistof var?) symbol? . -> . var?) 29 | (or (for/first ([b (in-mlist env)] 30 | #:when (eq? (var-id b) id)) 31 | b) 32 | ;; We didn't find it. If reasonable to do so, add it to the env. 33 | ;; This makes it possible to have forward references at the top level. 34 | (let ([x (make-var id #t '() '() '() #f #f)]) 35 | (unless (allow-forward-references?) 36 | (compiler-error "variable referenced before its definition:" id)) 37 | (mappend! env (mlist x)) 38 | x))) 39 | 40 | (define/contract (env-extend env ids def) 41 | ((mlistof var?) (listof symbol?) any/c . -> . (mlistof var?)) 42 | (mappend (list->mlist 43 | (map (lambda (id) 44 | (make-var id #f '() '() (list def) #f #f)) 45 | ids)) 46 | env)) 47 | -------------------------------------------------------------------------------- /compiler/front-end.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "utilities.rkt" "ast.rkt" "env.rkt" "analysis.rkt") 4 | 5 | ;; Front-end code transformations. 6 | 7 | ;------------------------------------------------------------------------------ 8 | 9 | (provide adjust-unmutable-references!) 10 | 11 | (define (adjust-unmutable-references! node) 12 | (match node 13 | [(call parent `(,(ref _ '() (app var-id '#%unbox)) 14 | ,(and child (ref _ '() (? immutable-var? v))))) 15 | (set-node-parent! child parent) 16 | (when parent 17 | (set-node-children! parent (for/list ([c (node-children parent)]) 18 | (if (eq? c node) child c)))) 19 | child] 20 | [_ 21 | (for-each adjust-unmutable-references! (node-children node)) 22 | node])) 23 | 24 | ;----------------------------------------------------------------------------- 25 | 26 | (provide mark-needed-global-vars!) 27 | 28 | (define (mark-var! var) 29 | (when (and (var-global? var) 30 | (not (var-needed? var)) 31 | ;; globals that obey the following conditions are considered 32 | ;; to be constants 33 | (not (and (not (mutable-var? var)) 34 | ;; to weed out primitives, which have no definitions 35 | (> (length (var-defs var)) 0) 36 | (cst? (child1 (car (var-defs var))))))) 37 | (set-var-needed?! var #t) 38 | (for ([def (in-list (var-defs var))]) 39 | (let ([val (child1 def)]) 40 | (when (side-effect-less? val) 41 | (mark-needed-global-vars! val)))))) 42 | 43 | (define (mark-needed-global-vars! node) 44 | (match node 45 | [(ref _ '() var) 46 | (mark-var! var)] 47 | [(def _ `(,val) var) 48 | (when (not (side-effect-less? val)) 49 | (mark-needed-global-vars! val))] 50 | [(or (? cst? node) (? set? node) (? if*? node) (? prc? node) 51 | (? call? node) (? seq? node)) 52 | (for-each mark-needed-global-vars! (node-children node))] 53 | [_ 54 | (compiler-error "unknown expression type" node)])) 55 | 56 | ;----------------------------------------------------------------------------- 57 | 58 | (provide inline-eta!) 59 | 60 | ;; When an eta-expansion is used in operator position, it can be replaced 61 | ;; by the function it's wrapping. 62 | ;; ex: (define (foo x y) (bar x y)) (foo 1) 63 | ;; => (bar 1) 64 | (define (inline-eta! node) 65 | (match node 66 | [(call p `(,(and orig-op (ref _ '() (app var-defs `(,d . ,rest)))) 67 | . ,args)) 68 | (=> unmatch) 69 | (match d 70 | [(def p `(,(prc _ `(,body) params #f entry)) v) 71 | (match body 72 | [(seq _ `(,(call p `(,(ref _ '() inside-op) . ,inside-args)))) 73 | (if (andmap ref? inside-args) 74 | ;; since the call is directly inside the lambda (no 75 | ;; intermediate scopes), we can compare ids directly 76 | (let ([inside-args (map (lambda (x) (var-id (ref-var x))) 77 | inside-args)] 78 | [params (map var-id params)]) 79 | (cond [(equal? inside-args params) 80 | ;; we can replace orig-op with inside-op 81 | (set-ref-var! orig-op inside-op)] 82 | [else (unmatch)])) 83 | (unmatch))] 84 | [_ (unmatch)])] 85 | [_ (unmatch)])] 86 | [_ 87 | (for-each inline-eta! (node-children node))])) 88 | 89 | ;----------------------------------------------------------------------------- 90 | 91 | (provide constant-fold!) 92 | 93 | (define (constant-fold! node) 94 | (match node 95 | ;; if we're calling a primitive 96 | [(call p `(,(ref _ '() (? var-primitive op)) 97 | . ,args)) 98 | (=> unmatch) 99 | (for-each constant-fold! args) ; fold args before the whole call 100 | (let ([folder (primitive-constant-folder (var-primitive op))] 101 | ;; (we need to access the children again (can't just use `args', 102 | ;; since constant folding may have mutated them) 103 | [args (cdr (node-children node))]) 104 | ;; the primitive can do constant-folding, and the args are constant 105 | ;; folder takes the values of the args, and returns the value of the res 106 | (cond [(and folder (andmap cst? args)) 107 | ;; if the folding would raise an error, just don't do it, and 108 | ;; error at runtime 109 | (call-with-exception-handler 110 | (lambda (e) (unmatch)) 111 | (lambda () 112 | (define res-val (apply folder (map cst-val args))) 113 | (define res (make-cst p '() res-val)) 114 | ;; replace the call with the constant 115 | (set-node-children! p (map (lambda (x) 116 | (if (eq? x node) res x)) 117 | (node-children p)))))] 118 | [else 119 | (unmatch)]))] 120 | [_ 121 | (for-each constant-fold! (node-children node))])) 122 | -------------------------------------------------------------------------------- /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/library.scm: -------------------------------------------------------------------------------- 1 | (define + 2 | (lambda (x . rest) 3 | (if (pair? rest) 4 | (#%+-aux x rest) 5 | x))) 6 | 7 | (define #%+-aux 8 | (lambda (x rest) 9 | (if (pair? rest) 10 | (#%+-aux (#%+ x (car rest)) (cdr rest)) 11 | x))) 12 | 13 | (define neg 14 | (lambda (x) 15 | (- 0 x))) 16 | 17 | (define - 18 | (lambda (x . rest) 19 | (if (pair? rest) 20 | (#%--aux x rest) 21 | (neg x)))) 22 | 23 | (define #%--aux 24 | (lambda (x rest) 25 | (if (pair? rest) 26 | (#%--aux (#%- x (car rest)) (cdr rest)) 27 | x))) 28 | 29 | (define * 30 | (lambda (x . rest) 31 | (if (pair? rest) 32 | (#%*-aux x rest) 33 | x))) 34 | 35 | (define #%*-aux 36 | (lambda (x rest) 37 | (if (pair? rest) 38 | (#%*-aux (#%mul x (car rest)) (cdr rest)) 39 | x))) 40 | 41 | (define #%mul 42 | (lambda (x y) 43 | (let* ((x-neg? (< x 0)) 44 | (y-neg? (< y 0)) 45 | (x (if x-neg? (neg x) x)) 46 | (y (if y-neg? (neg y) y))) 47 | (let ((prod (#%mul-non-neg x y))) 48 | (cond ((and x-neg? y-neg?) 49 | prod) 50 | ((or x-neg? y-neg?) 51 | (neg prod)) 52 | (else 53 | prod)))))) 54 | 55 | (define quotient ;; TODO similar to #%mul, abstract ? 56 | (lambda (x y) 57 | (let* ((x-neg? (< x 0)) 58 | (y-neg? (< y 0)) 59 | (x (if x-neg? (neg x) x)) 60 | (y (if y-neg? (neg y) y))) 61 | (let ((quot (#%div-non-neg x y))) 62 | (cond ((and x-neg? y-neg?) 63 | quot) 64 | ((or x-neg? y-neg?) 65 | (neg quot)) 66 | (else 67 | quot)))))) 68 | 69 | (define / quotient) 70 | 71 | 72 | (define <= 73 | (lambda (x y) 74 | (or (< x y) (= x y)))) 75 | 76 | (define >= 77 | (lambda (x y) 78 | (or (> x y) (= x y)))) 79 | 80 | (define list 81 | (lambda lst lst)) 82 | 83 | (define length 84 | (lambda (lst) 85 | (#%length-aux lst 0))) 86 | 87 | (define #%length-aux 88 | (lambda (lst n) 89 | (if (pair? lst) 90 | (#%length-aux (cdr lst) (#%+ n 1)) 91 | n))) 92 | 93 | (define append 94 | (lambda (lst1 lst2) 95 | (if (pair? lst1) 96 | (cons (car lst1) (append (cdr lst1) lst2)) 97 | lst2))) 98 | 99 | (define reverse 100 | (lambda (lst) 101 | (#%reverse-aux lst '()))) 102 | 103 | (define #%reverse-aux 104 | (lambda (lst rev) 105 | (if (pair? lst) 106 | (#%reverse-aux (cdr lst) (cons (car lst) rev)) 107 | rev))) 108 | 109 | (define list-ref 110 | (lambda (lst i) 111 | (if (= i 0) 112 | (car lst) 113 | (list-ref (cdr lst) (#%- i 1))))) 114 | 115 | (define list-set! 116 | (lambda (lst i x) 117 | (if (= i 0) 118 | (set-car! lst x) 119 | (list-set! (cdr lst) (#%- i 1) x)))) 120 | 121 | (define max 122 | (lambda (x y) 123 | (if (> x y) x y))) 124 | 125 | (define min 126 | (lambda (x y) 127 | (if (< x y) x y))) 128 | 129 | (define abs 130 | (lambda (x) 131 | (if (< x 0) (neg x) x))) 132 | 133 | (define remainder #%rem-non-neg) 134 | (define modulo #%rem-non-neg) 135 | 136 | (define #%box (lambda (a) (cons a '()))) 137 | 138 | (define #%unbox car) 139 | 140 | (define #%box-set! set-car!) 141 | 142 | (define string 143 | (lambda chars 144 | (list->string chars))) 145 | 146 | (define string-length 147 | (lambda (str) 148 | (length (string->list str)))) 149 | 150 | (define string-append 151 | (lambda (str1 str2) 152 | (list->string (append (string->list str1) (string->list str2))))) 153 | 154 | (define substring 155 | (lambda (str start end) 156 | (list->string 157 | (#%substring-aux2 158 | (#%substring-aux1 (string->list str) start) 159 | (#%- end start))))) 160 | 161 | (define #%substring-aux1 162 | (lambda (lst n) 163 | (if (>= n 1) 164 | (#%substring-aux1 (cdr lst) (#%- n 1)) 165 | lst))) 166 | 167 | (define #%substring-aux2 168 | (lambda (lst n) 169 | (if (>= n 1) 170 | (cons (car lst) (#%substring-aux2 (cdr lst) (#%- n 1))) 171 | '()))) 172 | 173 | (define map 174 | (lambda (f lst) 175 | (if (pair? lst) 176 | (cons (f (car lst)) 177 | (map f (cdr lst))) 178 | '()))) 179 | 180 | (define for-each 181 | (lambda (f lst) 182 | (if (pair? lst) 183 | (begin 184 | (f (car lst)) 185 | (for-each f (cdr lst))) 186 | #f))) 187 | 188 | (define call/cc 189 | (lambda (receiver) 190 | (let ((k (get-cont))) 191 | (receiver 192 | (lambda (r) 193 | (return-to-cont k r)))))) 194 | 195 | (define root-k #f) 196 | (define readyq #f) 197 | 198 | (define start-first-process 199 | (lambda (thunk) 200 | ;; rest of the program, after call to start-first-process 201 | (set! root-k (get-cont)) 202 | (set! readyq (cons #f #f)) 203 | ;; initialize thread queue, which is a circular list of continuations 204 | (set-cdr! readyq readyq) 205 | (thunk))) 206 | 207 | (define spawn 208 | (lambda (thunk) 209 | (let* ((k (get-cont)) 210 | (next (cons k (cdr readyq)))) 211 | ;; add a new link to the circular list 212 | (set-cdr! readyq next) 213 | ;; Run thunk with root-k as cont. 214 | (graft-to-cont root-k (lambda () (thunk) (exit)))))) 215 | 216 | (define exit 217 | (lambda () 218 | (let ((next (cdr readyq))) 219 | (if (eq? next readyq) ; queue is empty 220 | #f 221 | (begin 222 | ;; step once on the circular list 223 | (set-cdr! readyq (cdr next)) 224 | ;; invoke next thread 225 | (return-to-cont (car next) #f)))))) 226 | 227 | (define yield 228 | (lambda () 229 | (let ((k (get-cont))) 230 | ;; save the current continuation 231 | (set-car! readyq k) 232 | ;; step once on the circular list 233 | (set! readyq (cdr readyq)) 234 | ;; run the next thread 235 | (let ((next-k (car readyq))) 236 | (set-car! readyq #f) 237 | (return-to-cont next-k #f))))) 238 | 239 | (define number->string 240 | (lambda (n) 241 | (list->string 242 | (if (< n 0) 243 | (cons #\- (#%number->string-aux (neg n) '())) 244 | (#%number->string-aux n '()))))) 245 | 246 | (define #%number->string-aux 247 | (lambda (n lst) 248 | (let ((rest (cons (#%+ #\0 (remainder n 10)) lst))) 249 | (if (< n 10) 250 | rest 251 | (#%number->string-aux (quotient n 10) rest))))) 252 | 253 | (define caar 254 | (lambda (p) 255 | (car (car p)))) 256 | (define cadr 257 | (lambda (p) 258 | (car (cdr p)))) 259 | (define cdar 260 | (lambda (p) 261 | (cdr (car p)))) 262 | (define cddr 263 | (lambda (p) 264 | (cdr (cdr p)))) 265 | (define caaar 266 | (lambda (p) 267 | (car (car (car p))))) 268 | (define caadr 269 | (lambda (p) 270 | (car (car (cdr p))))) 271 | (define cadar 272 | (lambda (p) 273 | (car (cdr (car p))))) 274 | (define caddr 275 | (lambda (p) 276 | (car (cdr (cdr p))))) 277 | (define cdaar 278 | (lambda (p) 279 | (cdr (car (car p))))) 280 | (define cdadr 281 | (lambda (p) 282 | (cdr (car (cdr p))))) 283 | (define cddar 284 | (lambda (p) 285 | (cdr (cdr (car p))))) 286 | (define cdddr 287 | (lambda (p) 288 | (cdr (cdr (cdr p))))) 289 | 290 | (define equal? 291 | (lambda (x y) 292 | (cond ((eq? x y) 293 | #t) 294 | ((and (pair? x) (pair? y)) 295 | (and (equal? (car x) (car y)) 296 | (equal? (cdr x) (cdr y)))) 297 | ((and (u8vector? x) (u8vector? y)) 298 | (u8vector-equal? x y)) 299 | (else 300 | #f)))) 301 | 302 | (define u8vector-equal? 303 | (lambda (x y) 304 | (let ((lx (u8vector-length x))) 305 | (if (= lx (u8vector-length y)) 306 | (#%u8vector-equal?-loop x y (- lx 1)) 307 | #f)))) 308 | (define #%u8vector-equal?-loop 309 | (lambda (x y l) 310 | (if (= l 0) 311 | #t 312 | (and (= (u8vector-ref x l) (u8vector-ref y l)) 313 | (#%u8vector-equal?-loop x y (#%- l 1)))))) 314 | 315 | (define assoc 316 | (lambda (t l) 317 | (cond ((null? l) 318 | #f) 319 | ((equal? t (caar l)) 320 | (car l)) 321 | (else 322 | (assoc t (cdr l)))))) 323 | 324 | (define memq 325 | (lambda (t l) 326 | (cond ((null? l) 327 | #f) 328 | ((eq? (car l) t) 329 | l) 330 | (else 331 | (memq t (cdr l)))))) 332 | 333 | (define vector list) 334 | (define vector-ref list-ref) 335 | (define vector-set! list-set!) 336 | 337 | (define u8vector 338 | (lambda x 339 | (list->u8vector x))) 340 | (define list->u8vector 341 | (lambda (x) 342 | (let* ((n (length x)) 343 | (v (#%make-u8vector n))) 344 | (#%list->u8vector-loop v 0 x) 345 | v))) 346 | (define #%list->u8vector-loop 347 | (lambda (v n x) 348 | (u8vector-set! v n (car x)) 349 | (if (not (null? (cdr x))) 350 | (#%list->u8vector-loop v (#%+ n 1) (cdr x))))) 351 | (define make-u8vector 352 | (lambda (n x) 353 | (#%make-u8vector-loop (#%make-u8vector n) (- n 1) x))) 354 | (define #%make-u8vector-loop 355 | (lambda (v n x) 356 | (if (>= n 0) 357 | (begin (u8vector-set! v n x) 358 | (#%make-u8vector-loop v (- n 1) x)) 359 | v))) 360 | (define u8vector-copy! 361 | (lambda (source source-start target target-start n) 362 | (if (> n 0) 363 | (begin (u8vector-set! target target-start 364 | (u8vector-ref source source-start)) 365 | (u8vector-copy! source (+ source-start 1) 366 | target (+ target-start 1) 367 | (- n 1)))))) 368 | -------------------------------------------------------------------------------- /compiler/parser.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide parse-program parse) 4 | (require "utilities.rkt" "analysis.rkt" "env.rkt" "ast.rkt") 5 | 6 | (define (parse-program lst env) 7 | (define exprs (parse-top-list (append lst '((#%halt))) env)) 8 | (let ([r (make-seq #f exprs)]) 9 | (for ([x (in-list exprs)]) (set-node-parent! x r)) 10 | r)) 11 | 12 | (define (parse-top-list lst env) 13 | (if (pair? lst) 14 | (append (parse-top (car lst) env) 15 | (parse-top-list (cdr lst) env)) 16 | '())) 17 | 18 | (define (parse-top expr env) 19 | (match expr 20 | [(cons 'begin body) 21 | (parse-top-list body env)] 22 | [(list-rest 'define (list-rest var params) body) 23 | (parse-define var `(lambda ,params ,@body) env)] 24 | [(list 'define (? symbol? var) val) 25 | (parse-define 26 | var val env 27 | ;; If we're not defining a function, forward references are 28 | ;; invalid. 29 | (match val [`(lambda . ,rest) #t] [_ #f]))] 30 | [_ 31 | (list (parse 'value expr env))])) 32 | 33 | (define (parse-define var val env [forward-references? #t]) 34 | (let ([var2 (env-lookup env var)]) 35 | (parameterize ([allow-forward-references? forward-references?]) 36 | (let* ([val2 (parse 'value val env)] 37 | [r (make-def #f (list val2) var2)]) 38 | (set-node-parent! val2 r) 39 | (set-var-defs! var2 (cons r (var-defs var2))) 40 | (list r))))) 41 | 42 | (define (parse use expr env) 43 | (match expr 44 | [(? self-eval? expr) 45 | (make-cst #f '() expr)] 46 | [(? symbol? expr) 47 | (let* ([var (env-lookup env expr)] 48 | [r (make-ref #f '() var)]) 49 | (set-var-refs! var (cons r (var-refs var))) 50 | (if (not (var-global? var)) 51 | (let* ([unbox (parse 'value '#%unbox env)] 52 | [app (make-call #f (list unbox r))]) 53 | (set-node-parent! r app) 54 | (set-node-parent! unbox app) 55 | app) 56 | r))] 57 | [`(set! ,lhs ,rhs) 58 | (let ([var (env-lookup env lhs)] 59 | [val (parse 'value rhs env)]) 60 | (if (var-global? var) 61 | (let ([r (make-set #f (list val) var)]) 62 | (set-node-parent! val r) 63 | (set-var-sets! var (cons r (var-sets var))) 64 | r) 65 | (let* ([ref (make-ref #f '() var)] 66 | [bs (make-ref #f '() (env-lookup env '#%box-set!))] 67 | [r (make-call #f `(,bs ,ref ,val))]) 68 | (set-node-parent! val r) 69 | (set-node-parent! ref r) 70 | (set-node-parent! bs r) 71 | (set-var-sets! var (cons r (var-sets var))) 72 | r)))] 73 | [`(quote ,datum) 74 | (make-cst #f '() datum)] 75 | [`(if ,tst ,thn ,els ...) 76 | (let* ([a (parse 'test tst env)] 77 | [b (parse use thn env)] 78 | [c (if (null? (cdddr expr)) 79 | (make-cst #f '() #f) 80 | (parse use (cadddr expr) env))] 81 | [r (make-if* #f (list a b c))]) 82 | (set-node-parent! a r) 83 | (set-node-parent! b r) 84 | (set-node-parent! c r) 85 | r)] 86 | [`(cond . ,body) ; should eventually be a macro 87 | (match body 88 | ['() 89 | (parse use '(if #f #f) env)] 90 | [`((else . ,rhs)) 91 | (parse use `(begin ,@rhs) env)] 92 | [`((,tst => ,rhs) . ,other-clauses) 93 | (let ([x (gensym)]) 94 | (parse use 95 | `(let ([,x ,tst]) 96 | (if ,x 97 | (,rhs ,x) 98 | (cond ,@other-clauses))) 99 | env))] 100 | [`((,tst . ,rhs) . ,other-clauses) 101 | (parse use 102 | `(if ,tst 103 | (begin ,@rhs) 104 | (cond ,@other-clauses)) 105 | env)])] 106 | [`(lambda ,pattern . ,body) 107 | (let* ([ids (extract-ids pattern)] 108 | ;; parent children params rest? entry-label 109 | [r (make-prc #f '() #f (has-rest-param? pattern) #f)] 110 | [new-env (env-extend env ids r)] 111 | [body (parse-body body new-env)] 112 | [mut-vars (append-map (lambda (id) 113 | (let ([v (env-lookup new-env id)]) 114 | (if (mutable-var? v) (list v) '()))) 115 | ids)]) 116 | (cond [(null? mut-vars) 117 | (set-prc-params! r 118 | (map (lambda (id) (env-lookup new-env id)) 119 | ids)) 120 | (set-node-children! r (list body)) 121 | (set-node-parent! body r) 122 | r] 123 | [else 124 | (let* ([prc (make-prc #f (list body) mut-vars #f #f)] 125 | [new-vars (map var-id mut-vars)] 126 | [tmp-env (env-extend env new-vars r)] 127 | [app 128 | (make-call 129 | r 130 | (cons prc 131 | (map (lambda (id) 132 | (parse 'value 133 | (cons '#%box (cons id '())) 134 | tmp-env)) 135 | new-vars)))]) 136 | ;; (lambda (a b) (set! a b)) 137 | ;; => (lambda (_a b) ((lambda (a) (box-set! a b)) (box _a))) 138 | (for-each (lambda (var) (set-var-defs! var (list prc))) 139 | mut-vars) 140 | (for-each (lambda (n) (set-node-parent! n app)) 141 | (cdr (node-children app))) 142 | (set-node-parent! prc app) 143 | (set-prc-params! r 144 | (map (lambda (id) (env-lookup tmp-env id)) 145 | ids)) 146 | (set-node-children! r (list app)) 147 | (set-node-parent! body prc) 148 | r)]))] 149 | [`(letrec ((,ks ,vs) ...) . ,body) 150 | (parse use 151 | `(let ,(map (lambda (k) (list k #f)) ks) 152 | ,@(append (map (lambda (k v) `(set! ,k ,v)) 153 | ks vs) ; letrec* 154 | body)) 155 | env)] 156 | [`(begin . ,forms) 157 | (let* ([exprs (map (lambda (x) (parse 'value x env)) forms)] 158 | [r (make-seq #f exprs)]) 159 | (for-each (lambda (x) (set-node-parent! x r)) exprs) 160 | r)] 161 | [`(let ,(? symbol? id) ((,ks ,vs) ...) . ,body) ; named let 162 | (parse use 163 | `(letrec ([,id (lambda ,ks ,@body)]) 164 | (,id ,@vs)) 165 | env)] 166 | [`(let ((,ks ,vs) ...) . ,body) 167 | (parse use `((lambda ,ks ,@body) ,@vs) env)] 168 | [`(let* () . ,body) ; base case for let* 169 | (parse use `(let () ,@body) env)] 170 | [`(let* ((,k ,v) ,bindings ...) . ,body) 171 | (parse use 172 | `(let ([,k ,v]) 173 | (let* ,bindings 174 | ,@body)) 175 | env)] 176 | ['(and) ; base case for and 177 | (parse use #t env)] 178 | [`(and ,tst) 179 | (parse use tst env)] 180 | [`(and ,tst . ,rest) 181 | (parse use `(if ,tst (and ,@rest) #f) env)] 182 | ['(or) ; base case for or 183 | (parse use #f env)] 184 | [`(or ,tst) 185 | (parse use tst env)] 186 | [`(or ,tst . ,rest) 187 | (if (eq? use 'test) 188 | ;; we don't need to keep the actual result, we only care about 189 | ;; its "truthiness" 190 | (parse use `(if ,tst #t (or ,@rest)) env) 191 | (parse use 192 | (let ([v (gensym)]) 193 | `(let ([,v ,tst]) 194 | (if ,v ,v (or ,@rest)))) 195 | env))] 196 | [`(,op . ,args) (=> fail!) 197 | (if (memq (car expr) 198 | '(quote quasiquote unquote unquote-splicing lambda if set! cond 199 | and or case let let* letrec begin do define delay)) 200 | (compiler-error "the compiler does not implement the special form" 201 | (car expr)) 202 | (fail!))] 203 | [(? list? expr) ; call 204 | (let* ([exprs (map (lambda (x) (parse 'value x env)) expr)] 205 | [r (make-call #f exprs)]) 206 | (for-each (lambda (x) (set-node-parent! x r)) exprs) 207 | r)] 208 | [_ 209 | (compiler-error "unknown expression" expr)])) 210 | 211 | (define (parse-body exprs env) 212 | (parse 'value (cons 'begin exprs) env)) 213 | -------------------------------------------------------------------------------- /compiler/picobit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "utilities.rkt" 4 | "pretty-printer.rkt" 5 | "primitives.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 | (mark-needed-global-vars! node) 26 | (adjust-unmutable-references! node) 27 | (inline-eta! node) 28 | (constant-fold! node) 29 | (when (show-post-front-end?) 30 | (pretty-print (node->expr node))) 31 | (let* ([ctx (comp-none node (make-init-context))] 32 | [code (context-code ctx)] 33 | [bbs (code->vector code)]) 34 | (resolve-toplevel-labels! bbs) 35 | (let ([prog (schedule (tree-shake! bbs))]) 36 | (when (show-asm?) 37 | (pretty-print prog)) 38 | ;; output port is in a thunk to avoid creating result 39 | ;; files if compilation fails 40 | (let ([size (assemble prog (out-port-thunk))]) 41 | (when (show-size?) 42 | (printf "~a bytes\n" size))))))) 43 | 44 | (define output-file-gen 45 | (make-parameter 46 | (lambda (in) 47 | (let ([hex-filename (path-replace-suffix in ".hex")]) 48 | ;; r5rs's with-output-to-file (in asm.rkt) can't overwrite. bleh 49 | (when (file-exists? hex-filename) 50 | (delete-file hex-filename)) 51 | hex-filename)))) 52 | 53 | (command-line 54 | #:once-each 55 | [("--size") 56 | "Display the size of the generated bytecode." 57 | (show-size? #t)] 58 | [("--parse") 59 | "Display post-parsing representation of the program." 60 | (show-parsed? #t)] 61 | [("--front") 62 | "Display post-front-end representation of the program." 63 | (show-parsed? #t)] 64 | [("-S" "--asm") 65 | "Display generated bytecode pre-assembly." 66 | (show-asm? #t)] 67 | [("--stats") 68 | "Display statistics about generated instructions." 69 | (stats? #t)] 70 | [("-o") out 71 | "Place the output into the given file." 72 | (output-file-gen (lambda (in) out))] 73 | #:args (filename) 74 | (void 75 | (if (equal? filename "-") 76 | ;; read input from stdin, produce code on stdout 77 | (compile 78 | (current-input-port) 79 | (lambda () (current-output-port))) 80 | (compile 81 | (open-input-file filename) 82 | (lambda () (open-output-file ((output-file-gen) filename))))))) 83 | -------------------------------------------------------------------------------- /compiler/pretty-printer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "utilities.rkt" "ast.rkt" "env.rkt") 4 | 5 | (provide node->expr) 6 | 7 | (define (node->expr node) 8 | (match node 9 | [(cst _ '() val) 10 | (if (self-eval? val) 11 | val 12 | (list 'quote val))] 13 | [(ref _ '() var) 14 | (var-id var)] 15 | [(def _ `(,rhs) var) 16 | (list 'define (var-id var) (node->expr rhs))] 17 | [(set _ `(,rhs) var) 18 | (list 'set! (var-id var) (node->expr rhs))] 19 | [(if* _ `(,tst ,thn ,els)) 20 | (list 'if (node->expr tst) (node->expr thn) (node->expr els))] 21 | [(prc _ `(,body) params rest? entry-label) 22 | (define (build-pattern params rest?) 23 | (cond [(null? params) 24 | '()] 25 | [(null? (cdr params)) 26 | (if rest? 27 | (var-id (car params)) 28 | (list (var-id (car params))))] 29 | [else 30 | (cons (var-id (car params)) 31 | (build-pattern (cdr params) rest?))])) 32 | `(lambda ,(build-pattern params rest?) 33 | ,@(if (seq? body) 34 | (nodes->exprs (node-children body)) 35 | (list (node->expr body))))] 36 | [(call _ children) 37 | (map node->expr children)] 38 | [(seq _ children) 39 | (cond [(null? children) 40 | '(void)] 41 | [(null? (cdr children)) 42 | (node->expr (car children))] 43 | [else 44 | (cons 'begin (nodes->exprs children))])] 45 | [_ 46 | (compiler-error "unknown expression type" node)])) 47 | 48 | (define (nodes->exprs nodes) 49 | (if (null? nodes) 50 | '() 51 | (if (seq? (car nodes)) 52 | (append (nodes->exprs (node-children (car nodes))) 53 | (nodes->exprs (cdr nodes))) 54 | (cons (node->expr (car nodes)) 55 | (nodes->exprs (cdr nodes)))))) 56 | -------------------------------------------------------------------------------- /compiler/primitives.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/mpair unstable/sequence) 4 | (require srfi/4) 5 | (require "env.rkt" 6 | "parser.rkt" "front-end.rkt") ; to build the eta-expansions 7 | 8 | ;----------------------------------------------------------------------------- 9 | 10 | (provide global-env) 11 | (define global-env (mlist)) 12 | 13 | (provide primitive-encodings) 14 | (define primitive-encodings '()) 15 | 16 | 17 | (define-syntax define-primitive 18 | (syntax-rules () 19 | [(define-primitive name nargs encoding) 20 | (define-primitive name nargs encoding #:uns-res? #f)] 21 | [(define-primitive name nargs encoding #:unspecified-result) 22 | (define-primitive name nargs encoding #:uns-res? #t)] 23 | [(define-primitive name nargs encoding #:uns-res? uns?) 24 | (let ([prim (make-var 25 | 'name #t '() '() '() #f 26 | (make-primitive 27 | nargs #f 28 | ;; eta-expansion, for higher-order uses, created lazily, to 29 | ;; avoid parsing before all the primitives are defined 30 | (lambda () 31 | (define res #f) 32 | (or res 33 | (begin (set! res (create-eta-expansion 'name nargs)) 34 | res))) 35 | uns?))]) 36 | (set! global-env (mcons prim global-env)) 37 | (set! primitive-encodings 38 | (dict-set primitive-encodings 'name encoding)))])) 39 | 40 | (define (create-eta-expansion name nargs) 41 | (define params (build-list nargs (lambda (x) (gensym)))) 42 | (define node 43 | (parse #f `(lambda ,params (,name ,@params)) global-env)) 44 | (adjust-unmutable-references! node) 45 | node) 46 | 47 | (include "gen.primitives.rkt") 48 | 49 | 50 | ;; Since constant folding is a compiler-only concept, it doesn't make 51 | ;; much sense to add folders to primitives in the VM, where primitives 52 | ;; are defined. 53 | ;; Instead, we add the constant folders post-facto. This requires that 54 | ;; the foldable primitives actually be defined, though. Since folding 55 | ;; is used for "essential" primitives, that shouldn't be an issue. 56 | 57 | (define (add-constant-folder name folder) 58 | (define prim (var-primitive (env-lookup global-env name))) 59 | (set-primitive-constant-folder! prim folder)) 60 | 61 | (define folders 62 | `((number? . ,number?) 63 | (#%+ . ,+) 64 | (#%- . ,-) 65 | (#%mul-non-neg . ,*) 66 | (#%div-non-neg . ,quotient) 67 | (#%rem-non-neg . ,remainder) 68 | (= . ,=) 69 | (< . ,<) 70 | (> . ,>) 71 | (pair? . ,pair?) 72 | (car . ,car) 73 | (cdr . ,cdr) 74 | (null? . ,null?) 75 | (eq? . ,eq?) 76 | (not . ,not) 77 | (symbol? . ,symbol?) 78 | (string? . ,string?) 79 | (string->list . ,string->list) 80 | (list->string . ,list->string) 81 | (u8vector-ref . ,u8vector-ref) 82 | (u8vector? . ,u8vector?) 83 | (u8vector-length . ,u8vector-length) 84 | (boolean? . ,boolean?) 85 | (bitwise-ior . ,bitwise-ior) 86 | (bitwise-xor . ,bitwise-xor))) 87 | 88 | (for ([(name folder) (in-pairs folders)]) 89 | (add-constant-folder name folder)) 90 | -------------------------------------------------------------------------------- /compiler/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (only-in unstable/port read-all) 4 | racket/runtime-path 5 | srfi/4) 6 | 7 | (provide read-program) 8 | 9 | ;; at this point, the #u or #u8(...) has already been seen 10 | (define (read-u8vector port) 11 | (unless (and (equal? (read-char port) #\8) 12 | (equal? (read-char port) #\()) 13 | (error "bad byte vector syntax")) 14 | (let ([s (open-output-string)]) 15 | (let loop ([c (read-char port)]) 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))] 22 | [else 23 | ;; we saw the closing paren, we're done 24 | (let ([contents (regexp-split #px"[[:space:]]+" 25 | (get-output-string s))]) 26 | (list->u8vector 27 | (map string->number contents)))])))) 28 | 29 | ;; u8vector literals are not natively supported by Racket 30 | (define u8vector-readtable 31 | (make-readtable 32 | (current-readtable) 33 | #\u 34 | 'dispatch-macro 35 | (case-lambda 36 | [(char port) ; read 37 | (read-u8vector port)] 38 | [(char port src line col pos) ; read-syntax 39 | (read-u8vector port)]))) 40 | 41 | (define (expand-includes exprs) 42 | (map (lambda (e) 43 | (if (eq? (car e) 'include) 44 | (cons 'begin 45 | (expand-includes 46 | (with-input-from-file (cadr e) read-all))) 47 | e)) 48 | exprs)) 49 | 50 | (define-runtime-path compiler-dir ".") 51 | 52 | (define (read-program port) 53 | (parameterize ([current-readtable u8vector-readtable]) 54 | (define (read-lib f) 55 | (with-input-from-file (build-path compiler-dir f) 56 | read-all)) 57 | (define library 58 | (append (read-lib "library.scm") ; architecture-independent 59 | (read-lib "gen.library.scm"))) ; architecture-dependent 60 | (expand-includes (append library (read-all read port))))) 61 | -------------------------------------------------------------------------------- /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 8 | (lambda (msg . others) 9 | (display "*** PICOBIT ERROR -- ") 10 | (display msg) 11 | (for-each (lambda (x) (display " ") (write x)) others) 12 | (newline) 13 | (exit 1))) 14 | 15 | (define (self-eval? expr) 16 | (or (number? expr) 17 | (char? expr) 18 | (boolean? expr) 19 | (string? expr) 20 | (u8vector? expr))) 21 | 22 | 23 | ;; to control output level 24 | (define show-size? (make-parameter #f)) 25 | (define show-asm? (make-parameter #f)) 26 | (define show-parsed? (make-parameter #f)) 27 | (define show-post-front-end? (make-parameter #f)) 28 | (define stats? (make-parameter #f)) 29 | -------------------------------------------------------------------------------- /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 (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 | -------------------------------------------------------------------------------- /robot: -------------------------------------------------------------------------------- 1 | #! ./gsi 2 | 3 | (include "robot.scm") 4 | -------------------------------------------------------------------------------- /robot.bat: -------------------------------------------------------------------------------- 1 | @;gsi.exe %~f0 %* 2 | 3 | (include "robot.scm") 4 | -------------------------------------------------------------------------------- /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 (test-case "no expected file" 25 | (check-true (file-exists? expected))) 26 | (when (file-exists? expected) 27 | (f file-str hex expected input)) 28 | (when (file-exists? hex) 29 | (delete-file hex))))))) 30 | 31 | (define (run-succeed file) 32 | (run-one 33 | file 34 | (lambda (file-str hex expected input) 35 | (system* "./picobit" file-str) 36 | (test-case "compilation" (check-true (file-exists? hex))) 37 | (when (file-exists? hex) 38 | (let ([out (with-output-to-string 39 | (lambda () 40 | (parameterize 41 | ([current-input-port 42 | (if (file-exists? input) 43 | (open-input-file input) 44 | (open-input-string ""))]) 45 | (system* "./picobit-vm" hex))))]) 46 | (test-case "execution" 47 | (check-equal? out (file->string expected)))))))) 48 | 49 | (define (run-fail-compile file) 50 | (run-one 51 | file 52 | (lambda (file-str hex expected input) 53 | (let ([out (with-output-to-string 54 | (lambda () 55 | (system* "./picobit" file-str)))]) 56 | (test-case "compilation error" 57 | (check-false (file-exists? hex)) 58 | (check-equal? out (file->string expected))))))) 59 | 60 | (define (run-fail-execute file) (run-succeed file)) 61 | 62 | (define (run-single file) 63 | (let*-values ([(path p b) (split-path file)] 64 | [(dir) (path->string path)]) 65 | (cond [(equal? dir "tests/succeed/") 66 | (run-succeed file)] 67 | [(equal? dir "tests/fail/compile/") 68 | (run-fail-compile file)] 69 | [(equal? dir "tests/fail/execute/") 70 | (run-fail-execute file)]))) 71 | 72 | (define args (current-command-line-arguments)) 73 | 74 | (void 75 | (run-tests 76 | (cond [(>= (vector-length args) 1) ; run one 77 | (run-single (string->path (vector-ref args 0)))] 78 | [else ; run all 79 | (make-test-suite 80 | "PICOBIT tests" 81 | (filter (lambda (x) (not (void? x))) 82 | (append 83 | (for/list ([file (in-directory "./tests/succeed/")]) 84 | (run-succeed file)) 85 | (for/list ([file (in-directory "./tests/fail/compile/")]) 86 | (run-fail-compile file)) 87 | (for/list ([file (in-directory "./tests/fail/execute/")]) 88 | (run-fail-execute file)))))]))) 89 | -------------------------------------------------------------------------------- /tests/fail/compile/define-ordering.expected: -------------------------------------------------------------------------------- 1 | *** PICOBIT ERROR -- variable referenced before its definition: bar 2 | -------------------------------------------------------------------------------- /tests/fail/compile/define-ordering.scm: -------------------------------------------------------------------------------- 1 | (define foo bar) 2 | 3 | (define (bar) 3) 4 | -------------------------------------------------------------------------------- /tests/fail/compile/unbound.expected: -------------------------------------------------------------------------------- 1 | *** PICOBIT ERROR -- undefined variable: toto 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/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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/empty.expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/whitequark/picobit/6adea42ccf0a8d3f5e2f4167fc201dc7a1b5576c/tests/succeed/empty.expected -------------------------------------------------------------------------------- /tests/succeed/empty.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/whitequark/picobit/6adea42ccf0a8d3f5e2f4167fc201dc7a1b5576c/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/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/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/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/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 | # Mon Sep 12 11:28:14 2011 5 | # 6 | # CONFIG_ARCH_HOST is not set 7 | CONFIG_ARCH_ARM=y 8 | CONFIG_ARCH_32BIT=y 9 | CONFIG_ARCH="arm" 10 | CONFIG_CROSS_COMPILER="arm-none-eabi-" 11 | CONFIG_ARM_CORTEX_M3=y 12 | CONFIG_ARM_COMPILER_GCC=y 13 | # CONFIG_ARM_COMPILER_KEIL is not set 14 | CONFIG_ARM_CPU_STM32F100RB=y 15 | CONFIG_ARM_BOARD_STM32_VLDISCOVERY=y 16 | # CONFIG_BIGNUM_FIXED is not set 17 | CONFIG_BIGNUM_LONG=y 18 | # CONFIG_VM_DEBUG is not set 19 | # CONFIG_GC_STATISTICS is not set 20 | # CONFIG_GC_DEBUG is not set 21 | -------------------------------------------------------------------------------- /vm/.gitignore: -------------------------------------------------------------------------------- 1 | .config.old 2 | include/arch 3 | picobit-vm 4 | picobit.hex 5 | picobit.elf 6 | .primitives.p 7 | *.o 8 | -------------------------------------------------------------------------------- /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 | CPPFLAGS = -Iinclude/ -DPICOBIT 84 | LDFLAGS = -nostdlib -L$(arch)/lib 85 | CFLAGS = $(CPPFLAGS) 86 | 87 | arch = arch/$(call unquote,$(CONFIG_ARCH)) 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 | ifeq ($(no-gcc),) 99 | CFLAGS += -Wall -Werror -Os $(LDFLAGS) 100 | LDFLAGS += -Wl,-warn-common -fno-hosted 101 | endif 102 | 103 | prim-gen = gawk -f scripts/scanner.awk -f scripts/prim-$(1).awk \ 104 | .primitives.p >$(2) 105 | 106 | .primitives.p: include/arch $(obj-y) .config 107 | rm -f $@ 108 | for object in $(obj-y); do \ 109 | $(CROSS)cpp -DNO_PRIMITIVE_EXPAND $(CPPFLAGS) \ 110 | $$object -o - >>$@; \ 111 | done 112 | $(call prim-gen,headergen,include/gen.primitives.h) 113 | $(call prim-gen,schemegen,../compiler/gen.primitives.rkt) 114 | $(call prim-gen,dispatchgen,core/gen.dispatch.c) 115 | 116 | fetch-macro = $$(($$(echo "$(2)" | $(CROSS)cpp $(CPPFLAGS) \ 117 | --include include/$(1) | tail -n1))) 118 | 119 | provide-macro = @echo "(define $(1) $(call fetch-macro,$(2),$(3)))" >>$@; \ 120 | echo "(provide $(1))" >>$@ 121 | 122 | .PHONY: ../compiler/gen.config.rkt 123 | ../compiler/gen.config.rkt: 124 | echo "#lang racket" >$@ 125 | echo "" >>$@ 126 | echo "(define code-start $(load-address))" >>$@ 127 | echo "(provide code-start)" >>$@ 128 | $(call provide-macro,max-fixnum,heap.h,MAX_FIXNUM) 129 | $(call provide-macro,min-rom-encoding,heap.h,MIN_ROM_ENCODING) 130 | $(call provide-macro,max-rom-encoding,heap.h,MAX_ROM_ENCODING) 131 | $(call provide-macro,min-ram-encoding,heap.h,MIN_RAM_ENCODING) 132 | 133 | ../compiler/gen.library.scm: .config $(arch)/Makefile 134 | echo >$@ 135 | for scm in $(scm-y); do \ 136 | echo "(include \"vm/$${scm}\")" >>$@; \ 137 | done 138 | 139 | all: include/arch .primitives.p ../compiler/gen.config.rkt \ 140 | ../compiler/gen.library.scm arch-all 141 | if [ -e picobit.elf ]; then \ 142 | CROSS="$(CROSS)" CPPFLAGS="$(CPPFLAGS)" scripts/check-encoding.sh; \ 143 | fi 144 | 145 | endif # $(dot-config) 146 | 147 | endif # $(config-targets) 148 | endif # $(mixed-targets) 149 | 150 | clean: FORCE 151 | rm -f include/arch picobit-vm picobit.elf picobit.hex \ 152 | .primitives.p ../compiler/gen.* include/gen.* \ 153 | core/gen.* *.o 154 | 155 | mrproper: clean FORCE 156 | make -C kconfig clean 157 | rm -f .config .config.old 158 | rm -rf include/config include/generated 159 | 160 | help: 161 | @echo "Picobit Virtual Machine" 162 | @echo " Picobit uses Kconfig for configuring its VM build" 163 | @echo " process. Configuration options are mostly same." 164 | @echo 165 | @echo "Configuration:" 166 | @echo " config: command-line configurator" 167 | @echo " nconfig: ncurses-based configurator" 168 | @echo " oldconfig: update configuration using current .config as base" 169 | @echo " silentoldconfig: same as oldconfig, but do not ask about new options" 170 | @echo 171 | @echo "Building:" 172 | @echo " all: build everything" 173 | @echo 174 | @echo "Cleaning:" 175 | @echo " clean: remove intermediate files" 176 | @echo " mrproper: remove intermediate files and configuration" 177 | 178 | .PHONY: FORCE 179 | -------------------------------------------------------------------------------- /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 "Compiler" 3 | 4 | config ARM_COMPILER_GCC 5 | bool "GCC" 6 | 7 | config ARM_COMPILER_KEIL 8 | bool "Keil (cc only)" 9 | endchoice 10 | 11 | if ARM_COMPILER_KEIL 12 | config ARM_KEIL_PATH 13 | string "Path to Keil in Wine" 14 | default "c:\\Keil\\ARM\\BIN40" 15 | endif 16 | 17 | choice 18 | prompt "Processor model" 19 | 20 | config ARM_CPU_STM32F100RB 21 | bool "ST STM32F100RB" 22 | endchoice 23 | 24 | choice 25 | prompt "Board name" 26 | 27 | config ARM_BOARD_STM32_VLDISCOVERY 28 | bool "STM32 VLDISCOVERY" 29 | endchoice 30 | -------------------------------------------------------------------------------- /vm/arch/arm/cortex-m3/Makefile: -------------------------------------------------------------------------------- 1 | ifdef CONFIG_ARM_CPU_STM32F100RB 2 | ldscript := stm32f100rb.ld 3 | ram_bytes := 0x2000 4 | rom_bytes := 0x20000 5 | endif 6 | 7 | CPPFLAGS += -DARCH_CPU_RAM_BYTES=$(ram_bytes) \ 8 | -DARCH_CPU_ROM_BYTES=$(rom_bytes) 9 | 10 | LDFLAGS += -T$(ldscript) 11 | 12 | arch-y += init.s 13 | 14 | arch-$(CONFIG_ARM_BOARD_STM32_VLDISCOVERY) += board-vldiscovery.c 15 | stdlib-$(CONFIG_ARM_BOARD_STM32_VLDISCOVERY) += stdlib-vldiscovery.scm 16 | 17 | load-address := \#x8008000 18 | 19 | arch-all: picobit.hex 20 | 21 | ifdef CONFIG_ARM_COMPILER_GCC 22 | CFLAGS += -mcpu=cortex-m3 -mthumb -g \ 23 | 24 | picobit.elf: $(obj-y) .config 25 | $(CROSS)gcc $(CFLAGS) -o $@ $(obj-y) 26 | endif 27 | 28 | ifdef CONFIG_ARM_COMPILER_KEIL 29 | no-gcc := 1 30 | 31 | CFLAGS += --cpu=Cortex-M3 --thumb -Ospace 32 | 33 | keil-y = $(filter %.c,$(obj-y)) 34 | 35 | picobit.o: $(keil-y) .config 36 | wine $(CONFIG_ARM_KEIL_PATH)\\armcc.exe $(CFLAGS) -c $(keil-y) 37 | wine $(CONFIG_ARM_KEIL_PATH)\\armlink.exe --output $@ \ 38 | --partial $(notdir $(patsubst %.c,%.o,$(keil-y))) 39 | 40 | init.o: $(arch)/init.s 41 | $(CROSS)gcc $(CFLAGS) -c -o $@ $^ 42 | 43 | picobit.elf: picobit.o init.o 44 | $(CROSS)ld $(LDFLAGS) -o $@ init.o picobit.o 45 | endif 46 | 47 | picobit.hex: picobit.elf 48 | $(CROSS)objcopy -O ihex $^ $@ 49 | -------------------------------------------------------------------------------- /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 | #if defined(CONFIG_ARM_COMPILER_GCC) 24 | __asm__ __volatile__("nop"); 25 | #endif 26 | 27 | #if defined(CONFIG_ARM_COMPILER_KEIL) 28 | __nop(); 29 | #endif 30 | } 31 | } 32 | 33 | arg1 = OBJ_FALSE; 34 | } 35 | 36 | PRIMITIVE_UNSPEC(#%set-led!, arch_set_led, 1) 37 | { 38 | if (arg1 == OBJ_FALSE) { 39 | GPIOC->ODR &= ~BIT(9); 40 | } else { 41 | GPIOC->ODR |= BIT(9); 42 | } 43 | 44 | arg1 = OBJ_FALSE; 45 | } 46 | 47 | void main () 48 | { 49 | RCC->APB2ENR |= IOPCEN; 50 | GPIOC->CRH = 0x44444411; 51 | 52 | interpreter(); 53 | } 54 | -------------------------------------------------------------------------------- /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 | #include 5 | 6 | /* 7 | * Addresses 0-0x8000 are reserved for code. 8 | */ 9 | #define CODE_START 0x8000 10 | 11 | #define ARCH_ROM_BYTES (ARCH_CPU_ROM_BYTES - CODE_START) 12 | 13 | /* 14 | * Extra RAM bytes taken by static variables in certain configurations. 15 | */ 16 | #ifdef CONFIG_ARM_CPU_STM32F100RB 17 | #define ARCH_RAM_EXTRA_BYTES 8 18 | #else 19 | #define ARCH_RAM_EXTRA_BYTES 0 20 | #endif /* CONFIG_ARM_CPU_STM32F100RB */ 21 | 22 | /* 23 | * 0x100 is the size of stack. 24 | * 44 is the size of interpreter variables. 25 | * Adjust ARCH_RAM_EXTRA_BYTES according to your needs. 26 | */ 27 | #define ARCH_RAM_BYTES (ARCH_CPU_RAM_BYTES - 0x100 - 44 - ARCH_RAM_EXTRA_BYTES) 28 | 29 | extern uint8 __picobit_heap; 30 | 31 | #define ram_get(a) ((uint8*)&__picobit_heap)[a] 32 | #define ram_set(a,x) ((uint8*)&__picobit_heap)[a] = (x) 33 | 34 | #define rom_get(a) (((uint8*) 0)[a]) 35 | 36 | #endif 37 | -------------------------------------------------------------------------------- /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 | #ifdef CONFIG_ARM_COMPILER_KEIL 5 | #pragma diag_suppress 1,1295,951,223 6 | #endif 7 | 8 | #ifdef CONFIG_ARM_COMPILER_GCC 9 | #pragma GCC diagnostic ignored "-Wimplicit-function-declaration" 10 | #endif 11 | 12 | /* Define Picobit basic types */ 13 | 14 | typedef unsigned char uint8; 15 | typedef unsigned short uint16; 16 | typedef unsigned int uint32; 17 | 18 | #endif 19 | -------------------------------------------------------------------------------- /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 | *(.data) 32 | *(COMMON) 33 | 34 | . = ALIGN(4); 35 | 36 | __bss_end__ = .; 37 | 38 | __picobit_heap = .; 39 | } > ram 40 | 41 | /DISCARD/ : { 42 | *(.comment) 43 | *(.ARM.attributes) 44 | } 45 | } 46 | -------------------------------------------------------------------------------- /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 | 5 | (define sleep 6 | (lambda (value) 7 | (#%sleep value))) -------------------------------------------------------------------------------- /vm/arch/host/Kconfig: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/whitequark/picobit/6adea42ccf0a8d3f5e2f4167fc201dc7a1b5576c/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 | printf ("ERROR: %s: %s\n", prim, msg); 13 | exit (1); 14 | } 15 | 16 | void type_error (char *prim, char *type) 17 | { 18 | printf ("ERROR: %s: An argument of type %s was expected\n", prim, type); 19 | exit (1); 20 | } 21 | 22 | void write_hex_nibble (int n) 23 | { 24 | putchar ("0123456789ABCDEF"[n]); 25 | } 26 | 27 | void write_hex (uint8 n) 28 | { 29 | write_hex_nibble (n >> 4); 30 | write_hex_nibble (n & 0x0f); 31 | } 32 | 33 | int hex (int c) 34 | { 35 | if (c >= '0' && c <= '9') { 36 | return (c - '0'); 37 | } 38 | 39 | if (c >= 'A' && c <= 'F') { 40 | return (c - 'A' + 10); 41 | } 42 | 43 | if (c >= 'a' && c <= 'f') { 44 | return (c - 'a' + 10); 45 | } 46 | 47 | return -1; 48 | } 49 | 50 | int read_hex_byte (FILE *f) 51 | { 52 | int h1 = hex (fgetc (f)); 53 | int h2 = hex (fgetc (f)); 54 | 55 | if (h1 >= 0 && h2 >= 0) { 56 | return (h1<<4) + h2; 57 | } 58 | 59 | return -1; 60 | } 61 | 62 | int read_hex_file (char *filename) 63 | { 64 | int c; 65 | FILE *f = fopen (filename, "r"); 66 | int result = 0; 67 | int len; 68 | int a, a1, a2; 69 | int t; 70 | int b; 71 | int i; 72 | uint8 sum; 73 | int hi16 = 0; 74 | 75 | for (i=0; i= 0 && adr < ROM_BYTES) { 109 | rom_mem[adr] = b; 110 | } 111 | 112 | a = (a + 1) & 0xffff; 113 | i++; 114 | sum += b; 115 | 116 | goto next0; 117 | } 118 | } else if (t == 1) { 119 | if (len != 0) { 120 | break; 121 | } 122 | } else if (t == 4) { 123 | if (len != 2) { 124 | break; 125 | } 126 | 127 | if ((a1 = read_hex_byte (f)) < 0 || 128 | (a2 = read_hex_byte (f)) < 0) { 129 | break; 130 | } 131 | 132 | sum += a1 + a2; 133 | 134 | hi16 = (a1<<8) + a2; 135 | } else { 136 | break; 137 | } 138 | 139 | if ((b = read_hex_byte (f)) < 0) { 140 | break; 141 | } 142 | 143 | sum = -sum; 144 | 145 | if (sum != b) { 146 | printf ("*** HEX file checksum error (expected 0x%02x)\n", sum); 147 | break; 148 | } 149 | 150 | c = fgetc (f); 151 | 152 | if ((c != '\r') && (c != '\n')) { 153 | break; 154 | } 155 | 156 | if (t == 1) { 157 | result = 1; 158 | break; 159 | } 160 | } 161 | 162 | if (result == 0) { 163 | printf ("*** HEX file syntax error\n"); 164 | } 165 | 166 | fclose (f); 167 | } 168 | 169 | return result; 170 | } 171 | 172 | void usage () 173 | { 174 | printf ("usage: sim file.hex\n"); 175 | exit (1); 176 | } 177 | 178 | int main (int argc, char *argv[]) 179 | { 180 | int errcode = 0; 181 | 182 | if (argc != 2) { 183 | usage (); 184 | } 185 | 186 | if (!read_hex_file (argv[1])) { 187 | printf ("*** Could not read hex file \"%s\"\n", argv[1]); 188 | } else { 189 | if (rom_get (CODE_START+0) != 0xfb || 190 | rom_get (CODE_START+1) != 0xd7) { 191 | printf ("*** The hex file was not compiled with PICOBIT\n"); 192 | } else { 193 | interpreter (); 194 | 195 | #ifdef CONFIG_GC_STATISTICS 196 | printf ("**************** memory needed = %d\n", max_live + 1); 197 | #endif 198 | } 199 | } 200 | 201 | return errcode; 202 | } 203 | -------------------------------------------------------------------------------- /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 | #define ARCH_RAM_BYTES 0x2000 7 | #define ARCH_ROM_BYTES 0x8000 8 | 9 | extern uint8 ram_mem[]; 10 | #define ram_get(a) ram_mem[a] 11 | #define ram_set(a,x) ram_mem[a] = (x) 12 | 13 | extern uint8 rom_mem[]; 14 | #define rom_get(a) (rom_mem[a-CODE_START]) 15 | 16 | #endif 17 | -------------------------------------------------------------------------------- /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_STATISTICS 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 MIN_FIXNUM_ENCODING 3 31 | #define MIN_FIXNUM -1 32 | #define MAX_FIXNUM 256 33 | 34 | #define ZERO ENCODE_FIXNUM(0) 35 | #define NEG1 (ZERO-1) 36 | #define POS1 (ZERO+1) 37 | 38 | #define MIN_RAM_ENCODING (MAX_RAM_ENCODING - (ARCH_RAM_BYTES / 4) + 1) 39 | #define MAX_RAM_ENCODING 8191 40 | #define RAM_BYTES ((MAX_RAM_ENCODING - MIN_RAM_ENCODING + 1)*4) 41 | 42 | #define MIN_ROM_ENCODING (MIN_FIXNUM_ENCODING + MAX_FIXNUM - MIN_FIXNUM + 1) 43 | 44 | #if (MIN_ROM_ENCODING - MIN_RAM_ENCODING + 1) > (ARCH_ROM_BYTES / 4) 45 | #define MAX_ROM_ENCODING (MIN_ROM_ENCODING + (ARCH_ROM_BYTES / 4) + 1) 46 | #else 47 | #define MAX_ROM_ENCODING (MIN_RAM_ENCODING - 1) 48 | #endif 49 | 50 | #define ROM_BYTES ((MAX_ROM_ENCODING - MIN_ROM_ENCODING + 1) * 4) 51 | 52 | #define MIN_VEC_ENCODING MIN_RAM_ENCODING 53 | #define MAX_VEC_ENCODING MAX_ROM_ENCODING 54 | #define VEC_BYTES ((MAX_VEC_ENCODING - MIN_VEC_ENCODING + 1) * 4) 55 | 56 | #ifdef LESS_MACROS 57 | uint16 OBJ_TO_RAM_ADDR(uint16 o, uint8 f) 58 | { 59 | return ((((o) - MIN_RAM_ENCODING) << 2) + (f)); 60 | } 61 | uint16 OBJ_TO_ROM_ADDR(uint16 o, uint8 f) 62 | { 63 | return ((((o) - MIN_ROM_ENCODING) << 2) + (CODE_START + 4 + (f))); 64 | } 65 | uint16 VEC_TO_RAM_OBJ(uint16 o) 66 | { 67 | return o + MAX_RAM_ENCODING; 68 | } 69 | uint16 RAM_TO_VEC_OBJ(uint16 o) 70 | { 71 | return o - MAX_RAM_ENCODING; 72 | } 73 | #else 74 | #define OBJ_TO_RAM_ADDR(o,f) ((((o) - MIN_RAM_ENCODING) << 2) + (f)) 75 | #define OBJ_TO_ROM_ADDR(o,f) ((((o) - MIN_ROM_ENCODING) << 2) + (CODE_START + 4 + (f))) 76 | #define VEC_TO_RAM_OBJ(o) ((o) + MAX_RAM_ENCODING + 1) 77 | #define RAM_TO_VEC_OBJ(o) ((o) - MAX_RAM_ENCODING - 1) 78 | #endif 79 | 80 | #ifdef LESS_MACROS 81 | uint8 ram_get_field0(uint16 o) 82 | { 83 | return ram_get (OBJ_TO_RAM_ADDR(o,0)); 84 | } 85 | void ram_set_field0(uint16 o, uint8 val) 86 | { 87 | ram_set (OBJ_TO_RAM_ADDR(o,0), val); 88 | } 89 | uint8 rom_get_field0(uint16 o) 90 | { 91 | return rom_get (OBJ_TO_ROM_ADDR(o,0)); 92 | } 93 | #else 94 | #define ram_get_field0(o) ram_get (OBJ_TO_RAM_ADDR(o,0)) 95 | #define ram_set_field0(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val) 96 | #define rom_get_field0(o) rom_get (OBJ_TO_ROM_ADDR(o,0)) 97 | #endif 98 | 99 | #ifdef LESS_MACROS 100 | uint8 ram_get_gc_tags(uint16 o) 101 | { 102 | return (ram_get_field0(o) & 0x60); 103 | } 104 | uint8 ram_get_gc_tag0(uint16 o) 105 | { 106 | return (ram_get_field0(o) & 0x20); 107 | } 108 | uint8 ram_get_gc_tag1(uint16 o) 109 | { 110 | return (ram_get_field0(o) & 0x40); 111 | } 112 | void ram_set_gc_tags(uint16 o, uint8 tags) 113 | { 114 | ram_set_field0(o,(ram_get_field0(o) & 0x9f) | (tags)); 115 | } 116 | void ram_set_gc_tag0(uint16 o, uint8 tag) 117 | { 118 | ram_set_field0(o,(ram_get_field0(o) & 0xdf) | (tag)); 119 | } 120 | void ram_set_gc_tag1(uint16 o, uint8 tag) 121 | { 122 | ram_set_field0(o,(ram_get_field0(o) & 0xbf) | (tag)); 123 | } 124 | #else 125 | #define ram_get_gc_tags(o) (ram_get_field0(o) & 0x60) 126 | #define ram_get_gc_tag0(o) (ram_get_field0(o) & 0x20) 127 | #define ram_get_gc_tag1(o) (ram_get_field0(o) & 0x40) 128 | #define ram_set_gc_tags(o,tags) \ 129 | (ram_set_field0(o,(ram_get_field0(o) & 0x9f) | (tags))) 130 | #define ram_set_gc_tag0(o,tag) \ 131 | ram_set_field0(o,(ram_get_field0(o) & 0xdf) | (tag)) 132 | #define ram_set_gc_tag1(o,tag) \ 133 | ram_set_field0(o,(ram_get_field0(o) & 0xbf) | (tag)) 134 | #endif 135 | 136 | #ifdef LESS_MACROS 137 | uint8 ram_get_field1(uint16 o) 138 | { 139 | return ram_get (OBJ_TO_RAM_ADDR(o,1)); 140 | } 141 | uint8 ram_get_field2(uint16 o) 142 | { 143 | return ram_get (OBJ_TO_RAM_ADDR(o,2)); 144 | } 145 | uint8 ram_get_field3(uint16 o) 146 | { 147 | return ram_get (OBJ_TO_RAM_ADDR(o,3)); 148 | } 149 | void ram_set_field1(uint16 o, uint8 val) 150 | { 151 | ram_set (OBJ_TO_RAM_ADDR(o,1), val); 152 | } 153 | void ram_set_field2(uint16 o, uint8 val) 154 | { 155 | ram_set (OBJ_TO_RAM_ADDR(o,2), val); 156 | } 157 | void ram_set_field3(uint16 o, uint8 val) 158 | { 159 | ram_set (OBJ_TO_RAM_ADDR(o,3), val); 160 | } 161 | uint8 rom_get_field1(uint16 o) 162 | { 163 | return rom_get (OBJ_TO_ROM_ADDR(o,1)); 164 | } 165 | uint8 rom_get_field2(uint16 o) 166 | { 167 | return rom_get (OBJ_TO_ROM_ADDR(o,2)); 168 | } 169 | uint8 rom_get_field3(uint16 o) 170 | { 171 | return rom_get (OBJ_TO_ROM_ADDR(o,3)); 172 | } 173 | #else 174 | #define ram_get_field1(o) ram_get (OBJ_TO_RAM_ADDR(o,1)) 175 | #define ram_get_field2(o) ram_get (OBJ_TO_RAM_ADDR(o,2)) 176 | #define ram_get_field3(o) ram_get (OBJ_TO_RAM_ADDR(o,3)) 177 | #define ram_set_field1(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val) 178 | #define ram_set_field2(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val) 179 | #define ram_set_field3(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val) 180 | #define rom_get_field1(o) rom_get (OBJ_TO_ROM_ADDR(o,1)) 181 | #define rom_get_field2(o) rom_get (OBJ_TO_ROM_ADDR(o,2)) 182 | #define rom_get_field3(o) rom_get (OBJ_TO_ROM_ADDR(o,3)) 183 | #endif 184 | 185 | obj cons (obj car, obj cdr); 186 | 187 | obj ram_get_car (obj o); 188 | obj rom_get_car (obj o); 189 | obj ram_get_cdr (obj o); 190 | obj rom_get_cdr (obj o); 191 | void ram_set_car (obj o, obj val); 192 | void ram_set_cdr (obj o, obj val); 193 | 194 | obj ram_get_entry (obj o); 195 | 196 | obj get_global (uint8 i); 197 | void set_global (uint8 i, obj o); 198 | 199 | #endif 200 | -------------------------------------------------------------------------------- /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/check-encoding.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | function get_symbol() { 4 | echo "0x"$(($(${CROSS}objdump picobit.elf -t | grep "$1" | cut -f1 -d' '))) 5 | } 6 | 7 | function get_macro() { 8 | echo $(($(echo "$2" | ${CROSS}cpp ${CPPFLAGS} --include "$1" | tail -n1))) 9 | } 10 | 11 | REAL_HEAP_SIZE=$(($(get_macro heap.h ARCH_CPU_RAM_BYTES) - \ 12 | ($(get_symbol __picobit_heap) - $(get_symbol __stack_begin__)))) 13 | 14 | DEFINED_HEAP_SIZE=$(get_macro heap.h ARCH_RAM_BYTES) 15 | 16 | if [ "$REAL_HEAP_SIZE" != "$DEFINED_HEAP_SIZE" ]; then 17 | echo 18 | echo " HEAP SIZE MISMATCH!" 19 | echo " Number of heap bytes based on linker data: ${REAL_HEAP_SIZE}" 20 | echo " Number of heap bytes based on headers: ${DEFINED_HEAP_SIZE}" 21 | echo " To see variables consuming the .bss, try:" 22 | echo " ${CROSS}objdump -t picobit.elf" 23 | echo 24 | exit 1 25 | fi 26 | -------------------------------------------------------------------------------- /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 | --------------------------------------------------------------------------------