Paste: icfp 2009 vm
Author: | erg |
Mode: | factor |
Date: | Sat, 27 Jun 2009 02:02:16 |
Plain Text |
USING: accessors arrays assocs combinators grouping io.binary
io.encodings.binary io.files kernel literals math math.bitwise
math.functions sequences fry ;
IN: icfp2009
TUPLE: vm
status
instruction-counter
instructions
data
inputs
outputs ;
CONSTANT: 2^14 $[ 14 2^ ]
: <vm>
vm new
swap 2^14 0 pad-tail >>instructions
swap 2^14 0.0 pad-tail >>data
0 >>instruction-counter
2^14 0 <array> >>inputs
2^14 0 <array> >>outputs ;
: D-opp -28 shift ; inline
: D-r1 -14 shift 14 bits ; inline
: D-r2 14 bits ; inline
: D-regs [ D-r1 ] [ D-r2 ] bi ; inline
: D-mems
[ D-regs ] dip data>> '[ _ nth ] bi@ ;
: S-opp -24 shift ; inline
: S-imm -20 shift 3 bits ; inline
: S-r1 14 bits ; inline
: S-mem
[ S-r1 ] [ data>> nth ] bi* ;
: set-rd
[ instruction-counter>> ] [ data>> ] bi set-nth ;
: /op
dup zero? [ 2drop 0.0 ] [ /f ] if ;
: op-5
[ D-regs swap ] dip
[ data>> nth ] [ outputs>> set-nth ] bi-curry
[ call ] [ call ] bi* ;
: op-6
dup status>> [
[ [ D-r1 ] [ data>> nth ] bi* ]
[ instruction-counter>> ]
[ data>> ] tri set-nth
] [
[ [ D-r2 ] [ data>> nth ] bi* ]
[ instruction-counter>> ]
[ data>> ] tri set-nth
] if ;
: run-D-opp
over D-opp {
{ 1 [ [ D-mems + ] [ instruction-counter>> ] [ data>> ] tri set-nth ] }
{ 2 [ [ D-mems - ] [ instruction-counter>> ] [ data>> ] tri set-nth ] }
{ 3 [ [ D-mems * ] [ instruction-counter>> ] [ data>> ] tri set-nth ] }
{ 4 [ [ D-mems /op ] [ instruction-counter>> ] [ data>> ] tri set-nth ] }
{ 5 [ op-5 ] }
{ 6 [ op-6 ] }
[ "unknown D opp" 2array throw ]
} case ;
: S-op1
[
[ S-mem ] [ drop S-imm ] 2bi {
{ 0 [ 0.0 < ] }
{ 1 [ 0.0 <= ] }
{ 2 [ zero? ] }
{ 3 [ 0.0 >= ] }
{ 4 [ 0.0 > ] }
[ "bad opcode for S-op1" throw ]
} case
] keep (>>status) ;
: S-op2
[ S-mem sqrt abs ] keep set-rd ;
: S-op3
[ S-mem ] keep set-rd ;
: S-op4
[ [ S-r1 ] [ inputs>> ] bi* nth ] keep set-rd ;
: run-S-opp
over S-opp {
{ 0 [ 2drop ] }
{ 1 [ S-op1 ] }
{ 2 [ S-op2 ] }
{ 3 [ S-op3 ] }
{ 4 [ S-op4 ] }
} case ;
: fetch-instruction
[ instruction-counter>> ] [ instructions>> ] bi nth ;
: run-opp
[ fetch-instruction ] keep
over D-opp 0 >
[ run-D-opp ] [ run-S-opp ] if ;
: run-vm
'[
_
{
[ instruction-counter>> 0 = [ break ] when ]
[ run-opp ]
[ [ 1 + ] change-instruction-counter drop ]
[ [ [ 2^14 >= ] keep 0 ? ] change-instruction-counter drop ]
} cleave
t
] loop ;
: pad-scenario-data
dup length 24 divisor? [
dup length dup 24 mod 24 swap - + 0 pad-tail
] unless ;
: data-file>vm
binary file-contents
pad-scenario-data
12 group 2 group
[ 1 over [ 4 cut swap append ] change-nth ] map concat [
8 cut [ le> bits>double ] [ le> ] bi*
] { } map>assoc [ keys ] [ values ] bi <vm> ;
: scenario1 "vocab:icfp2009/bin1.obf" data-file>vm ;
: scenario2 "vocab:icfp2009/bin2.obf" data-file>vm ;
: scenario3 "vocab:icfp2009/bin3.obf" data-file>vm ;
: scenario4 "vocab:icfp2009/bin4.obf" data-file>vm ;
New Annotation