Merge branch 'master' into irc
Bruno Deferrari
commit
4d62b1be3c
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays arrays assocs kernel kernel.private libc math
|
||||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors alien.strings
|
||||
quotations layouts system compiler.units io io.files
|
||||
io.encodings.binary io.streams.memory accessors combinators effects
|
||||
continuations fry classes ;
|
||||
namespaces make parser sequences strings words splitting math.parser
|
||||
cpu.architecture alien alien.accessors alien.strings quotations
|
||||
layouts system compiler.units io io.files io.encodings.binary
|
||||
io.streams.memory accessors combinators effects continuations fry
|
||||
classes ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ WHERE
|
|||
: *T ( alien -- z )
|
||||
[ T-real ] [ T-imaginary ] bi rect> ; inline
|
||||
|
||||
T in get
|
||||
T current-vocab
|
||||
{ { N "real" } { N "imaginary" } }
|
||||
define-struct
|
||||
|
||||
|
|
|
|||
|
|
@ -421,7 +421,7 @@ PRIVATE>
|
|||
: define-fortran-record ( name vocab fields -- )
|
||||
[ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
|
||||
|
||||
SYNTAX: RECORD: scan in get parse-definition define-fortran-record ;
|
||||
SYNTAX: RECORD: scan current-vocab parse-definition define-fortran-record ;
|
||||
|
||||
: set-fortran-abi ( library -- )
|
||||
library-fortran-abis get-global at fortran-abi set ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
USING: accessors alien.c-types strings help.markup help.syntax
|
||||
alien.syntax sequences io arrays kernel words assocs namespaces
|
||||
accessors ;
|
||||
USING: alien.c-types strings help.markup help.syntax alien.syntax
|
||||
sequences io arrays kernel words assocs namespaces ;
|
||||
IN: alien.structs
|
||||
|
||||
ARTICLE: "c-structs" "C structure types"
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ SYNTAX: TYPEDEF:
|
|||
scan scan typedef ;
|
||||
|
||||
SYNTAX: C-STRUCT:
|
||||
scan in get parse-definition define-struct ;
|
||||
scan current-vocab parse-definition define-struct ;
|
||||
|
||||
SYNTAX: C-UNION:
|
||||
scan parse-definition define-union ;
|
||||
|
|
|
|||
|
|
@ -5,23 +5,51 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
|
|||
io.streams.byte-array ;
|
||||
IN: bitstreams.tests
|
||||
|
||||
[ 1 t ]
|
||||
[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
|
||||
|
||||
[ 254 8 t ]
|
||||
[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
|
||||
[ 4095 12 t ]
|
||||
[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
|
||||
|
||||
[ B{ 254 } ]
|
||||
[ BIN: 1111111111 ]
|
||||
[
|
||||
binary <byte-writer> <bitstream-writer> 254 8 rot
|
||||
[ write-bits ] keep stream>> >byte-array
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
10 swap peek
|
||||
] unit-test
|
||||
|
||||
[ 255 8 t ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
[ BIN: 111111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
9 swap peek
|
||||
] unit-test
|
||||
|
||||
[ 255 8 f ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
|
||||
[ BIN: 11111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
8 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 1111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
7 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
6 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 11111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
5 swap peek
|
||||
] unit-test
|
||||
|
||||
[ B{ } <msb0-bit-reader> 5 swap peek ] must-fail
|
||||
[ B{ } <msb0-bit-reader> 1 swap peek ] must-fail
|
||||
[ B{ } <msb0-bit-reader> 8 swap peek ] must-fail
|
||||
|
||||
[ 0 ] [ B{ } <msb0-bit-reader> 0 swap peek ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,96 +1,160 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays destructors fry io kernel locals
|
||||
math sequences ;
|
||||
USING: accessors alien.accessors assocs byte-arrays combinators
|
||||
constructors destructors fry io io.binary io.encodings.binary
|
||||
io.streams.byte-array kernel locals macros math math.ranges
|
||||
multiline sequences sequences.private vectors byte-vectors
|
||||
combinators.short-circuit math.bitwise ;
|
||||
IN: bitstreams
|
||||
|
||||
TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
|
||||
TUPLE: bitstream-reader < bitstream ;
|
||||
TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
|
||||
|
||||
: reset-bitstream ( stream -- stream )
|
||||
0 >>#bits 0 >>current-bits ; inline
|
||||
ERROR: invalid-widthed bits #bits ;
|
||||
|
||||
: new-bitstream ( stream class -- bitstream )
|
||||
: check-widthed ( bits #bits -- bits #bits )
|
||||
dup 0 < [ invalid-widthed ] when
|
||||
2dup { [ nip 0 = ] [ drop 0 = not ] } 2&& [ invalid-widthed ] when
|
||||
over 0 = [
|
||||
2dup [ dup 0 < [ neg ] when log2 1 + ] dip > [ invalid-widthed ] when
|
||||
] unless ;
|
||||
|
||||
: <widthed> ( bits #bits -- widthed )
|
||||
check-widthed
|
||||
widthed boa ;
|
||||
|
||||
: zero-widthed ( -- widthed ) 0 0 <widthed> ;
|
||||
: zero-widthed? ( widthed -- ? ) zero-widthed = ;
|
||||
|
||||
TUPLE: bit-reader
|
||||
{ bytes byte-array }
|
||||
{ byte-pos array-capacity initial: 0 }
|
||||
{ bit-pos array-capacity initial: 0 } ;
|
||||
|
||||
TUPLE: bit-writer
|
||||
{ bytes byte-vector }
|
||||
{ widthed widthed } ;
|
||||
|
||||
TUPLE: msb0-bit-reader < bit-reader ;
|
||||
TUPLE: lsb0-bit-reader < bit-reader ;
|
||||
CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
|
||||
CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
|
||||
|
||||
TUPLE: msb0-bit-writer < bit-writer ;
|
||||
TUPLE: lsb0-bit-writer < bit-writer ;
|
||||
|
||||
: new-bit-writer ( class -- bs )
|
||||
new
|
||||
swap >>stream
|
||||
reset-bitstream ; inline
|
||||
BV{ } clone >>bytes
|
||||
0 0 <widthed> >>widthed ; inline
|
||||
|
||||
M: bitstream-reader dispose ( stream -- )
|
||||
stream>> dispose ;
|
||||
: <msb0-bit-writer> ( -- bs )
|
||||
msb0-bit-writer new-bit-writer ;
|
||||
|
||||
: <bitstream-reader> ( stream -- bitstream )
|
||||
bitstream-reader new-bitstream ; inline
|
||||
: <lsb0-bit-writer> ( -- bs )
|
||||
lsb0-bit-writer new-bit-writer ;
|
||||
|
||||
: read-next-byte ( bitstream -- bitstream )
|
||||
dup stream>> stream-read1 [
|
||||
>>current-bits 8 >>#bits
|
||||
GENERIC: peek ( n bitstream -- value )
|
||||
GENERIC: poke ( value n bitstream -- )
|
||||
|
||||
: seek ( n bitstream -- )
|
||||
{
|
||||
[ byte-pos>> 8 * ]
|
||||
[ bit-pos>> + + 8 /mod ]
|
||||
[ (>>bit-pos) ]
|
||||
[ (>>byte-pos) ]
|
||||
} cleave ; inline
|
||||
|
||||
: read ( n bitstream -- value )
|
||||
[ peek ] [ seek ] 2bi ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
ERROR: not-enough-bits widthed n ;
|
||||
|
||||
: widthed-bits ( widthed n -- bits )
|
||||
dup 0 < [ not-enough-bits ] when
|
||||
2dup [ #bits>> ] dip < [ not-enough-bits ] when
|
||||
[ [ bits>> ] [ #bits>> ] bi ] dip
|
||||
[ - neg shift ] keep <widthed> ;
|
||||
|
||||
: split-widthed ( widthed n -- widthed1 widthed2 )
|
||||
2dup [ #bits>> ] dip < [
|
||||
drop zero-widthed
|
||||
] [
|
||||
0 >>#bits
|
||||
t >>end-of-stream?
|
||||
] if* ;
|
||||
|
||||
: maybe-read-next-byte ( bitstream -- bitstream )
|
||||
dup #bits>> 0 = [ read-next-byte ] when ; inline
|
||||
|
||||
: shift-one-bit ( bitstream -- n )
|
||||
[ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
|
||||
|
||||
: next-bit ( bitstream -- n/f ? )
|
||||
maybe-read-next-byte
|
||||
dup end-of-stream?>> [
|
||||
drop f
|
||||
] [
|
||||
[ shift-one-bit ]
|
||||
[ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
|
||||
] if dup >boolean ;
|
||||
|
||||
: read-bit ( bitstream -- n ? )
|
||||
dup #bits>> 1 = [
|
||||
[ current-bits>> 1 bitand ]
|
||||
[ read-next-byte drop ] bi t
|
||||
] [
|
||||
next-bit
|
||||
] if ; inline
|
||||
|
||||
: bits>integer ( seq -- n )
|
||||
0 [ [ 1 shift ] dip bitor ] reduce ; inline
|
||||
|
||||
: read-bits ( width bitstream -- n width ? )
|
||||
[
|
||||
'[ _ read-bit drop ] replicate
|
||||
[ f = ] trim-tail
|
||||
[ bits>integer ] [ length ] bi
|
||||
] 2keep drop over = ;
|
||||
|
||||
TUPLE: bitstream-writer < bitstream ;
|
||||
|
||||
: <bitstream-writer> ( stream -- bitstream )
|
||||
bitstream-writer new-bitstream ; inline
|
||||
|
||||
: write-bit ( n bitstream -- )
|
||||
[ 1 shift bitor ] change-current-bits
|
||||
[ 1+ ] change-#bits
|
||||
dup #bits>> 8 = [
|
||||
[ [ current-bits>> ] [ stream>> stream-write1 ] bi ]
|
||||
[ reset-bitstream drop ] bi
|
||||
] [
|
||||
drop
|
||||
] if ; inline
|
||||
|
||||
ERROR: invalid-bit-width n ;
|
||||
|
||||
:: write-bits ( n width bitstream -- )
|
||||
n 0 < [ n invalid-bit-width ] when
|
||||
n 0 = [
|
||||
width [ 0 bitstream write-bit ] times
|
||||
] [
|
||||
width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times
|
||||
n-length [
|
||||
n-length swap - 1- neg n swap shift 1 bitand
|
||||
bitstream write-bit
|
||||
] each
|
||||
[ widthed-bits ]
|
||||
[ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep <widthed> ] 2bi
|
||||
] if ;
|
||||
|
||||
: flush-bits ( bitstream -- ) stream>> stream-flush ;
|
||||
: widthed>bytes ( widthed -- bytes widthed )
|
||||
[ 8 split-widthed dup zero-widthed? not ]
|
||||
[ swap bits>> ] B{ } produce-as nip swap ;
|
||||
|
||||
: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;
|
||||
:: |widthed ( widthed1 widthed2 -- widthed3 )
|
||||
widthed1 bits>> :> bits1
|
||||
widthed1 #bits>> :> #bits1
|
||||
widthed2 bits>> :> bits2
|
||||
widthed2 #bits>> :> #bits2
|
||||
bits1 #bits2 shift bits2 bitor
|
||||
#bits1 #bits2 + <widthed> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M:: lsb0-bit-writer poke ( value n bs -- )
|
||||
value n <widthed> :> widthed
|
||||
widthed
|
||||
bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
|
||||
byte bs widthed>> |widthed :> new-byte
|
||||
new-byte #bits>> 8 = [
|
||||
new-byte bits>> bs bytes>> push
|
||||
zero-widthed bs (>>widthed)
|
||||
remainder widthed>bytes
|
||||
[ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
|
||||
] [
|
||||
byte bs (>>widthed)
|
||||
] if ;
|
||||
|
||||
: enough-bits? ( n bs -- ? )
|
||||
[ bytes>> length ]
|
||||
[ byte-pos>> - 8 * ]
|
||||
[ bit-pos>> - ] tri <= ;
|
||||
|
||||
ERROR: not-enough-bits n bit-reader ;
|
||||
|
||||
: #bits>#bytes ( #bits -- #bytes )
|
||||
8 /mod 0 = [ 1 + ] unless ; inline
|
||||
|
||||
:: subseq>bits-le ( bignum n bs -- bits )
|
||||
bignum bs bit-pos>> neg shift n bits ;
|
||||
|
||||
:: subseq>bits-be ( bignum n bs -- bits )
|
||||
bignum
|
||||
8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when
|
||||
neg shift n bits ;
|
||||
|
||||
:: adjust-bits ( n bs -- )
|
||||
n 8 /mod :> #bits :> #bytes
|
||||
bs [ #bytes + ] change-byte-pos
|
||||
bit-pos>> #bits + dup 8 >= [
|
||||
8 - bs (>>bit-pos)
|
||||
bs [ 1 + ] change-byte-pos drop
|
||||
] [
|
||||
bs (>>bit-pos)
|
||||
] if ;
|
||||
|
||||
:: (peek) ( n bs endian> subseq-endian -- bits )
|
||||
n bs enough-bits? [ n bs not-enough-bits ] unless
|
||||
bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
|
||||
bs bytes>> subseq endian> execute( seq -- x ) :> bignum
|
||||
bignum n bs subseq-endian execute( bignum n bs -- bits ) ;
|
||||
|
||||
M: lsb0-bit-reader peek ( n bs -- bits ) \ le> \ subseq>bits-le (peek) ;
|
||||
|
||||
M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
|
||||
|
||||
:: bit-writer-bytes ( writer -- bytes )
|
||||
writer widthed>> #bits>> :> n
|
||||
n 0 = [
|
||||
writer widthed>> bits>> 8 n - shift
|
||||
writer bytes>> swap push
|
||||
] unless
|
||||
writer bytes>> ;
|
||||
|
|
|
|||
|
|
@ -1,13 +1,14 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors compiler cpu.architecture vocabs.loader system
|
||||
USING: accessors cpu.architecture vocabs.loader system
|
||||
sequences namespaces parser kernel kernel.private classes
|
||||
classes.private arrays hashtables vectors classes.tuple sbufs
|
||||
hashtables.private sequences.private math classes.tuple.private
|
||||
growable namespaces.private assocs words command-line vocabs io
|
||||
io.encodings.string libc splitting math.parser memory
|
||||
compiler.units math.order compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.optimizer ;
|
||||
io.encodings.string libc splitting math.parser memory compiler.units
|
||||
math.order compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.cfg.optimizer ;
|
||||
FROM: compiler => enable-optimizer compile-word ;
|
||||
IN: bootstrap.compiler
|
||||
|
||||
! Don't bring this in when deploying, since it will store a
|
||||
|
|
@ -68,7 +69,7 @@ nl
|
|||
"." write flush
|
||||
|
||||
{
|
||||
new-sequence nth push pop peek flip
|
||||
new-sequence nth push pop last flip
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
|
|
|
|||
|
|
@ -1,15 +1,14 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays byte-arrays generic assocs hashtables assocs
|
||||
hashtables.private io io.binary io.files io.encodings.binary
|
||||
io.pathnames kernel kernel.private math namespaces make parser
|
||||
prettyprint sequences sequences.private strings sbufs vectors words
|
||||
quotations assocs system layouts splitting grouping growable classes
|
||||
classes.builtin classes.tuple classes.tuple.private vocabs
|
||||
vocabs.loader source-files definitions debugger quotations.private
|
||||
sequences.private combinators math.order math.private accessors
|
||||
slots.private generic.single.private compiler.units compiler.constants
|
||||
fry bootstrap.image.syntax ;
|
||||
USING: alien arrays byte-arrays generic hashtables hashtables.private
|
||||
io io.binary io.files io.encodings.binary io.pathnames kernel
|
||||
kernel.private math namespaces make parser prettyprint sequences
|
||||
strings sbufs vectors words quotations assocs system layouts splitting
|
||||
grouping growable classes classes.builtin classes.tuple
|
||||
classes.tuple.private vocabs vocabs.loader source-files definitions
|
||||
debugger quotations.private combinators math.order math.private
|
||||
accessors slots.private generic.single.private compiler.units
|
||||
compiler.constants fry bootstrap.image.syntax ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: arch ( os cpu -- arch )
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.order math.parser math.functions kernel
|
||||
sequences io accessors arrays io.streams.string splitting
|
||||
combinators accessors calendar calendar.format.macros present ;
|
||||
combinators calendar calendar.format.macros present ;
|
||||
IN: calendar.format
|
||||
|
||||
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
!
|
||||
! Channels - based on ideas from newsqueak
|
||||
USING: kernel sequences threads continuations
|
||||
random math accessors random ;
|
||||
random math accessors ;
|
||||
IN: channels
|
||||
|
||||
TUPLE: channel receivers senders ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,48 @@
|
|||
USING: kernel io strings byte-arrays sequences namespaces math
|
||||
parser checksums.hmac tools.test checksums.md5 checksums.sha
|
||||
checksums ;
|
||||
IN: checksums.hmac.tests
|
||||
|
||||
[
|
||||
"\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
|
||||
] [
|
||||
"Hi There" 16 11 <string> md5 hmac-bytes >string ] unit-test
|
||||
|
||||
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
|
||||
[ "what do ya want for nothing?" "Jefe" md5 hmac-bytes >string ] unit-test
|
||||
|
||||
[
|
||||
"V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
|
||||
]
|
||||
[
|
||||
50 HEX: dd <repetition>
|
||||
16 HEX: aa <string> md5 hmac-bytes >string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
|
||||
] [
|
||||
"Hi There" 16 11 <string> sha1 hmac-bytes >string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y"
|
||||
] [
|
||||
"what do ya want for nothing?" "Jefe" sha1 hmac-bytes >string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
|
||||
] [
|
||||
50 HEX: dd <repetition>
|
||||
16 HEX: aa <string> sha1 hmac-bytes >string
|
||||
] unit-test
|
||||
|
||||
[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ]
|
||||
[ "Hi There" 20 HEX: b <string> sha-256 hmac-bytes hex-string ] unit-test
|
||||
|
||||
[ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ]
|
||||
[
|
||||
"what do ya want for nothing?"
|
||||
"JefeJefeJefeJefeJefeJefeJefeJefe" sha-256 hmac-bytes hex-string
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays checksums combinators fry io io.binary
|
||||
io.encodings.binary io.files io.streams.byte-array kernel
|
||||
locals math math.vectors memoize sequences ;
|
||||
IN: checksums.hmac
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ;
|
||||
|
||||
: opad ( checksum-state -- seq ) block-size>> HEX: 5c <array> ;
|
||||
|
||||
: ipad ( checksum-state -- seq ) block-size>> HEX: 36 <array> ;
|
||||
|
||||
:: init-key ( checksum key checksum-state -- o i )
|
||||
checksum-state block-size>> key length <
|
||||
[ key checksum checksum-bytes ] [ key ] if
|
||||
checksum-state block-size>> 0 pad-tail
|
||||
[ checksum-state opad seq-bitxor ]
|
||||
[ checksum-state ipad seq-bitxor ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: hmac-stream ( stream key checksum -- value )
|
||||
checksum initialize-checksum-state :> checksum-state
|
||||
checksum key checksum-state init-key :> Ki :> Ko
|
||||
checksum-state Ki add-checksum-bytes
|
||||
stream add-checksum-stream get-checksum
|
||||
checksum initialize-checksum-state
|
||||
Ko add-checksum-bytes swap add-checksum-bytes
|
||||
get-checksum ;
|
||||
|
||||
: hmac-file ( path key checksum -- value )
|
||||
[ binary <file-reader> ] 2dip hmac-stream ;
|
||||
|
||||
: hmac-bytes ( seq key checksum -- value )
|
||||
[ binary <byte-reader> ] 2dip hmac-stream ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test checksums.interleave checksums.sha ;
|
||||
IN: checksums.interleave.tests
|
||||
|
||||
[
|
||||
B{
|
||||
59 155 253 205 75 163 94 115 208 42 227 92 181 19 60 232
|
||||
119 65 178 131 210 48 241 230 204 216 30 156 4 215 80 84 93
|
||||
206 44 1 18 128 150 153
|
||||
}
|
||||
] [
|
||||
B{
|
||||
102 83 241 12 26 250 181 76 97 200 37 117 168 74 254 48 216
|
||||
170 26 58 150 150 179 24 153 146 191 225 203 127 166 167
|
||||
}
|
||||
sha1 interleaved-checksum
|
||||
] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs checksums grouping kernel locals math sequences ;
|
||||
IN: checksums.interleave
|
||||
|
||||
: seq>2seq ( seq -- seq1 seq2 )
|
||||
#! { abcdefgh } -> { aceg } { bdfh }
|
||||
2 group flip [ { } { } ] [ first2 ] if-empty ;
|
||||
|
||||
: 2seq>seq ( seq1 seq2 -- seq )
|
||||
#! { aceg } { bdfh } -> { abcdefgh }
|
||||
[ zip concat ] keep like ;
|
||||
|
||||
:: interleaved-checksum ( bytes checksum -- seq )
|
||||
bytes [ zero? ] trim-head
|
||||
dup length odd? [ rest-slice ] when
|
||||
seq>2seq [ checksum checksum-bytes ] bi@ 2seq>seq ;
|
||||
|
|
@ -1,4 +1,6 @@
|
|||
USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
|
||||
USING: byte-arrays checksums checksums.md5 io.encodings.binary
|
||||
io.streams.byte-array kernel math namespaces tools.test ;
|
||||
|
||||
|
||||
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
|
|
@ -8,3 +10,24 @@ USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
|
|||
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<md5-state> "asdf" add-checksum-bytes
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<md5-state> "" add-checksum-bytes
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<md5-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,59 +1,55 @@
|
|||
! Copyright (C) 2006, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io io.binary io.files io.streams.byte-array math
|
||||
USING: alien.c-types kernel io io.binary io.files io.streams.byte-array math
|
||||
math.functions math.parser namespaces splitting grouping strings
|
||||
sequences byte-arrays locals sequences.private macros fry
|
||||
io.encodings.binary math.bitwise checksums
|
||||
checksums.common checksums.stream combinators ;
|
||||
io.encodings.binary math.bitwise checksums accessors
|
||||
checksums.common checksums.stream combinators combinators.smart
|
||||
specialized-arrays.uint literals hints ;
|
||||
IN: checksums.md5
|
||||
|
||||
! See http://www.faqs.org/rfcs/rfc1321.html
|
||||
SINGLETON: md5
|
||||
|
||||
INSTANCE: md5 stream-checksum
|
||||
|
||||
TUPLE: md5-state < checksum-state state old-state ;
|
||||
|
||||
: <md5-state> ( -- md5 )
|
||||
md5-state new-checksum-state
|
||||
64 >>block-size
|
||||
uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
|
||||
[ clone >>state ] [ >>old-state ] bi ;
|
||||
|
||||
M: md5 initialize-checksum-state drop <md5-state> ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOLS: a b c d old-a old-b old-c old-d ;
|
||||
: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
|
||||
|
||||
: T ( N -- Y )
|
||||
sin abs 32 2^ * >integer ; foldable
|
||||
: update-md5 ( md5 -- )
|
||||
[ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
|
||||
[ (>>old-state) ] [ (>>state) ] bi ;
|
||||
|
||||
: initialize-md5 ( -- )
|
||||
0 bytes-read set
|
||||
HEX: 67452301 dup a set old-a set
|
||||
HEX: efcdab89 dup b set old-b set
|
||||
HEX: 98badcfe dup c set old-c set
|
||||
HEX: 10325476 dup d set old-d set ;
|
||||
CONSTANT: T
|
||||
$[
|
||||
80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as
|
||||
]
|
||||
|
||||
: update-md ( -- )
|
||||
old-a a update-old-new
|
||||
old-b b update-old-new
|
||||
old-c c update-old-new
|
||||
old-d d update-old-new ;
|
||||
|
||||
:: (ABCD) ( x a b c d k s i func -- )
|
||||
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
|
||||
a [
|
||||
b get c get d get func call w+
|
||||
k x nth-unsafe w+
|
||||
i T w+
|
||||
s bitroll-32
|
||||
b get w+
|
||||
] change ; inline
|
||||
|
||||
: F ( X Y Z -- FXYZ )
|
||||
:: F ( X Y Z -- FXYZ )
|
||||
#! F(X,Y,Z) = XY v not(X) Z
|
||||
pick bitnot bitand [ bitand ] [ bitor ] bi* ;
|
||||
X Y bitand X bitnot Z bitand bitor ; inline
|
||||
|
||||
: G ( X Y Z -- GXYZ )
|
||||
:: G ( X Y Z -- GXYZ )
|
||||
#! G(X,Y,Z) = XZ v Y not(Z)
|
||||
dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
|
||||
X Z bitand Y Z bitnot bitand bitor ; inline
|
||||
|
||||
: H ( X Y Z -- HXYZ )
|
||||
#! H(X,Y,Z) = X xor Y xor Z
|
||||
bitxor bitxor ;
|
||||
bitxor bitxor ; inline
|
||||
|
||||
: I ( X Y Z -- IXYZ )
|
||||
:: I ( X Y Z -- IXYZ )
|
||||
#! I(X,Y,Z) = Y xor (X v not(Z))
|
||||
rot swap bitnot bitor bitxor ;
|
||||
Z bitnot X bitor Y bitxor ; inline
|
||||
|
||||
CONSTANT: S11 7
|
||||
CONSTANT: S12 12
|
||||
|
|
@ -72,10 +68,27 @@ CONSTANT: S42 10
|
|||
CONSTANT: S43 15
|
||||
CONSTANT: S44 21
|
||||
|
||||
MACRO: with-md5-round ( ops func -- )
|
||||
'[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ;
|
||||
CONSTANT: a 0
|
||||
CONSTANT: b 1
|
||||
CONSTANT: c 2
|
||||
CONSTANT: d 3
|
||||
|
||||
: (process-md5-block-F) ( block -- )
|
||||
:: (ABCD) ( x state a b c d k s i quot -- )
|
||||
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
|
||||
a state [
|
||||
b state nth-unsafe
|
||||
c state nth-unsafe
|
||||
d state nth-unsafe quot call w+
|
||||
k x nth-unsafe w+
|
||||
i T nth-unsafe w+
|
||||
s bitroll-32
|
||||
b state nth-unsafe w+ 32 bits
|
||||
] change-nth-unsafe ; inline
|
||||
|
||||
MACRO: with-md5-round ( ops quot -- )
|
||||
'[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
|
||||
|
||||
: (process-md5-block-F) ( block state -- )
|
||||
{
|
||||
[ a b c d 0 S11 1 ]
|
||||
[ d a b c 1 S12 2 ]
|
||||
|
|
@ -95,7 +108,7 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ b c d a 15 S14 16 ]
|
||||
} [ F ] with-md5-round ;
|
||||
|
||||
: (process-md5-block-G) ( block -- )
|
||||
: (process-md5-block-G) ( block state -- )
|
||||
{
|
||||
[ a b c d 1 S21 17 ]
|
||||
[ d a b c 6 S22 18 ]
|
||||
|
|
@ -115,7 +128,7 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ b c d a 12 S24 32 ]
|
||||
} [ G ] with-md5-round ;
|
||||
|
||||
: (process-md5-block-H) ( block -- )
|
||||
: (process-md5-block-H) ( block state -- )
|
||||
{
|
||||
[ a b c d 5 S31 33 ]
|
||||
[ d a b c 8 S32 34 ]
|
||||
|
|
@ -135,7 +148,7 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ b c d a 2 S34 48 ]
|
||||
} [ H ] with-md5-round ;
|
||||
|
||||
: (process-md5-block-I) ( block -- )
|
||||
: (process-md5-block-I) ( block state -- )
|
||||
{
|
||||
[ a b c d 0 S41 49 ]
|
||||
[ d a b c 7 S42 50 ]
|
||||
|
|
@ -155,36 +168,54 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ b c d a 9 S44 64 ]
|
||||
} [ I ] with-md5-round ;
|
||||
|
||||
: (process-md5-block) ( block -- )
|
||||
4 <groups> [ le> ] map {
|
||||
HINTS: (process-md5-block-F) { uint-array md5-state } ;
|
||||
HINTS: (process-md5-block-G) { uint-array md5-state } ;
|
||||
HINTS: (process-md5-block-H) { uint-array md5-state } ;
|
||||
HINTS: (process-md5-block-I) { uint-array md5-state } ;
|
||||
|
||||
: byte-array>le ( byte-array -- byte-array )
|
||||
little-endian? [
|
||||
dup 4 <sliced-groups> [
|
||||
[ [ 1 2 ] dip exchange-unsafe ]
|
||||
[ [ 0 3 ] dip exchange-unsafe ] bi
|
||||
] each
|
||||
] unless ;
|
||||
|
||||
: byte-array>uint-array-le ( byte-array -- uint-array )
|
||||
byte-array>le byte-array>uint-array ;
|
||||
|
||||
HINTS: byte-array>uint-array-le byte-array ;
|
||||
|
||||
: uint-array>byte-array-le ( uint-array -- byte-array )
|
||||
underlying>> byte-array>le ;
|
||||
|
||||
HINTS: uint-array>byte-array-le uint-array ;
|
||||
|
||||
M: md5-state checksum-block ( block state -- )
|
||||
[
|
||||
[ byte-array>uint-array-le ] [ state>> ] bi* {
|
||||
[ (process-md5-block-F) ]
|
||||
[ (process-md5-block-G) ]
|
||||
[ (process-md5-block-H) ]
|
||||
[ (process-md5-block-I) ]
|
||||
} cleave
|
||||
|
||||
update-md ;
|
||||
|
||||
: process-md5-block ( str -- )
|
||||
dup length [ bytes-read [ + ] change ] keep 64 = [
|
||||
(process-md5-block)
|
||||
} 2cleave
|
||||
] [
|
||||
f bytes-read get pad-last-block
|
||||
[ (process-md5-block) ] each
|
||||
] if ;
|
||||
nip update-md5
|
||||
] 2bi ;
|
||||
|
||||
: stream>md5 ( -- )
|
||||
64 read [ process-md5-block ] keep
|
||||
length 64 = [ stream>md5 ] when ;
|
||||
: md5>checksum ( md5 -- bytes ) state>> uint-array>byte-array-le ;
|
||||
|
||||
: get-md5 ( -- str )
|
||||
[ a b c d ] [ get 4 >le ] map concat >byte-array ;
|
||||
M: md5-state clone ( md5 -- new-md5 )
|
||||
call-next-method
|
||||
[ clone ] change-state
|
||||
[ clone ] change-old-state ;
|
||||
|
||||
M: md5-state get-checksum ( md5 -- bytes )
|
||||
clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri
|
||||
[ [ checksum-block ] curry each ] [ md5>checksum ] bi ;
|
||||
|
||||
M: md5 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <md5-state> ] dip add-checksum-stream get-checksum ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SINGLETON: md5
|
||||
|
||||
INSTANCE: md5 stream-checksum
|
||||
|
||||
M: md5 checksum-stream ( stream -- byte-array )
|
||||
drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;
|
||||
|
|
|
|||
|
|
@ -30,8 +30,8 @@ ARTICLE: "checksums.openssl" "OpenSSL checksums"
|
|||
"An error thrown if the digest name is unrecognized:"
|
||||
{ $subsection unknown-digest }
|
||||
"An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:"
|
||||
{ $example "USING: byte-arrays checksums checksums.openssl prettyprint ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" }
|
||||
{ $example "USING: byte-arrays checksums checksums.openssl ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" }
|
||||
"If we use the Factor implementation, we get the same result, just slightly slower:"
|
||||
{ $example "USING: byte-arrays checksums checksums.sha1 prettyprint ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
|
||||
{ $example "USING: byte-arrays checksums checksums.sha ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
|
||||
|
||||
ABOUT: "checksums.openssl"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: accessors byte-arrays checksums checksums.openssl
|
||||
combinators.short-circuit kernel system tools.test ;
|
||||
IN: checksums.openssl.tests
|
||||
USING: byte-arrays checksums.openssl checksums tools.test
|
||||
accessors kernel system ;
|
||||
|
||||
[
|
||||
B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 }
|
||||
|
|
@ -22,7 +22,7 @@ accessors kernel system ;
|
|||
"Bad checksum test" >byte-array
|
||||
"no such checksum" <openssl-checksum>
|
||||
checksum-bytes
|
||||
] [ [ unknown-digest? ] [ name>> "no such checksum" = ] bi and ]
|
||||
] [ { [ unknown-digest? ] [ name>> "no such checksum" = ] } 1&& ]
|
||||
must-fail-with
|
||||
|
||||
[ ] [ image openssl-sha1 checksum-file drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,18 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: checksums.sha
|
||||
|
||||
HELP: sha-224
|
||||
{ $class-description "SHA-224 checksum algorithm." } ;
|
||||
|
||||
HELP: sha-256
|
||||
{ $class-description "SHA-256 checksum algorithm." } ;
|
||||
|
||||
ARTICLE: "checksums.sha" "SHA-2 checksum"
|
||||
"The SHA family of checksum algorithms are one-way hashes useful for checksumming data. SHA-1 is considered insecure, while SHA-2 It is generally considered to be pretty strong." $nl
|
||||
"SHA-2 checksums:"
|
||||
{ $subsection sha-224 }
|
||||
{ $subsection sha-256 }
|
||||
"SHA-1 checksum:"
|
||||
{ $subsection sha1 } ;
|
||||
|
||||
ABOUT: "checksums.sha"
|
||||
|
|
@ -1,10 +1,18 @@
|
|||
USING: arrays kernel math namespaces sequences tools.test
|
||||
checksums.sha2 checksums ;
|
||||
IN: checksums.sha2.tests
|
||||
USING: arrays checksums checksums.sha checksums.sha.private
|
||||
io.encodings.binary io.streams.byte-array kernel math
|
||||
namespaces sequences tools.test ;
|
||||
IN: checksums.sha.tests
|
||||
|
||||
: test-checksum ( text identifier -- checksum )
|
||||
checksum-bytes hex-string ;
|
||||
|
||||
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
|
||||
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
|
||||
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
|
||||
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
|
||||
10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
|
||||
|
||||
|
||||
[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
|
||||
[
|
||||
"abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
|
||||
|
|
@ -36,7 +44,27 @@ IN: checksums.sha2.tests
|
|||
] unit-test
|
||||
|
||||
|
||||
|
||||
|
||||
! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
|
||||
! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<sha1-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<sha-256-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<sha-224-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
|
|
@ -3,16 +3,40 @@
|
|||
USING: kernel splitting grouping math sequences namespaces make
|
||||
io.binary math.bitwise checksums checksums.common
|
||||
sbufs strings combinators.smart math.ranges fry combinators
|
||||
accessors locals ;
|
||||
IN: checksums.sha2
|
||||
accessors locals checksums.stream multiline literals
|
||||
generalizations ;
|
||||
IN: checksums.sha
|
||||
|
||||
SINGLETON: sha1
|
||||
INSTANCE: sha1 stream-checksum
|
||||
|
||||
SINGLETON: sha-224
|
||||
SINGLETON: sha-256
|
||||
|
||||
INSTANCE: sha-224 checksum
|
||||
INSTANCE: sha-256 checksum
|
||||
INSTANCE: sha-224 stream-checksum
|
||||
INSTANCE: sha-256 stream-checksum
|
||||
|
||||
TUPLE: sha2-state K H word-size block-size ;
|
||||
TUPLE: sha1-state < checksum-state K H W word-size ;
|
||||
|
||||
CONSTANT: initial-H-sha1
|
||||
{
|
||||
HEX: 67452301
|
||||
HEX: efcdab89
|
||||
HEX: 98badcfe
|
||||
HEX: 10325476
|
||||
HEX: c3d2e1f0
|
||||
}
|
||||
|
||||
CONSTANT: K-sha1
|
||||
$[
|
||||
20 HEX: 5a827999 <repetition>
|
||||
20 HEX: 6ed9eba1 <repetition>
|
||||
20 HEX: 8f1bbcdc <repetition>
|
||||
20 HEX: ca62c1d6 <repetition>
|
||||
4 { } nappend-as
|
||||
]
|
||||
|
||||
TUPLE: sha2-state < checksum-state K H word-size ;
|
||||
|
||||
TUPLE: sha2-short < sha2-state ;
|
||||
|
||||
|
|
@ -22,6 +46,11 @@ TUPLE: sha-224-state < sha2-short ;
|
|||
|
||||
TUPLE: sha-256-state < sha2-short ;
|
||||
|
||||
M: sha2-state clone
|
||||
call-next-method
|
||||
[ clone ] change-H
|
||||
[ clone ] change-K ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: a 0
|
||||
|
|
@ -116,6 +145,33 @@ CONSTANT: K-384
|
|||
|
||||
ALIAS: K-512 K-384
|
||||
|
||||
: <sha1-state> ( -- sha1-state )
|
||||
sha1-state new-checksum-state
|
||||
64 >>block-size
|
||||
K-sha1 >>K
|
||||
initial-H-sha1 >>H
|
||||
4 >>word-size ;
|
||||
|
||||
: <sha-224-state> ( -- sha2-state )
|
||||
sha-224-state new-checksum-state
|
||||
64 >>block-size
|
||||
K-256 >>K
|
||||
initial-H-224 >>H
|
||||
4 >>word-size ;
|
||||
|
||||
: <sha-256-state> ( -- sha2-state )
|
||||
sha-256-state new-checksum-state
|
||||
64 >>block-size
|
||||
K-256 >>K
|
||||
initial-H-256 >>H
|
||||
4 >>word-size ;
|
||||
|
||||
M: sha1 initialize-checksum-state drop <sha1-state> ;
|
||||
|
||||
M: sha-224 initialize-checksum-state drop <sha-224-state> ;
|
||||
|
||||
M: sha-256 initialize-checksum-state drop <sha-256-state> ;
|
||||
|
||||
: s0-256 ( x -- x' )
|
||||
[
|
||||
[ -7 bitroll-32 ]
|
||||
|
|
@ -172,7 +228,7 @@ ALIAS: K-512 K-384
|
|||
[ -41 bitroll-64 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: process-M-256 ( n seq -- )
|
||||
: prepare-M-256 ( n seq -- )
|
||||
{
|
||||
[ [ 16 - ] dip nth ]
|
||||
[ [ 15 - ] dip nth s0-256 ]
|
||||
|
|
@ -181,7 +237,7 @@ ALIAS: K-512 K-384
|
|||
[ ]
|
||||
} 2cleave set-nth ; inline
|
||||
|
||||
: process-M-512 ( n seq -- )
|
||||
: prepare-M-512 ( n seq -- )
|
||||
{
|
||||
[ [ 16 - ] dip nth ]
|
||||
[ [ 15 - ] dip nth s0-512 ]
|
||||
|
|
@ -201,26 +257,6 @@ ALIAS: K-512 K-384
|
|||
|
||||
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
|
||||
|
||||
M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
|
||||
drop
|
||||
dup [
|
||||
HEX: 80 ,
|
||||
length
|
||||
[ 64 mod calculate-pad-length 0 <string> % ]
|
||||
[ 3 shift 8 >be % ] bi
|
||||
] "" make append ;
|
||||
|
||||
M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
|
||||
drop dup [
|
||||
HEX: 80 ,
|
||||
length
|
||||
[ 128 mod calculate-pad-length-long 0 <string> % ]
|
||||
[ 3 shift 8 >be % ] bi
|
||||
] "" make append ;
|
||||
|
||||
: seq>byte-array ( seq n -- string )
|
||||
'[ _ >be ] map B{ } join ;
|
||||
|
||||
:: T1-256 ( n M H sha2 -- T1 )
|
||||
n M nth
|
||||
n sha2 K>> nth +
|
||||
|
|
@ -257,7 +293,7 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
|
|||
[ word-size>> <sliced-groups> [ be> ] map ]
|
||||
[
|
||||
block-size>> [ 0 pad-tail 16 ] keep [a,b) over
|
||||
'[ _ process-M-256 ] each
|
||||
'[ _ prepare-M-256 ] each
|
||||
] bi ; inline
|
||||
|
||||
:: process-chunk ( M block-size cloned-H sha2 -- )
|
||||
|
|
@ -266,41 +302,110 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
|
|||
cloned-H T2-256
|
||||
cloned-H update-H
|
||||
] each
|
||||
cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
|
||||
sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline
|
||||
|
||||
: sha2-steps ( sliced-groups state -- )
|
||||
'[
|
||||
_
|
||||
M: sha2-short checksum-block
|
||||
[ prepare-message-schedule ]
|
||||
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
|
||||
] each ;
|
||||
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
|
||||
|
||||
: byte-array>sha2 ( bytes state -- )
|
||||
[ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
|
||||
[ sha2-steps ] bi ;
|
||||
: seq>byte-array ( seq n -- string )
|
||||
'[ _ >be ] map B{ } join ;
|
||||
|
||||
: <sha-224-state> ( -- sha2-state )
|
||||
sha-224-state new
|
||||
K-256 >>K
|
||||
initial-H-224 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
: sha1>checksum ( sha2 -- bytes )
|
||||
H>> 4 seq>byte-array ;
|
||||
|
||||
: <sha-256-state> ( -- sha2-state )
|
||||
sha-256-state new
|
||||
K-256 >>K
|
||||
initial-H-256 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
: sha-224>checksum ( sha2 -- bytes )
|
||||
H>> 7 head 4 seq>byte-array ;
|
||||
|
||||
: sha-256>checksum ( sha2 -- bytes )
|
||||
H>> 4 seq>byte-array ;
|
||||
|
||||
: pad-last-short-block ( state -- )
|
||||
[ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri
|
||||
[ checksum-block ] curry each ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: sha-224 checksum-bytes
|
||||
drop <sha-224-state>
|
||||
[ byte-array>sha2 ]
|
||||
[ H>> 7 head 4 seq>byte-array ] bi ;
|
||||
M: sha-224-state get-checksum
|
||||
clone
|
||||
[ pad-last-short-block ] [ sha-224>checksum ] bi ;
|
||||
|
||||
M: sha-256 checksum-bytes
|
||||
drop <sha-256-state>
|
||||
[ byte-array>sha2 ]
|
||||
[ H>> 4 seq>byte-array ] bi ;
|
||||
M: sha-256-state get-checksum
|
||||
clone
|
||||
[ pad-last-short-block ] [ sha-256>checksum ] bi ;
|
||||
|
||||
M: sha-224 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <sha-224-state> ] dip add-checksum-stream get-checksum ;
|
||||
|
||||
M: sha-256 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <sha-256-state> ] dip add-checksum-stream get-checksum ;
|
||||
|
||||
|
||||
|
||||
: sha1-W ( t seq -- )
|
||||
{
|
||||
[ [ 3 - ] dip nth ]
|
||||
[ [ 8 - ] dip nth bitxor ]
|
||||
[ [ 14 - ] dip nth bitxor ]
|
||||
[ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
|
||||
[ ]
|
||||
} 2cleave set-nth ;
|
||||
|
||||
: prepare-sha1-message-schedule ( seq -- w-seq )
|
||||
4 <sliced-groups> [ be> ] map
|
||||
80 0 pad-tail 16 80 [a,b) over
|
||||
'[ _ sha1-W ] each ; inline
|
||||
|
||||
: sha1-f ( B C D n -- f_nbcd )
|
||||
20 /i
|
||||
{
|
||||
{ 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
|
||||
{ 1 [ bitxor bitxor ] }
|
||||
{ 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
|
||||
{ 3 [ bitxor bitxor ] }
|
||||
} case ;
|
||||
|
||||
:: inner-loop ( n H W K -- temp )
|
||||
a H nth :> A
|
||||
b H nth :> B
|
||||
c H nth :> C
|
||||
d H nth :> D
|
||||
e H nth :> E
|
||||
[
|
||||
A 5 bitroll-32
|
||||
|
||||
B C D n sha1-f
|
||||
|
||||
E
|
||||
|
||||
n K nth
|
||||
|
||||
n W nth
|
||||
] sum-outputs 32 bits ;
|
||||
|
||||
:: process-sha1-chunk ( bytes H W K state -- )
|
||||
80 [
|
||||
H W K inner-loop
|
||||
d H nth e H set-nth
|
||||
c H nth d H set-nth
|
||||
b H nth 30 bitroll-32 c H set-nth
|
||||
a H nth b H set-nth
|
||||
a H set-nth
|
||||
] each
|
||||
state [ H [ w+ ] 2map ] change-H drop ; inline
|
||||
|
||||
M:: sha1-state checksum-block ( bytes state -- )
|
||||
bytes prepare-sha1-message-schedule state (>>W)
|
||||
|
||||
bytes
|
||||
state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ;
|
||||
|
||||
M: sha1-state get-checksum
|
||||
clone
|
||||
[ pad-last-short-block ] [ sha-256>checksum ] bi ;
|
||||
|
||||
M: sha1 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <sha1-state> ] dip add-checksum-stream get-checksum ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
SHA checksum algorithms
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: checksums.sha1
|
||||
|
||||
HELP: sha1
|
||||
{ $class-description "SHA1 checksum algorithm." } ;
|
||||
|
||||
ARTICLE: "checksums.sha1" "SHA1 checksum"
|
||||
"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")."
|
||||
{ $subsection sha1 } ;
|
||||
|
||||
ABOUT: "checksums.sha1"
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
USING: arrays kernel math namespaces sequences tools.test checksums checksums.sha1 ;
|
||||
|
||||
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
|
||||
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
|
||||
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
|
||||
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
|
||||
10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
|
||||
|
||||
[
|
||||
";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
|
||||
] [
|
||||
"\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
|
||||
sha1-interleave
|
||||
] unit-test
|
||||
|
|
@ -1,134 +0,0 @@
|
|||
! Copyright (C) 2006, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators kernel io io.encodings.binary io.files
|
||||
io.streams.byte-array math.vectors strings sequences namespaces
|
||||
make math parser sequences assocs grouping vectors io.binary
|
||||
hashtables math.bitwise checksums checksums.common
|
||||
checksums.stream ;
|
||||
IN: checksums.sha1
|
||||
|
||||
! Implemented according to RFC 3174.
|
||||
|
||||
SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
|
||||
|
||||
: get-wth ( n -- wth ) w get nth ; inline
|
||||
: shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline
|
||||
|
||||
: initialize-sha1 ( -- )
|
||||
0 bytes-read set
|
||||
HEX: 67452301 dup h0 set A set
|
||||
HEX: efcdab89 dup h1 set B set
|
||||
HEX: 98badcfe dup h2 set C set
|
||||
HEX: 10325476 dup h3 set D set
|
||||
HEX: c3d2e1f0 dup h4 set E set
|
||||
[
|
||||
20 HEX: 5a827999 <array> %
|
||||
20 HEX: 6ed9eba1 <array> %
|
||||
20 HEX: 8f1bbcdc <array> %
|
||||
20 HEX: ca62c1d6 <array> %
|
||||
] { } make K set ;
|
||||
|
||||
! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
|
||||
: sha1-W ( t -- W_t )
|
||||
dup 3 - get-wth
|
||||
over 8 - get-wth bitxor
|
||||
over 14 - get-wth bitxor
|
||||
swap 16 - get-wth bitxor 1 bitroll-32 ;
|
||||
|
||||
! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D) ( 0 <= t <= 19)
|
||||
! f(t;B,C,D) = B XOR C XOR D (20 <= t <= 39)
|
||||
! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59)
|
||||
! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79)
|
||||
: sha1-f ( B C D t -- f_tbcd )
|
||||
20 /i
|
||||
{
|
||||
{ 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
|
||||
{ 1 [ bitxor bitxor ] }
|
||||
{ 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
|
||||
{ 3 [ bitxor bitxor ] }
|
||||
} case ;
|
||||
|
||||
: nth-int-be ( string n -- int )
|
||||
4 * dup 4 + rot <slice> be> ; inline
|
||||
|
||||
: make-w ( str -- )
|
||||
#! compute w, steps a-b of RFC 3174, section 6.1
|
||||
16 [ nth-int-be w get push ] with each
|
||||
16 80 dup <slice> [ sha1-W w get push ] each ;
|
||||
|
||||
: init-letters ( -- )
|
||||
! step c of RFC 3174, section 6.1
|
||||
h0 get A set
|
||||
h1 get B set
|
||||
h2 get C set
|
||||
h3 get D set
|
||||
h4 get E set ;
|
||||
|
||||
: inner-loop ( n -- temp )
|
||||
! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
|
||||
[
|
||||
[ B get C get D get ] keep sha1-f ,
|
||||
dup get-wth ,
|
||||
K get nth ,
|
||||
A get 5 bitroll-32 ,
|
||||
E get ,
|
||||
] { } make sum 32 bits ; inline
|
||||
|
||||
: set-vars ( temp -- )
|
||||
! E = D; D = C; C = S^30(B); B = A; A = TEMP;
|
||||
D get E set
|
||||
C get D set
|
||||
B get 30 bitroll-32 C set
|
||||
A get B set
|
||||
A set ;
|
||||
|
||||
: calculate-letters ( -- )
|
||||
! step d of RFC 3174, section 6.1
|
||||
80 [ inner-loop set-vars ] each ;
|
||||
|
||||
: update-hs ( -- )
|
||||
! step e of RFC 3174, section 6.1
|
||||
A h0 update-old-new
|
||||
B h1 update-old-new
|
||||
C h2 update-old-new
|
||||
D h3 update-old-new
|
||||
E h4 update-old-new ;
|
||||
|
||||
: (process-sha1-block) ( str -- )
|
||||
80 <vector> w set make-w init-letters calculate-letters update-hs ;
|
||||
|
||||
: process-sha1-block ( str -- )
|
||||
dup length [ bytes-read [ + ] change ] keep 64 = [
|
||||
(process-sha1-block)
|
||||
] [
|
||||
t bytes-read get pad-last-block
|
||||
[ (process-sha1-block) ] each
|
||||
] if ;
|
||||
|
||||
: stream>sha1 ( -- )
|
||||
64 read [ process-sha1-block ] keep
|
||||
length 64 = [ stream>sha1 ] when ;
|
||||
|
||||
: get-sha1 ( -- str )
|
||||
[ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
|
||||
|
||||
SINGLETON: sha1
|
||||
|
||||
INSTANCE: sha1 stream-checksum
|
||||
|
||||
M: sha1 checksum-stream ( stream -- sha1 )
|
||||
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
|
||||
|
||||
: seq>2seq ( seq -- seq1 seq2 )
|
||||
#! { abcdefgh } -> { aceg } { bdfh }
|
||||
2 group flip [ { } { } ] [ first2 ] if-empty ;
|
||||
|
||||
: 2seq>seq ( seq1 seq2 -- seq )
|
||||
#! { aceg } { bdfh } -> { abcdefgh }
|
||||
[ zip concat ] keep like ;
|
||||
|
||||
: sha1-interleave ( string -- seq )
|
||||
[ zero? ] trim-head
|
||||
dup length odd? [ rest ] when
|
||||
seq>2seq [ sha1 checksum-bytes ] bi@
|
||||
2seq>seq ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
SHA1 checksum algorithm
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: checksums.sha2
|
||||
|
||||
HELP: sha-256
|
||||
{ $class-description "SHA-256 checksum algorithm." } ;
|
||||
|
||||
ARTICLE: "checksums.sha2" "SHA2 checksum"
|
||||
"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong."
|
||||
{ $subsection sha-256 } ;
|
||||
|
||||
ABOUT: "checksums.sha2"
|
||||
|
|
@ -1 +0,0 @@
|
|||
SHA2 checksum algorithm
|
||||
|
|
@ -43,6 +43,11 @@ HELP: push-growing-circular
|
|||
{ "elt" object } { "circular" circular } }
|
||||
{ $description "Pushes an element onto a " { $link growing-circular } " object." } ;
|
||||
|
||||
HELP: rotate-circular
|
||||
{ $values
|
||||
{ "circular" circular } }
|
||||
{ $description "Advances the start index of a circular object by one." } ;
|
||||
|
||||
ARTICLE: "circular" "Circular sequences"
|
||||
"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
|
||||
"Creating a new circular object:"
|
||||
|
|
@ -51,6 +56,7 @@ ARTICLE: "circular" "Circular sequences"
|
|||
{ $subsection <growing-circular> }
|
||||
"Changing the start index:"
|
||||
{ $subsection change-circular-start }
|
||||
{ $subsection rotate-circular }
|
||||
"Pushing new elements:"
|
||||
{ $subsection push-circular }
|
||||
{ $subsection push-growing-circular } ;
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ circular strings ;
|
|||
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
|
||||
|
||||
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
|
||||
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
|
||||
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
|
||||
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
|
||||
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
|
||||
|
|
|
|||
|
|
@ -27,6 +27,9 @@ M: circular virtual-seq seq>> ;
|
|||
#! change start to (start + n) mod length
|
||||
circular-wrap (>>start) ;
|
||||
|
||||
: rotate-circular ( circular -- )
|
||||
[ start>> 1 + ] keep circular-wrap (>>start) ;
|
||||
|
||||
: push-circular ( elt circular -- )
|
||||
[ set-first ] [ 1 swap change-circular-start ] bi ;
|
||||
|
||||
|
|
@ -43,13 +46,13 @@ M: growing-circular length length>> ;
|
|||
: full? ( circular -- ? )
|
||||
[ length ] [ seq>> length ] bi = ;
|
||||
|
||||
: set-peek ( elt seq -- )
|
||||
: set-last ( elt seq -- )
|
||||
[ length 1- ] keep set-nth ;
|
||||
PRIVATE>
|
||||
|
||||
: push-growing-circular ( elt circular -- )
|
||||
dup full? [ push-circular ]
|
||||
[ [ 1+ ] change-length set-peek ] if ;
|
||||
[ [ 1+ ] change-length set-last ] if ;
|
||||
|
||||
: <growing-circular> ( capacity -- growing-circular )
|
||||
{ } new-sequence 0 0 growing-circular boa ;
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types alien.strings arrays assocs
|
||||
continuations combinators compiler compiler.alien stack-checker kernel
|
||||
math namespaces make parser quotations sequences strings words
|
||||
math namespaces make quotations sequences strings words
|
||||
cocoa.runtime io macros memoize io.encodings.utf8 effects libc
|
||||
libc.private parser lexer init core-foundation fry generalizations
|
||||
libc.private lexer init core-foundation fry generalizations
|
||||
specialized-arrays.direct.alien ;
|
||||
IN: cocoa.messages
|
||||
|
||||
|
|
|
|||
|
|
@ -69,6 +69,4 @@ SYMBOL: main-vocab-hook
|
|||
: ignore-cli-args? ( -- ? )
|
||||
os macosx? "run" get "ui" = and ;
|
||||
|
||||
: script-mode ( -- ) ;
|
||||
|
||||
[ default-cli-args ] "command-line" add-init-hook
|
||||
|
|
|
|||
|
|
@ -1,56 +1 @@
|
|||
USING: compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.alias-analysis compiler.cfg.debugger
|
||||
cpu.architecture tools.test kernel ;
|
||||
IN: compiler.cfg.alias-analysis.tests
|
||||
|
||||
[ ] [
|
||||
{
|
||||
T{ ##peek f V int-regs 2 D 1 f }
|
||||
T{ ##box-alien f V int-regs 1 V int-regs 2 }
|
||||
T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
|
||||
} alias-analysis drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
{
|
||||
T{ ##load-reference f V int-regs 1 "hello" }
|
||||
T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
|
||||
} alias-analysis drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##peek f V int-regs 1 D 1 f }
|
||||
T{ ##peek f V int-regs 2 D 2 f }
|
||||
T{ ##replace f V int-regs 1 D 0 f }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##peek f V int-regs 1 D 1 f }
|
||||
T{ ##peek f V int-regs 2 D 2 f }
|
||||
T{ ##replace f V int-regs 2 D 0 f }
|
||||
T{ ##replace f V int-regs 1 D 0 f }
|
||||
} alias-analysis
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##peek f V int-regs 1 D 1 f }
|
||||
T{ ##peek f V int-regs 2 D 0 f }
|
||||
T{ ##copy f V int-regs 3 V int-regs 2 f }
|
||||
T{ ##copy f V int-regs 4 V int-regs 1 f }
|
||||
T{ ##replace f V int-regs 3 D 0 f }
|
||||
T{ ##replace f V int-regs 4 D 1 f }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##peek f V int-regs 1 D 1 f }
|
||||
T{ ##peek f V int-regs 2 D 0 f }
|
||||
T{ ##replace f V int-regs 1 D 0 f }
|
||||
T{ ##replace f V int-regs 2 D 1 f }
|
||||
T{ ##peek f V int-regs 3 D 1 f }
|
||||
T{ ##peek f V int-regs 4 D 0 f }
|
||||
T{ ##replace f V int-regs 3 D 0 f }
|
||||
T{ ##replace f V int-regs 4 D 1 f }
|
||||
} alias-analysis
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,15 +1,13 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces assocs hashtables sequences arrays
|
||||
accessors vectors combinators sets classes compiler.cfg
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.cfg.copy-prop ;
|
||||
compiler.cfg.copy-prop compiler.cfg.rpo
|
||||
compiler.cfg.liveness compiler.cfg.local ;
|
||||
IN: compiler.cfg.alias-analysis
|
||||
|
||||
! Alias analysis -- assumes compiler.cfg.height has already run.
|
||||
!
|
||||
! We try to eliminate redundant slot and stack
|
||||
! traffic using some simple heuristics.
|
||||
! We try to eliminate redundant slot operations using some simple heuristics.
|
||||
!
|
||||
! All heap-allocated objects which are loaded from the stack, or
|
||||
! other object slots are pessimistically assumed to belong to
|
||||
|
|
@ -17,9 +15,6 @@ IN: compiler.cfg.alias-analysis
|
|||
!
|
||||
! Freshly-allocated objects get their own alias class.
|
||||
!
|
||||
! The data and retain stack pointer registers are treated
|
||||
! uniformly, and each one gets its own alias class.
|
||||
!
|
||||
! Simple pseudo-C example showing load elimination:
|
||||
!
|
||||
! int *x, *y, z: inputs
|
||||
|
|
@ -68,15 +63,14 @@ IN: compiler.cfg.alias-analysis
|
|||
! Map vregs -> alias classes
|
||||
SYMBOL: vregs>acs
|
||||
|
||||
: check ( obj -- obj )
|
||||
[ "BUG: static type error detected" throw ] unless* ; inline
|
||||
ERROR: vreg-ac-not-set vreg ;
|
||||
|
||||
: vreg>ac ( vreg -- ac )
|
||||
#! Only vregs produced by ##allot, ##peek and ##slot can
|
||||
#! ever be used as valid inputs to ##slot and ##set-slot,
|
||||
#! so we assert this fact by not giving alias classes to
|
||||
#! other vregs.
|
||||
vregs>acs get at check ;
|
||||
vregs>acs get ?at [ vreg-ac-not-set ] unless ;
|
||||
|
||||
! Map alias classes -> sequence of vregs
|
||||
SYMBOL: acs>vregs
|
||||
|
|
@ -122,8 +116,10 @@ SYMBOL: histories
|
|||
#! value.
|
||||
over [ live-slots get at at ] [ 2drop f ] if ;
|
||||
|
||||
ERROR: vreg-has-no-slots vreg ;
|
||||
|
||||
: load-constant-slot ( value slot# vreg -- )
|
||||
live-slots get at check set-at ;
|
||||
live-slots get ?at [ vreg-has-no-slots ] unless set-at ;
|
||||
|
||||
: load-slot ( value slot#/f vreg -- )
|
||||
over [ load-constant-slot ] [ 3drop ] if ;
|
||||
|
|
@ -165,7 +161,7 @@ SYMBOL: heap-ac
|
|||
|
||||
: record-constant-set-slot ( slot# vreg -- )
|
||||
history [
|
||||
dup empty? [ dup peek store? [ dup pop* ] when ] unless
|
||||
dup empty? [ dup last store? [ dup pop* ] when ] unless
|
||||
store new-action swap ?push
|
||||
] change-at ;
|
||||
|
||||
|
|
@ -189,23 +185,19 @@ SYMBOL: constants
|
|||
GENERIC: insn-slot# ( insn -- slot#/f )
|
||||
GENERIC: insn-object ( insn -- vreg )
|
||||
|
||||
M: ##peek insn-slot# loc>> n>> ;
|
||||
M: ##replace insn-slot# loc>> n>> ;
|
||||
M: ##slot insn-slot# slot>> constant ;
|
||||
M: ##slot-imm insn-slot# slot>> ;
|
||||
M: ##set-slot insn-slot# slot>> constant ;
|
||||
M: ##set-slot-imm insn-slot# slot>> ;
|
||||
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
|
||||
|
||||
M: ##peek insn-object loc>> class ;
|
||||
M: ##replace insn-object loc>> class ;
|
||||
M: ##slot insn-object obj>> resolve ;
|
||||
M: ##slot-imm insn-object obj>> resolve ;
|
||||
M: ##set-slot insn-object obj>> resolve ;
|
||||
M: ##set-slot-imm insn-object obj>> resolve ;
|
||||
M: ##alien-global insn-object drop \ ##alien-global ;
|
||||
|
||||
: init-alias-analysis ( -- )
|
||||
: init-alias-analysis ( live-in -- )
|
||||
H{ } clone histories set
|
||||
H{ } clone vregs>acs set
|
||||
H{ } clone acs>vregs set
|
||||
|
|
@ -216,40 +208,26 @@ M: ##alien-global insn-object drop \ ##alien-global ;
|
|||
0 ac-counter set
|
||||
next-ac heap-ac set
|
||||
|
||||
ds-loc next-ac set-ac
|
||||
rs-loc next-ac set-ac ;
|
||||
[ set-heap-ac ] each ;
|
||||
|
||||
GENERIC: analyze-aliases* ( insn -- insn' )
|
||||
|
||||
M: ##load-immediate analyze-aliases*
|
||||
dup [ val>> ] [ dst>> ] bi constants get set-at ;
|
||||
|
||||
M: ##load-reference analyze-aliases*
|
||||
M: ##flushable analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##alien-global analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##allot analyze-aliases*
|
||||
#! A freshly allocated object is distinct from any other
|
||||
#! object.
|
||||
dup dst>> set-new-ac ;
|
||||
|
||||
M: ##box-float analyze-aliases*
|
||||
#! A freshly allocated object is distinct from any other
|
||||
#! object.
|
||||
dup dst>> set-new-ac ;
|
||||
|
||||
M: ##box-alien analyze-aliases*
|
||||
M: ##allocation analyze-aliases*
|
||||
#! A freshly allocated object is distinct from any other
|
||||
#! object.
|
||||
dup dst>> set-new-ac ;
|
||||
|
||||
M: ##read analyze-aliases*
|
||||
dup dst>> set-heap-ac
|
||||
call-next-method
|
||||
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
|
||||
2dup live-slot dup [
|
||||
2nip f \ ##copy boa analyze-aliases* nip
|
||||
2nip \ ##copy new-insn analyze-aliases* nip
|
||||
] [
|
||||
drop remember-slot
|
||||
] if ;
|
||||
|
|
@ -292,15 +270,6 @@ GENERIC: eliminate-dead-stores* ( insn -- insn' )
|
|||
] unless
|
||||
] when ;
|
||||
|
||||
M: ##replace eliminate-dead-stores*
|
||||
#! Writes to above the top of the stack can be pruned also.
|
||||
#! This is sound since any such writes are not observable
|
||||
#! after the basic block, and any reads of those locations
|
||||
#! will have been converted to copies by analyze-slot,
|
||||
#! and the final stack height of the basic block is set at
|
||||
#! the beginning by compiler.cfg.stack.
|
||||
dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ;
|
||||
|
||||
M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
|
||||
|
||||
M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
|
||||
|
|
@ -310,8 +279,10 @@ M: insn eliminate-dead-stores* ;
|
|||
: eliminate-dead-stores ( insns -- insns' )
|
||||
[ insn# set eliminate-dead-stores* ] map-index sift ;
|
||||
|
||||
: alias-analysis ( insns -- insns' )
|
||||
init-alias-analysis
|
||||
: alias-analysis-step ( insns -- insns' )
|
||||
analyze-aliases
|
||||
compute-live-stores
|
||||
eliminate-dead-stores ;
|
||||
|
||||
: alias-analysis ( cfg -- cfg' )
|
||||
[ init-alias-analysis ] [ alias-analysis-step ] local-optimization ;
|
||||
|
|
@ -81,30 +81,35 @@ GENERIC: emit-node ( node -- next )
|
|||
basic-block get successors>> push
|
||||
stop-iterating ;
|
||||
|
||||
: emit-call ( word -- next )
|
||||
: emit-call ( word height -- next )
|
||||
{
|
||||
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
|
||||
{ [ over loops get key? ] [ drop loops get at local-recursive-call ] }
|
||||
{ [ terminate-call? ] [ ##call stop-iterating ] }
|
||||
{ [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
|
||||
{ [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
|
||||
[ ##epilogue ##jump stop-iterating ]
|
||||
{ [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
|
||||
[ drop ##epilogue ##jump stop-iterating ]
|
||||
} cond ;
|
||||
|
||||
! #recursive
|
||||
: compile-recursive ( node -- next )
|
||||
[ label>> id>> emit-call ]
|
||||
: recursive-height ( #recursive -- n )
|
||||
[ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
|
||||
|
||||
: emit-recursive ( #recursive -- next )
|
||||
[ [ label>> id>> ] [ recursive-height ] bi emit-call ]
|
||||
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
|
||||
|
||||
: remember-loop ( label -- )
|
||||
basic-block get swap loops get set-at ;
|
||||
|
||||
: compile-loop ( node -- next )
|
||||
: emit-loop ( node -- next )
|
||||
##loop-entry
|
||||
##branch
|
||||
begin-basic-block
|
||||
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
|
||||
iterate-next ;
|
||||
|
||||
M: #recursive emit-node
|
||||
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
|
||||
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
|
||||
|
||||
! #if
|
||||
: emit-branch ( obj -- final-bb )
|
||||
|
|
@ -154,65 +159,16 @@ M: #if emit-node
|
|||
} cond iterate-next ;
|
||||
|
||||
! #dispatch
|
||||
: trivial-dispatch-branch? ( nodes -- ? )
|
||||
dup length 1 = [
|
||||
first dup #call? [
|
||||
word>> "intrinsic" word-prop not
|
||||
] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: dispatch-branch ( nodes word -- label )
|
||||
over trivial-dispatch-branch? [
|
||||
drop first word>>
|
||||
] [
|
||||
gensym [
|
||||
[
|
||||
V{ } clone node-stack set
|
||||
##prologue
|
||||
begin-basic-block
|
||||
emit-nodes
|
||||
basic-block get [
|
||||
##epilogue
|
||||
##return
|
||||
end-basic-block
|
||||
] when
|
||||
] with-cfg-builder
|
||||
] keep
|
||||
] if ;
|
||||
|
||||
: dispatch-branches ( node -- )
|
||||
children>> [
|
||||
current-word get dispatch-branch
|
||||
##dispatch-label
|
||||
] each ;
|
||||
|
||||
: emit-dispatch ( node -- )
|
||||
##epilogue
|
||||
ds-pop ^^offset>slot i 0 ##dispatch
|
||||
dispatch-branches ;
|
||||
|
||||
: <dispatch-block> ( -- word )
|
||||
gensym dup t "inlined-block" set-word-prop ;
|
||||
|
||||
M: #dispatch emit-node
|
||||
tail-call? [
|
||||
emit-dispatch stop-iterating
|
||||
] [
|
||||
current-word get <dispatch-block> [
|
||||
[
|
||||
begin-word
|
||||
emit-dispatch
|
||||
] with-cfg-builder
|
||||
] keep emit-call
|
||||
] if ;
|
||||
ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
|
||||
|
||||
! #call
|
||||
M: #call emit-node
|
||||
dup word>> dup "intrinsic" word-prop
|
||||
[ emit-intrinsic ] [ nip emit-call ] if ;
|
||||
[ emit-intrinsic ] [ swap call-height emit-call ] if ;
|
||||
|
||||
! #call-recursive
|
||||
M: #call-recursive emit-node label>> id>> emit-call ;
|
||||
M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
|
||||
|
||||
! #push
|
||||
M: #push emit-node
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays vectors accessors namespaces ;
|
||||
USING: kernel arrays vectors accessors
|
||||
namespaces make fry sequences ;
|
||||
IN: compiler.cfg
|
||||
|
||||
TUPLE: basic-block < identity-tuple
|
||||
|
|
@ -10,18 +11,27 @@ number
|
|||
{ successors vector }
|
||||
{ predecessors vector } ;
|
||||
|
||||
: <basic-block> ( -- basic-block )
|
||||
M: basic-block hashcode* nip id>> ;
|
||||
|
||||
: <basic-block> ( -- bb )
|
||||
basic-block new
|
||||
V{ } clone >>instructions
|
||||
V{ } clone >>successors
|
||||
V{ } clone >>predecessors
|
||||
\ basic-block counter >>id ;
|
||||
|
||||
TUPLE: cfg { entry basic-block } word label ;
|
||||
: add-instructions ( bb quot -- )
|
||||
[ instructions>> building ] dip '[
|
||||
building get pop
|
||||
_ dip
|
||||
building get push
|
||||
] with-variable ; inline
|
||||
|
||||
C: <cfg> cfg
|
||||
TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
|
||||
|
||||
TUPLE: mr { instructions array } word label spill-counts ;
|
||||
: <cfg> ( entry word label -- cfg ) f f cfg boa ;
|
||||
|
||||
TUPLE: mr { instructions array } word label ;
|
||||
|
||||
: <mr> ( instructions word label -- mr )
|
||||
mr new
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness
|
||||
combinators.short-circuit accessors math sequences sets assocs ;
|
||||
IN: compiler.cfg.checker
|
||||
|
||||
ERROR: last-insn-not-a-jump insn ;
|
||||
|
||||
: check-last-instruction ( bb -- )
|
||||
last dup {
|
||||
[ ##branch? ]
|
||||
[ ##dispatch? ]
|
||||
[ ##conditional-branch? ]
|
||||
[ ##compare-imm-branch? ]
|
||||
[ ##return? ]
|
||||
[ ##callback-return? ]
|
||||
[ ##jump? ]
|
||||
[ ##call? ]
|
||||
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
|
||||
|
||||
ERROR: bad-loop-entry ;
|
||||
|
||||
: check-loop-entry ( bb -- )
|
||||
dup length 2 >= [
|
||||
2 head* [ ##loop-entry? ] any?
|
||||
[ bad-loop-entry ] when
|
||||
] [ drop ] if ;
|
||||
|
||||
ERROR: bad-successors ;
|
||||
|
||||
: check-successors ( bb -- )
|
||||
dup successors>> [ predecessors>> memq? ] with all?
|
||||
[ bad-successors ] unless ;
|
||||
|
||||
: check-basic-block ( bb -- )
|
||||
[ instructions>> check-last-instruction ]
|
||||
[ instructions>> check-loop-entry ]
|
||||
[ check-successors ]
|
||||
tri ;
|
||||
|
||||
ERROR: bad-live-in ;
|
||||
|
||||
ERROR: undefined-values uses defs ;
|
||||
|
||||
: check-mr ( mr -- )
|
||||
! Check that every used register has a definition
|
||||
instructions>>
|
||||
[ [ uses-vregs ] map concat ]
|
||||
[ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
|
||||
2dup subset? [ 2drop ] [ undefined-values ] if ;
|
||||
|
||||
: check-cfg ( cfg -- )
|
||||
compute-liveness
|
||||
[ entry>> live-in assoc-empty? [ bad-live-in ] unless ]
|
||||
[ [ check-basic-block ] each-basic-block ]
|
||||
[ flatten-cfg check-mr ]
|
||||
tri ;
|
||||
|
|
@ -6,7 +6,7 @@ IN: compiler.cfg.copy-prop
|
|||
SYMBOL: copies
|
||||
|
||||
: resolve ( vreg -- vreg )
|
||||
dup copies get at swap or ;
|
||||
[ copies get at ] keep or ;
|
||||
|
||||
: record-copy ( insn -- )
|
||||
[ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sets kernel namespaces sequences
|
||||
compiler.cfg.instructions compiler.cfg.def-use
|
||||
compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.dce
|
||||
|
||||
! Maps vregs to sequences of vregs
|
||||
SYMBOL: liveness-graph
|
||||
|
||||
! vregs which participate in side effects and thus are always live
|
||||
SYMBOL: live-vregs
|
||||
|
||||
: init-dead-code ( -- )
|
||||
H{ } clone liveness-graph set
|
||||
H{ } clone live-vregs set ;
|
||||
|
||||
GENERIC: update-liveness-graph ( insn -- )
|
||||
|
||||
M: ##flushable update-liveness-graph
|
||||
[ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
|
||||
|
||||
: record-live ( vregs -- )
|
||||
[
|
||||
dup live-vregs get key? [ drop ] [
|
||||
[ live-vregs get conjoin ]
|
||||
[ liveness-graph get at record-live ]
|
||||
bi
|
||||
] if
|
||||
] each ;
|
||||
|
||||
M: insn update-liveness-graph uses-vregs record-live ;
|
||||
|
||||
GENERIC: live-insn? ( insn -- ? )
|
||||
|
||||
M: ##flushable live-insn? dst>> live-vregs get key? ;
|
||||
|
||||
M: insn live-insn? drop t ;
|
||||
|
||||
: eliminate-dead-code ( cfg -- cfg' )
|
||||
init-dead-code
|
||||
[ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
|
||||
[ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
|
||||
[ ]
|
||||
tri ;
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
USING: compiler.cfg.dead-code compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.debugger
|
||||
cpu.architecture tools.test ;
|
||||
IN: compiler.cfg.dead-code.tests
|
||||
|
||||
[ { } ] [
|
||||
{ T{ ##load-immediate f V int-regs 134 16 } }
|
||||
eliminate-dead-code
|
||||
] unit-test
|
||||
|
|
@ -1,61 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sets kernel namespaces sequences
|
||||
compiler.cfg.instructions compiler.cfg.def-use ;
|
||||
IN: compiler.cfg.dead-code
|
||||
|
||||
! Dead code elimination -- assumes compiler.cfg.alias-analysis
|
||||
! has already run.
|
||||
|
||||
! Maps vregs to sequences of vregs
|
||||
SYMBOL: liveness-graph
|
||||
|
||||
! vregs which participate in side effects and thus are always live
|
||||
SYMBOL: live-vregs
|
||||
|
||||
! mapping vregs to stack locations
|
||||
SYMBOL: vregs>locs
|
||||
|
||||
: init-dead-code ( -- )
|
||||
H{ } clone liveness-graph set
|
||||
H{ } clone live-vregs set
|
||||
H{ } clone vregs>locs set ;
|
||||
|
||||
GENERIC: compute-liveness ( insn -- )
|
||||
|
||||
M: ##flushable compute-liveness
|
||||
[ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
|
||||
|
||||
M: ##peek compute-liveness
|
||||
[ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ]
|
||||
[ call-next-method ]
|
||||
bi ;
|
||||
|
||||
: live-replace? ( ##replace -- ? )
|
||||
[ src>> vregs>locs get at ] [ loc>> ] bi = not ;
|
||||
|
||||
M: ##replace compute-liveness
|
||||
dup live-replace? [ call-next-method ] [ drop ] if ;
|
||||
|
||||
: record-live ( vregs -- )
|
||||
[
|
||||
dup live-vregs get key? [ drop ] [
|
||||
[ live-vregs get conjoin ]
|
||||
[ liveness-graph get at record-live ]
|
||||
bi
|
||||
] if
|
||||
] each ;
|
||||
|
||||
M: insn compute-liveness uses-vregs record-live ;
|
||||
|
||||
GENERIC: live-insn? ( insn -- ? )
|
||||
|
||||
M: ##flushable live-insn? dst>> live-vregs get key? ;
|
||||
|
||||
M: ##replace live-insn? live-replace? ;
|
||||
|
||||
M: insn live-insn? drop t ;
|
||||
|
||||
: eliminate-dead-code ( insns -- insns' )
|
||||
init-dead-code
|
||||
[ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Dead-code elimination
|
||||
|
|
@ -7,7 +7,8 @@ parser compiler.tree.builder compiler.tree.optimizer
|
|||
compiler.cfg.builder compiler.cfg.linearization
|
||||
compiler.cfg.registers compiler.cfg.stack-frame
|
||||
compiler.cfg.linear-scan compiler.cfg.two-operand
|
||||
compiler.cfg.optimizer ;
|
||||
compiler.cfg.liveness compiler.cfg.optimizer
|
||||
compiler.cfg.mr ;
|
||||
IN: compiler.cfg.debugger
|
||||
|
||||
GENERIC: test-cfg ( quot -- cfgs )
|
||||
|
|
@ -18,20 +19,14 @@ M: callable test-cfg
|
|||
M: word test-cfg
|
||||
[ build-tree optimize-tree ] keep build-cfg ;
|
||||
|
||||
SYMBOL: allocate-registers?
|
||||
|
||||
: test-mr ( quot -- mrs )
|
||||
test-cfg [
|
||||
optimize-cfg
|
||||
build-mr
|
||||
convert-two-operand
|
||||
allocate-registers? get
|
||||
[ linear-scan build-stack-frame ] when
|
||||
] map ;
|
||||
|
||||
: insn. ( insn -- )
|
||||
tuple>array allocate-registers? get [ but-last ] unless
|
||||
[ pprint bl ] each nl ;
|
||||
tuple>array [ pprint bl ] each nl ;
|
||||
|
||||
: mr. ( mrs -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,28 +1,39 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.def-use
|
||||
|
||||
GENERIC: defs-vregs ( insn -- seq )
|
||||
GENERIC: temp-vregs ( insn -- seq )
|
||||
GENERIC: uses-vregs ( insn -- seq )
|
||||
|
||||
: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
|
||||
M: ##flushable defs-vregs dst>> 1array ;
|
||||
M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
|
||||
M: ##unary/temp defs-vregs dst/tmp-vregs ;
|
||||
M: ##allot defs-vregs dst/tmp-vregs ;
|
||||
M: ##dispatch defs-vregs temp>> 1array ;
|
||||
M: ##slot defs-vregs dst/tmp-vregs ;
|
||||
M: ##unary/temp defs-vregs dst>> 1array ;
|
||||
M: ##allot defs-vregs dst>> 1array ;
|
||||
M: ##slot defs-vregs dst>> 1array ;
|
||||
M: ##set-slot defs-vregs temp>> 1array ;
|
||||
M: ##string-nth defs-vregs dst/tmp-vregs ;
|
||||
M: ##set-string-nth-fast defs-vregs temp>> 1array ;
|
||||
M: ##compare defs-vregs dst/tmp-vregs ;
|
||||
M: ##compare-imm defs-vregs dst/tmp-vregs ;
|
||||
M: ##compare-float defs-vregs dst/tmp-vregs ;
|
||||
M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
|
||||
M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
|
||||
M: ##string-nth defs-vregs dst>> 1array ;
|
||||
M: ##compare defs-vregs dst>> 1array ;
|
||||
M: ##compare-imm defs-vregs dst>> 1array ;
|
||||
M: ##compare-float defs-vregs dst>> 1array ;
|
||||
M: insn defs-vregs drop f ;
|
||||
|
||||
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
|
||||
M: ##unary/temp temp-vregs temp>> 1array ;
|
||||
M: ##allot temp-vregs temp>> 1array ;
|
||||
M: ##dispatch temp-vregs temp>> 1array ;
|
||||
M: ##slot temp-vregs temp>> 1array ;
|
||||
M: ##set-slot temp-vregs temp>> 1array ;
|
||||
M: ##string-nth temp-vregs temp>> 1array ;
|
||||
M: ##set-string-nth-fast temp-vregs temp>> 1array ;
|
||||
M: ##compare temp-vregs temp>> 1array ;
|
||||
M: ##compare-imm temp-vregs temp>> 1array ;
|
||||
M: ##compare-float temp-vregs temp>> 1array ;
|
||||
M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
|
||||
M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
|
||||
M: _dispatch temp-vregs temp>> 1array ;
|
||||
M: insn temp-vregs drop f ;
|
||||
|
||||
M: ##unary uses-vregs src>> 1array ;
|
||||
M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||
M: ##binary-imm uses-vregs src1>> 1array ;
|
||||
|
|
@ -39,10 +50,14 @@ M: ##dispatch uses-vregs src>> 1array ;
|
|||
M: ##alien-getter uses-vregs src>> 1array ;
|
||||
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
|
||||
M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||
M: ##phi uses-vregs inputs>> ;
|
||||
M: ##gc uses-vregs live-in>> ;
|
||||
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||
M: _compare-imm-branch uses-vregs src1>> 1array ;
|
||||
M: _dispatch uses-vregs src>> 1array ;
|
||||
M: insn uses-vregs drop f ;
|
||||
|
||||
! Instructions that use vregs
|
||||
UNION: vreg-insn
|
||||
##flushable
|
||||
##write-barrier
|
||||
|
|
@ -51,5 +66,8 @@ UNION: vreg-insn
|
|||
##fixnum-overflow
|
||||
##conditional-branch
|
||||
##compare-imm-branch
|
||||
##phi
|
||||
##gc
|
||||
_conditional-branch
|
||||
_compare-imm-branch ;
|
||||
_compare-imm-branch
|
||||
_dispatch ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators compiler.cfg.rpo
|
||||
compiler.cfg.stack-analysis fry kernel math.order namespaces
|
||||
sequences ;
|
||||
IN: compiler.cfg.dominance
|
||||
|
||||
! Reference:
|
||||
|
||||
! A Simple, Fast Dominance Algorithm
|
||||
! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
|
||||
! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
|
||||
|
||||
SYMBOL: idoms
|
||||
|
||||
: idom ( bb -- bb' ) idoms get at ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
|
||||
|
||||
: intersect ( finger1 finger2 -- bb )
|
||||
2dup [ number>> ] compare {
|
||||
{ +lt+ [ [ idom ] dip intersect ] }
|
||||
{ +gt+ [ idom intersect ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
||||
: compute-idom ( bb -- idom )
|
||||
predecessors>> [ idom ] map sift
|
||||
[ ] [ intersect ] map-reduce ;
|
||||
|
||||
: iterate ( rpo -- changed? )
|
||||
[ [ compute-idom ] keep set-idom ] map [ ] any? ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: compute-dominance ( cfg -- cfg )
|
||||
H{ } clone idoms set
|
||||
dup reverse-post-order
|
||||
unclip dup set-idom drop '[ _ iterate ] loop ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences assocs
|
||||
cpu.architecture compiler.cfg.rpo
|
||||
compiler.cfg.liveness compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.gc-checks
|
||||
|
||||
: gc? ( bb -- ? )
|
||||
instructions>> [ ##allocation? ] any? ;
|
||||
|
||||
: object-pointer-regs ( basic-block -- vregs )
|
||||
live-in keys [ reg-class>> int-regs eq? ] filter ;
|
||||
|
||||
: insert-gc-check ( basic-block -- )
|
||||
dup gc? [
|
||||
dup
|
||||
[ swap object-pointer-regs \ ##gc new-insn prefix ]
|
||||
change-instructions drop
|
||||
] [ drop ] if ;
|
||||
|
||||
: insert-gc-checks ( cfg -- cfg' )
|
||||
dup [ insert-gc-check ] each-basic-block ;
|
||||
|
|
@ -73,3 +73,5 @@ IN: compiler.cfg.hats
|
|||
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
|
||||
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
|
||||
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
|
||||
|
||||
: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors math namespaces sequences kernel fry
|
||||
compiler.cfg compiler.cfg.registers compiler.cfg.instructions ;
|
||||
compiler.cfg compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.cfg.liveness compiler.cfg.local ;
|
||||
IN: compiler.cfg.height
|
||||
|
||||
! Combine multiple stack height changes into one at the
|
||||
|
|
@ -42,10 +43,13 @@ M: ##replace normalize-height* normalize-peek/replace ;
|
|||
|
||||
M: insn normalize-height* ;
|
||||
|
||||
: normalize-height ( insns -- insns' )
|
||||
: height-step ( insns -- insns' )
|
||||
0 ds-height set
|
||||
0 rs-height set
|
||||
[ [ compute-heights ] each ]
|
||||
[ [ [ normalize-height* ] map sift ] with-scope ] bi
|
||||
ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if
|
||||
rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ;
|
||||
ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
|
||||
rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
|
||||
|
||||
: normalize-height ( cfg -- cfg' )
|
||||
[ drop ] [ height-step ] local-optimization ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs accessors arrays kernel sequences namespaces words
|
||||
math math.order layouts classes.algebra alien byte-arrays
|
||||
|
|
@ -6,6 +6,8 @@ compiler.constants combinators compiler.cfg.registers
|
|||
compiler.cfg.instructions.syntax ;
|
||||
IN: compiler.cfg.instructions
|
||||
|
||||
: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline
|
||||
|
||||
! Virtual CPU instructions, used by CFG and machine IRs
|
||||
TUPLE: insn ;
|
||||
|
||||
|
|
@ -44,8 +46,8 @@ M: fixnum ##load-literal tag-fixnum ##load-immediate ;
|
|||
M: f ##load-literal drop \ f tag-number ##load-immediate ;
|
||||
M: object ##load-literal ##load-reference ;
|
||||
|
||||
INSN: ##peek < ##read { loc loc } ;
|
||||
INSN: ##replace < ##write { loc loc } ;
|
||||
INSN: ##peek < ##flushable { loc loc } ;
|
||||
INSN: ##replace < ##effect { loc loc } ;
|
||||
INSN: ##inc-d { n integer } ;
|
||||
INSN: ##inc-r { n integer } ;
|
||||
|
||||
|
|
@ -57,13 +59,12 @@ TUPLE: stack-frame
|
|||
spill-counts ;
|
||||
|
||||
INSN: ##stack-frame stack-frame ;
|
||||
INSN: ##call word ;
|
||||
INSN: ##call word { height integer } ;
|
||||
INSN: ##jump word ;
|
||||
INSN: ##return ;
|
||||
|
||||
! Jump tables
|
||||
INSN: ##dispatch src temp offset ;
|
||||
INSN: ##dispatch-label label ;
|
||||
INSN: ##dispatch src temp ;
|
||||
|
||||
! Slot access
|
||||
INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
|
||||
|
|
@ -160,9 +161,12 @@ INSN: ##set-alien-double < ##alien-setter ;
|
|||
|
||||
! Memory allocation
|
||||
INSN: ##allot < ##flushable size class { temp vreg } ;
|
||||
|
||||
UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
|
||||
|
||||
INSN: ##write-barrier < ##effect card# table ;
|
||||
|
||||
INSN: ##alien-global < ##read symbol library ;
|
||||
INSN: ##alien-global < ##flushable symbol library ;
|
||||
|
||||
! FFI
|
||||
INSN: ##alien-invoke params ;
|
||||
|
|
@ -178,6 +182,8 @@ INSN: ##branch ;
|
|||
|
||||
INSN: ##loop-entry ;
|
||||
|
||||
INSN: ##phi < ##pure inputs ;
|
||||
|
||||
! Condition codes
|
||||
SYMBOL: cc<
|
||||
SYMBOL: cc<=
|
||||
|
|
@ -217,16 +223,19 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
|
|||
INSN: ##compare-float-branch < ##conditional-branch ;
|
||||
INSN: ##compare-float < ##binary cc temp ;
|
||||
|
||||
INSN: ##gc live-in ;
|
||||
|
||||
! Instructions used by machine IR only.
|
||||
INSN: _prologue stack-frame ;
|
||||
INSN: _epilogue stack-frame ;
|
||||
|
||||
INSN: _label id ;
|
||||
|
||||
INSN: _gc ;
|
||||
|
||||
INSN: _branch label ;
|
||||
|
||||
INSN: _dispatch src temp ;
|
||||
INSN: _dispatch-label label ;
|
||||
|
||||
TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
|
||||
|
||||
INSN: _compare-branch < _conditional-branch ;
|
||||
|
|
|
|||
|
|
@ -11,12 +11,12 @@ IN: compiler.cfg.instructions.syntax
|
|||
"insn" "compiler.cfg.instructions" lookup ;
|
||||
|
||||
: insn-effect ( word -- effect )
|
||||
boa-effect in>> but-last f <effect> ;
|
||||
boa-effect in>> 2 head* f <effect> ;
|
||||
|
||||
SYNTAX: INSN:
|
||||
parse-tuple-definition "regs" suffix
|
||||
parse-tuple-definition { "regs" "insn#" } append
|
||||
[ dup tuple eq? [ drop insn-word ] when ] dip
|
||||
[ define-tuple-class ]
|
||||
[ 2drop save-location ]
|
||||
[ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
|
||||
[ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ]
|
||||
3tri ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ IN: compiler.cfg.intrinsics.allot
|
|||
[ second ds-load ] [ ^^load-literal ] bi prefix ;
|
||||
|
||||
: emit-<tuple-boa> ( node -- )
|
||||
dup node-input-infos peek literal>>
|
||||
dup node-input-infos last literal>>
|
||||
dup array? [
|
||||
nip
|
||||
ds-drop
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ SYMBOL: node-stack
|
|||
|
||||
: >node ( cursor -- ) node-stack get push ;
|
||||
: node> ( -- cursor ) node-stack get pop ;
|
||||
: node@ ( -- cursor ) node-stack get peek ;
|
||||
: node@ ( -- cursor ) node-stack get last ;
|
||||
: current-node ( -- node ) node@ first ;
|
||||
: iterate-next ( -- cursor ) node@ rest-slice ;
|
||||
: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
|
||||
|
|
@ -37,9 +37,9 @@ DEFER: (tail-call?)
|
|||
: tail-call? ( -- ? )
|
||||
node-stack get [
|
||||
rest-slice
|
||||
[ t ] [
|
||||
[ (tail-call?) ]
|
||||
[ first #terminate? not ]
|
||||
bi and
|
||||
] if-empty
|
||||
[ t ] [ (tail-call?) ] if-empty
|
||||
] all? ;
|
||||
|
||||
: terminate-call? ( -- ? )
|
||||
node-stack get last
|
||||
rest-slice [ f ] [ first #terminate? ] if-empty ;
|
||||
|
|
|
|||
|
|
@ -13,13 +13,13 @@ IN: compiler.cfg.linear-scan.assignment
|
|||
! but since we never have too many machine registers (around 30
|
||||
! at most) and we probably won't have that many live at any one
|
||||
! time anyway, it is not a problem to check each element.
|
||||
SYMBOL: active-intervals
|
||||
TUPLE: active-intervals seq ;
|
||||
|
||||
: add-active ( live-interval -- )
|
||||
active-intervals get push ;
|
||||
active-intervals get seq>> push ;
|
||||
|
||||
: lookup-register ( vreg -- reg )
|
||||
active-intervals get [ vreg>> = ] with find nip reg>> ;
|
||||
active-intervals get seq>> [ vreg>> = ] with find nip reg>> ;
|
||||
|
||||
! Minheap of live intervals which still need a register allocation
|
||||
SYMBOL: unhandled-intervals
|
||||
|
|
@ -41,8 +41,7 @@ SYMBOL: unhandled-intervals
|
|||
|
||||
: expire-old-intervals ( n -- )
|
||||
active-intervals get
|
||||
swap '[ end>> _ = ] partition
|
||||
active-intervals set
|
||||
[ swap '[ end>> _ = ] partition ] change-seq drop
|
||||
[ insert-spill ] each ;
|
||||
|
||||
: insert-reload ( live-interval -- )
|
||||
|
|
@ -59,29 +58,38 @@ SYMBOL: unhandled-intervals
|
|||
] [ 2drop ] if
|
||||
] if ;
|
||||
|
||||
GENERIC: (assign-registers) ( insn -- )
|
||||
GENERIC: assign-registers-in-insn ( insn -- )
|
||||
|
||||
M: vreg-insn (assign-registers)
|
||||
dup
|
||||
[ defs-vregs ] [ uses-vregs ] bi append
|
||||
active-intervals get swap '[ vreg>> _ member? ] filter
|
||||
: all-vregs ( insn -- vregs )
|
||||
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
|
||||
|
||||
M: vreg-insn assign-registers-in-insn
|
||||
active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
|
||||
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
|
||||
>>regs drop ;
|
||||
|
||||
M: insn (assign-registers) drop ;
|
||||
M: insn assign-registers-in-insn drop ;
|
||||
|
||||
: <active-intervals> ( -- obj )
|
||||
V{ } clone active-intervals boa ;
|
||||
|
||||
: init-assignment ( live-intervals -- )
|
||||
V{ } clone active-intervals set
|
||||
<active-intervals> active-intervals set
|
||||
<min-heap> unhandled-intervals set
|
||||
init-unhandled ;
|
||||
|
||||
: assign-registers ( insns live-intervals -- insns' )
|
||||
: assign-registers-in-block ( bb -- )
|
||||
[
|
||||
init-assignment
|
||||
[
|
||||
[ activate-new-intervals ]
|
||||
[ drop [ (assign-registers) ] [ , ] bi ]
|
||||
[ expire-old-intervals ]
|
||||
[
|
||||
[ insn#>> activate-new-intervals ]
|
||||
[ [ assign-registers-in-insn ] [ , ] bi ]
|
||||
[ insn#>> expire-old-intervals ]
|
||||
tri
|
||||
] each-index
|
||||
] { } make ;
|
||||
] each
|
||||
] V{ } make
|
||||
] change-instructions drop ;
|
||||
|
||||
: assign-registers ( rpo live-intervals -- )
|
||||
init-assignment
|
||||
[ assign-registers-in-block ] each ;
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ IN: compiler.cfg.linear-scan.debugger
|
|||
[ split-children ] map concat check-assigned ;
|
||||
|
||||
: picture ( uses -- str )
|
||||
dup peek 1 + CHAR: space <string>
|
||||
dup last 1 + CHAR: space <string>
|
||||
[ '[ CHAR: * swap _ set-nth ] each ] keep ;
|
||||
|
||||
: interval-picture ( interval -- str )
|
||||
|
|
|
|||
|
|
@ -3,6 +3,8 @@ USING: tools.test random sorting sequences sets hashtables assocs
|
|||
kernel fry arrays splitting namespaces math accessors vectors
|
||||
math.order grouping
|
||||
cpu.architecture
|
||||
compiler.cfg
|
||||
compiler.cfg.optimizer
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.linear-scan
|
||||
|
|
@ -244,7 +246,7 @@ SYMBOL: max-uses
|
|||
swap int-regs swap vreg boa >>vreg
|
||||
max-uses get random 2 max [ not-taken ] replicate natural-sort
|
||||
[ >>uses ] [ first >>start ] bi
|
||||
dup uses>> peek >>end
|
||||
dup uses>> last >>end
|
||||
] map
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -264,9 +266,15 @@ SYMBOL: max-uses
|
|||
|
||||
USING: math.private compiler.cfg.debugger ;
|
||||
|
||||
[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
|
||||
[ ] [
|
||||
[ float+ float>fixnum 3 fixnum*fast ]
|
||||
test-cfg first optimize-cfg linear-scan drop
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
T{ basic-block
|
||||
{ instructions
|
||||
V{
|
||||
T{ ##allot
|
||||
f
|
||||
T{ vreg f int-regs 1 }
|
||||
|
|
@ -274,8 +282,11 @@ USING: math.private compiler.cfg.debugger ;
|
|||
array
|
||||
T{ vreg f int-regs 2 }
|
||||
f
|
||||
} clone
|
||||
1array (linear-scan) first regs>> values all-equal?
|
||||
}
|
||||
}
|
||||
}
|
||||
} clone [ [ clone ] map ] change-instructions
|
||||
dup 1array (linear-scan) instructions>> first regs>> values all-equal?
|
||||
] unit-test
|
||||
|
||||
[ 0 1 ] [
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors namespaces make
|
||||
cpu.architecture
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.linear-scan.numbering
|
||||
compiler.cfg.linear-scan.live-intervals
|
||||
compiler.cfg.linear-scan.allocation
|
||||
compiler.cfg.linear-scan.assignment ;
|
||||
|
|
@ -23,16 +25,13 @@ IN: compiler.cfg.linear-scan
|
|||
! by Omri Traub, Glenn Holloway, Michael D. Smith
|
||||
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
|
||||
|
||||
: (linear-scan) ( insns -- insns' )
|
||||
: (linear-scan) ( rpo -- )
|
||||
dup number-instructions
|
||||
dup compute-live-intervals
|
||||
machine-registers allocate-registers assign-registers ;
|
||||
|
||||
: linear-scan ( mr -- mr' )
|
||||
: linear-scan ( cfg -- cfg' )
|
||||
[
|
||||
[
|
||||
[
|
||||
(linear-scan) %
|
||||
spill-counts get _spill-counts
|
||||
] { } make
|
||||
] change-instructions
|
||||
dup reverse-post-order (linear-scan)
|
||||
spill-counts get >>spill-counts
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel assocs accessors sequences math fry
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
|
|
@ -38,27 +38,29 @@ SYMBOL: live-intervals
|
|||
[ [ <live-interval> ] keep ] dip set-at
|
||||
] if ;
|
||||
|
||||
GENERIC# compute-live-intervals* 1 ( insn n -- )
|
||||
GENERIC: compute-live-intervals* ( insn -- )
|
||||
|
||||
M: insn compute-live-intervals* 2drop ;
|
||||
M: insn compute-live-intervals* drop ;
|
||||
|
||||
M: vreg-insn compute-live-intervals*
|
||||
dup insn#>>
|
||||
live-intervals get
|
||||
[ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
|
||||
[ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
|
||||
3bi ;
|
||||
[ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
|
||||
3tri ;
|
||||
|
||||
: record-copy ( insn -- )
|
||||
[ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
|
||||
|
||||
M: ##copy compute-live-intervals*
|
||||
[ call-next-method ] [ drop record-copy ] 2bi ;
|
||||
[ call-next-method ] [ record-copy ] bi ;
|
||||
|
||||
M: ##copy-float compute-live-intervals*
|
||||
[ call-next-method ] [ drop record-copy ] 2bi ;
|
||||
[ call-next-method ] [ record-copy ] bi ;
|
||||
|
||||
: compute-live-intervals ( instructions -- live-intervals )
|
||||
: compute-live-intervals ( rpo -- live-intervals )
|
||||
H{ } clone [
|
||||
live-intervals set
|
||||
[ compute-live-intervals* ] each-index
|
||||
[ instructions>> [ compute-live-intervals* ] each ] each
|
||||
] keep values ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors math sequences ;
|
||||
IN: compiler.cfg.linear-scan.numbering
|
||||
|
||||
: number-instructions ( rpo -- )
|
||||
[ 0 ] dip [
|
||||
instructions>> [
|
||||
[ (>>insn#) ] [ drop 2 + ] 2bi
|
||||
] each
|
||||
] each drop ;
|
||||
|
|
@ -1,17 +1,21 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math accessors sequences namespaces make
|
||||
combinators classes
|
||||
combinators assocs
|
||||
cpu.architecture
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.linearization
|
||||
|
||||
! Convert CFG IR to machine IR.
|
||||
GENERIC: linearize-insn ( basic-block insn -- )
|
||||
|
||||
: linearize-insns ( basic-block -- )
|
||||
dup instructions>> [ linearize-insn ] with each ; inline
|
||||
: linearize-basic-block ( bb -- )
|
||||
[ number>> _label ]
|
||||
[ dup instructions>> [ linearize-insn ] with each ]
|
||||
bi ;
|
||||
|
||||
M: insn linearize-insn , drop ;
|
||||
|
||||
|
|
@ -30,7 +34,7 @@ M: insn linearize-insn , drop ;
|
|||
: emit-branch ( basic-block successor -- )
|
||||
{
|
||||
{ [ 2dup useless-branch? ] [ 2drop ] }
|
||||
{ [ dup branch-to-branch? ] [ nip linearize-insns ] }
|
||||
{ [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
|
||||
[ nip number>> _branch ]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -46,35 +50,31 @@ M: ##branch linearize-insn
|
|||
[ drop dup successors>> second useless-branch? ] 2bi
|
||||
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
|
||||
|
||||
: with-regs ( insn quot -- )
|
||||
over regs>> [ call ] dip building get last (>>regs) ; inline
|
||||
|
||||
M: ##compare-branch linearize-insn
|
||||
binary-conditional _compare-branch emit-branch ;
|
||||
[ binary-conditional _compare-branch ] with-regs emit-branch ;
|
||||
|
||||
M: ##compare-imm-branch linearize-insn
|
||||
binary-conditional _compare-imm-branch emit-branch ;
|
||||
[ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
|
||||
|
||||
M: ##compare-float-branch linearize-insn
|
||||
binary-conditional _compare-float-branch emit-branch ;
|
||||
[ binary-conditional _compare-float-branch ] with-regs emit-branch ;
|
||||
|
||||
: gc? ( bb -- ? )
|
||||
instructions>> [
|
||||
class {
|
||||
##allot
|
||||
##integer>bignum
|
||||
##box-float
|
||||
##box-alien
|
||||
} memq?
|
||||
] any? ;
|
||||
M: ##dispatch linearize-insn
|
||||
swap
|
||||
[ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
|
||||
[ successors>> [ number>> _dispatch-label ] each ]
|
||||
bi* ;
|
||||
|
||||
: linearize-basic-block ( bb -- )
|
||||
[ number>> _label ]
|
||||
[ gc? [ _gc ] when ]
|
||||
[ linearize-insns ]
|
||||
tri ;
|
||||
: linearize-basic-blocks ( cfg -- insns )
|
||||
[
|
||||
[ [ linearize-basic-block ] each-basic-block ]
|
||||
[ spill-counts>> _spill-counts ]
|
||||
bi
|
||||
] { } make ;
|
||||
|
||||
: linearize-basic-blocks ( rpo -- insns )
|
||||
[ [ linearize-basic-block ] each ] { } make ;
|
||||
|
||||
: build-mr ( cfg -- mr )
|
||||
[ entry>> reverse-post-order linearize-basic-blocks ]
|
||||
[ word>> ] [ label>> ]
|
||||
tri <mr> ;
|
||||
: flatten-cfg ( cfg -- mr )
|
||||
[ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
|
||||
<mr> ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces deques accessors sets sequences assocs fry
|
||||
dlists compiler.cfg.def-use compiler.cfg.instructions
|
||||
compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.liveness
|
||||
|
||||
! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
|
||||
|
||||
! Assoc mapping basic blocks to sets of vregs
|
||||
SYMBOL: live-ins
|
||||
|
||||
: live-in ( basic-block -- set ) live-ins get at ;
|
||||
|
||||
! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
|
||||
! is in conrrespondence with a predecessor
|
||||
SYMBOL: phi-live-ins
|
||||
|
||||
: phi-live-in ( predecessor basic-block -- set )
|
||||
[ predecessors>> index ] keep phi-live-ins get at
|
||||
dup [ nth ] [ 2drop f ] if ;
|
||||
|
||||
! Assoc mapping basic blocks to sets of vregs
|
||||
SYMBOL: live-outs
|
||||
|
||||
: live-out ( basic-block -- set ) live-outs get at ;
|
||||
|
||||
SYMBOL: work-list
|
||||
|
||||
: add-to-work-list ( basic-blocks -- )
|
||||
work-list get '[ _ push-front ] each ;
|
||||
|
||||
: map-unique ( seq quot -- assoc )
|
||||
map concat unique ; inline
|
||||
|
||||
: gen-set ( instructions -- seq )
|
||||
[ ##phi? not ] filter [ uses-vregs ] map-unique ;
|
||||
|
||||
: kill-set ( instructions -- seq )
|
||||
[ [ defs-vregs ] [ temp-vregs ] bi append ] map-unique ;
|
||||
|
||||
: compute-live-in ( basic-block -- live-in )
|
||||
dup instructions>>
|
||||
[ [ live-out ] [ gen-set ] bi* assoc-union ]
|
||||
[ nip kill-set ]
|
||||
2bi assoc-diff ;
|
||||
|
||||
: compute-phi-live-in ( basic-block -- phi-live-in )
|
||||
instructions>> [ ##phi? ] filter
|
||||
[ f ] [ [ inputs>> ] map flip [ unique ] map ] if-empty ;
|
||||
|
||||
: update-live-in ( basic-block -- changed? )
|
||||
[ [ compute-live-in ] keep live-ins get maybe-set-at ]
|
||||
[ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
|
||||
bi and ;
|
||||
|
||||
: compute-live-out ( basic-block -- live-out )
|
||||
[ successors>> [ live-in ] map ]
|
||||
[ dup successors>> [ phi-live-in ] with map ] bi
|
||||
append assoc-combine ;
|
||||
|
||||
: update-live-out ( basic-block -- changed? )
|
||||
[ compute-live-out ] keep
|
||||
live-outs get maybe-set-at ;
|
||||
|
||||
: liveness-step ( basic-block -- )
|
||||
dup update-live-out [
|
||||
dup update-live-in
|
||||
[ predecessors>> add-to-work-list ] [ drop ] if
|
||||
] [ drop ] if ;
|
||||
|
||||
: compute-liveness ( cfg -- cfg' )
|
||||
<hashed-dlist> work-list set
|
||||
H{ } clone live-ins set
|
||||
H{ } clone phi-live-ins set
|
||||
H{ } clone live-outs set
|
||||
dup post-order add-to-work-list
|
||||
work-list get [ liveness-step ] slurp-deque ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.local
|
||||
|
||||
: optimize-basic-block ( bb init-quot insn-quot -- )
|
||||
[ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
|
||||
|
||||
: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
|
||||
[ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.cfg.linearization compiler.cfg.two-operand
|
||||
compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan
|
||||
compiler.cfg.stack-frame compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.mr
|
||||
|
||||
: build-mr ( cfg -- mr )
|
||||
convert-two-operand
|
||||
compute-liveness
|
||||
insert-gc-checks
|
||||
linear-scan
|
||||
flatten-cfg
|
||||
build-stack-frame ;
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
|
||||
compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
|
||||
sequences.private math sbufs math.private slots.private strings ;
|
||||
IN: compiler.cfg.optimizer.tests
|
||||
|
||||
! Miscellaneous tests
|
||||
|
||||
: more? ( x -- ? ) ;
|
||||
|
||||
: test-case-1 ( -- ? ) f ;
|
||||
|
||||
: test-case-2 ( -- )
|
||||
test-case-1 [ test-case-2 ] [ ] if ; inline recursive
|
||||
|
||||
{
|
||||
[ 1array ]
|
||||
[ 1 2 ? ]
|
||||
[ { array } declare [ ] map ]
|
||||
[ { array } declare dup 1 slot [ 1 slot ] when ]
|
||||
[ [ dup more? ] [ dup ] produce ]
|
||||
[ vector new over test-case-1 [ test-case-2 ] [ ] if ]
|
||||
[ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
|
||||
[
|
||||
{ fixnum sbuf } declare 2dup 3 slot fixnum> [
|
||||
over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
|
||||
] [ ] if
|
||||
]
|
||||
[ [ 2 fixnum* ] when 3 ]
|
||||
[ [ 2 fixnum+ ] when 3 ]
|
||||
[ [ 2 fixnum- ] when 3 ]
|
||||
[ 10000 [ ] times ]
|
||||
} [
|
||||
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
|
||||
] each
|
||||
|
|
@ -1,29 +1,30 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences compiler.cfg.rpo
|
||||
compiler.cfg.instructions
|
||||
USING: kernel sequences accessors combinators namespaces
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.useless-blocks
|
||||
compiler.cfg.height
|
||||
compiler.cfg.stack-analysis
|
||||
compiler.cfg.alias-analysis
|
||||
compiler.cfg.value-numbering
|
||||
compiler.cfg.dead-code
|
||||
compiler.cfg.write-barrier ;
|
||||
compiler.cfg.dce
|
||||
compiler.cfg.write-barrier
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.phi-elimination ;
|
||||
IN: compiler.cfg.optimizer
|
||||
|
||||
: trivial? ( insns -- ? )
|
||||
dup length 2 = [ first ##call? ] [ drop f ] if ;
|
||||
|
||||
: optimize-cfg ( cfg -- cfg' )
|
||||
[
|
||||
compute-predecessors
|
||||
delete-useless-blocks
|
||||
delete-useless-conditionals
|
||||
[
|
||||
dup trivial? [
|
||||
normalize-height
|
||||
stack-analysis
|
||||
compute-liveness
|
||||
alias-analysis
|
||||
value-numbering
|
||||
eliminate-dead-code
|
||||
eliminate-write-barriers
|
||||
] unless
|
||||
] change-basic-blocks ;
|
||||
eliminate-phis
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors compiler.cfg compiler.cfg.instructions
|
||||
compiler.cfg.rpo fry kernel sequences ;
|
||||
IN: compiler.cfg.phi-elimination
|
||||
|
||||
: insert-copy ( predecessor input output -- )
|
||||
'[ _ _ swap ##copy ] add-instructions ;
|
||||
|
||||
: eliminate-phi ( bb ##phi -- )
|
||||
[ predecessors>> ] [ [ inputs>> ] [ dst>> ] bi ] bi*
|
||||
'[ _ insert-copy ] 2each ;
|
||||
|
||||
: eliminate-phi-step ( bb -- )
|
||||
dup [
|
||||
[ ##phi? ] partition
|
||||
[ [ eliminate-phi ] with each ] dip
|
||||
] change-instructions drop ;
|
||||
|
||||
: eliminate-phis ( cfg -- cfg' )
|
||||
dup [ eliminate-phi-step ] each-basic-block ;
|
||||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.predecessors
|
||||
|
||||
: (compute-predecessors) ( bb -- )
|
||||
: predecessors-step ( bb -- )
|
||||
dup successors>> [ predecessors>> push ] with each ;
|
||||
|
||||
: compute-predecessors ( cfg -- cfg' )
|
||||
dup [ (compute-predecessors) ] each-basic-block ;
|
||||
dup [ predecessors-step ] each-basic-block ;
|
||||
|
|
|
|||
|
|
@ -1,35 +1,35 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors namespaces make math sequences sets
|
||||
assocs fry compiler.cfg.instructions ;
|
||||
assocs fry compiler.cfg compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.rpo
|
||||
|
||||
SYMBOL: visited
|
||||
|
||||
: post-order-traversal ( bb -- )
|
||||
dup id>> visited get key? [ drop ] [
|
||||
dup id>> visited get conjoin
|
||||
dup visited get key? [ drop ] [
|
||||
dup visited get conjoin
|
||||
[
|
||||
successors>> <reversed>
|
||||
[ post-order-traversal ] each
|
||||
] [ , ] bi
|
||||
] if ;
|
||||
|
||||
: post-order ( bb -- blocks )
|
||||
[ post-order-traversal ] { } make ;
|
||||
|
||||
: number-blocks ( blocks -- )
|
||||
[ >>number drop ] each-index ;
|
||||
dup length iota <reversed>
|
||||
[ >>number drop ] 2each ;
|
||||
|
||||
: reverse-post-order ( bb -- blocks )
|
||||
H{ } clone visited [
|
||||
post-order <reversed> dup number-blocks
|
||||
] with-variable ; inline
|
||||
: post-order ( cfg -- blocks )
|
||||
dup post-order>> [ ] [
|
||||
[
|
||||
H{ } clone visited set
|
||||
dup entry>> post-order-traversal
|
||||
] { } make dup number-blocks
|
||||
>>post-order post-order>>
|
||||
] ?if ;
|
||||
|
||||
: reverse-post-order ( cfg -- blocks )
|
||||
post-order <reversed> ; inline
|
||||
|
||||
: each-basic-block ( cfg quot -- )
|
||||
[ entry>> reverse-post-order ] dip each ; inline
|
||||
|
||||
: change-basic-blocks ( cfg quot -- cfg' )
|
||||
[ '[ _ change-instructions drop ] each-basic-block ]
|
||||
[ drop ]
|
||||
2bi ; inline
|
||||
[ reverse-post-order ] dip each ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,113 @@
|
|||
USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
|
||||
compiler.cfg.predecessors compiler.cfg.stack-analysis
|
||||
compiler.cfg.instructions sequences kernel tools.test accessors
|
||||
sequences.private alien math combinators.private compiler.cfg
|
||||
compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
|
||||
compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
|
||||
sets ;
|
||||
IN: compiler.cfg.stack-analysis.tests
|
||||
|
||||
! Fundamental invariant: a basic block should not load or store a value more than once
|
||||
: check-for-redundant-ops ( cfg -- )
|
||||
[
|
||||
instructions>>
|
||||
[
|
||||
[ ##peek? ] filter [ loc>> ] map duplicates empty?
|
||||
[ "Redundant peeks" throw ] unless
|
||||
] [
|
||||
[ ##replace? ] filter [ loc>> ] map duplicates empty?
|
||||
[ "Redundant replaces" throw ] unless
|
||||
] bi
|
||||
] each-basic-block ;
|
||||
|
||||
: test-stack-analysis ( quot -- cfg )
|
||||
dup cfg? [ test-cfg first ] unless
|
||||
compute-predecessors
|
||||
delete-useless-blocks
|
||||
delete-useless-conditionals
|
||||
normalize-height
|
||||
stack-analysis
|
||||
dup check-cfg
|
||||
dup check-for-redundant-ops ;
|
||||
|
||||
: linearize ( cfg -- mr )
|
||||
flatten-cfg instructions>> ;
|
||||
|
||||
[ ] [ [ ] test-stack-analysis drop ] unit-test
|
||||
|
||||
! Only peek once
|
||||
[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
|
||||
|
||||
! Redundant replace is redundant
|
||||
[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
|
||||
[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
|
||||
|
||||
! Replace required here
|
||||
[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
|
||||
[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
|
||||
|
||||
! Only one replace, at the end
|
||||
[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
|
||||
|
||||
! Do we support the full language?
|
||||
[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test
|
||||
[ ] [
|
||||
[ "int" { "int" "int" } "cdecl" [ + ] alien-callback ]
|
||||
test-cfg second test-stack-analysis drop
|
||||
] unit-test
|
||||
|
||||
! Test loops
|
||||
[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test
|
||||
|
||||
! Make sure that peeks are inserted in the right place
|
||||
[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
|
||||
|
||||
! This should be a total no-op
|
||||
[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
|
||||
|
||||
! Don't insert inc-d/inc-r; that's wrong!
|
||||
[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
|
||||
|
||||
! Bug in height tracking
|
||||
[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test
|
||||
|
||||
! Bugs with code that throws
|
||||
[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test
|
||||
|
||||
! Make sure the replace stores a value with the right height
|
||||
[ ] [
|
||||
[ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize
|
||||
[ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi
|
||||
] unit-test
|
||||
|
||||
! translate-loc was the wrong way round
|
||||
[ ] [
|
||||
[ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize
|
||||
[ [ ##load-immediate? ] count 2 assert= ]
|
||||
[ [ ##peek? ] count 1 assert= ]
|
||||
[ [ ##replace? ] count 3 assert= ]
|
||||
tri
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize
|
||||
[ [ ##load-immediate? ] count 2 assert= ]
|
||||
[ [ ##peek? ] count 1 assert= ]
|
||||
[ [ ##replace? ] count 1 assert= ]
|
||||
tri
|
||||
] unit-test
|
||||
|
||||
! Sync before a back-edge, not after
|
||||
! ##peeks should be inserted before a ##loop-entry
|
||||
! Don't optimize out the constants
|
||||
[ 1 t ] [
|
||||
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
|
||||
[ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,295 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces math sequences fry grouping
|
||||
sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use
|
||||
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
|
||||
compiler.cfg.hats compiler.cfg ;
|
||||
IN: compiler.cfg.stack-analysis
|
||||
|
||||
! Convert stack operations to register operations
|
||||
|
||||
! If 'poisoned' is set, disregard height information. This is set if we don't have
|
||||
! height change information for an instruction.
|
||||
TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height poisoned? ;
|
||||
|
||||
: <state> ( -- state )
|
||||
state new
|
||||
H{ } clone >>locs>vregs
|
||||
H{ } clone >>actual-locs>vregs
|
||||
H{ } clone >>changed-locs
|
||||
0 >>ds-height
|
||||
0 >>rs-height ;
|
||||
|
||||
M: state clone
|
||||
call-next-method
|
||||
[ clone ] change-locs>vregs
|
||||
[ clone ] change-actual-locs>vregs
|
||||
[ clone ] change-changed-locs ;
|
||||
|
||||
: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
|
||||
|
||||
: record-peek ( dst loc -- )
|
||||
state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
|
||||
|
||||
: changed-loc ( loc -- )
|
||||
state get changed-locs>> conjoin ;
|
||||
|
||||
: record-replace ( src loc -- )
|
||||
dup changed-loc state get locs>vregs>> set-at ;
|
||||
|
||||
GENERIC: height-for ( loc -- n )
|
||||
|
||||
M: ds-loc height-for drop state get ds-height>> ;
|
||||
M: rs-loc height-for drop state get rs-height>> ;
|
||||
|
||||
: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
|
||||
|
||||
GENERIC: translate-loc ( loc -- loc' )
|
||||
|
||||
M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
|
||||
M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
|
||||
|
||||
GENERIC: untranslate-loc ( loc -- loc' )
|
||||
|
||||
M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
|
||||
M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
|
||||
|
||||
: redundant-replace? ( vreg loc -- ? )
|
||||
dup untranslate-loc n>> 0 <
|
||||
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
|
||||
|
||||
: save-changed-locs ( state -- )
|
||||
[ changed-locs>> ] [ locs>vregs>> ] bi '[
|
||||
_ at swap 2dup redundant-replace?
|
||||
[ 2drop ] [ untranslate-loc ##replace ] if
|
||||
] assoc-each ;
|
||||
|
||||
: clear-state ( state -- )
|
||||
[ locs>vregs>> clear-assoc ]
|
||||
[ actual-locs>vregs>> clear-assoc ]
|
||||
[ changed-locs>> clear-assoc ]
|
||||
tri ;
|
||||
|
||||
ERROR: poisoned-state state ;
|
||||
|
||||
: sync-state ( -- )
|
||||
state get {
|
||||
[ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
|
||||
[ save-changed-locs ]
|
||||
[ clear-state ]
|
||||
} cleave ;
|
||||
|
||||
: poison-state ( -- ) state get t >>poisoned? drop ;
|
||||
|
||||
! Abstract interpretation
|
||||
GENERIC: visit ( insn -- )
|
||||
|
||||
! Instructions which don't have any effect on the stack
|
||||
UNION: neutral-insn
|
||||
##flushable
|
||||
##effect ;
|
||||
|
||||
M: neutral-insn visit , ;
|
||||
|
||||
UNION: sync-if-back-edge
|
||||
##branch
|
||||
##conditional-branch
|
||||
##compare-imm-branch
|
||||
##dispatch
|
||||
##loop-entry ;
|
||||
|
||||
SYMBOL: local-only?
|
||||
|
||||
t local-only? set-global
|
||||
|
||||
: back-edge? ( from to -- ? )
|
||||
[ number>> ] bi@ > ;
|
||||
|
||||
: sync-state? ( -- ? )
|
||||
basic-block get successors>>
|
||||
[ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
|
||||
local-only? get or ;
|
||||
|
||||
M: sync-if-back-edge visit
|
||||
sync-state? [ sync-state ] when , ;
|
||||
|
||||
: adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
|
||||
|
||||
M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
|
||||
|
||||
: adjust-r ( n -- ) state get [ + ] change-rs-height drop ;
|
||||
|
||||
M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
|
||||
|
||||
: eliminate-peek ( dst src -- )
|
||||
! the requested stack location is already in 'src'
|
||||
[ ##copy ] [ swap copies get set-at ] 2bi ;
|
||||
|
||||
M: ##peek visit
|
||||
dup
|
||||
[ dst>> ] [ loc>> translate-loc ] bi
|
||||
dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
|
||||
|
||||
M: ##replace visit
|
||||
[ src>> resolve ] [ loc>> translate-loc ] bi
|
||||
record-replace ;
|
||||
|
||||
M: ##copy visit
|
||||
[ call-next-method ] [ record-copy ] bi ;
|
||||
|
||||
M: ##call visit
|
||||
[ call-next-method ] [ height>> adjust-d ] bi ;
|
||||
|
||||
! Instructions that poison the stack state
|
||||
UNION: poison-insn
|
||||
##jump
|
||||
##return
|
||||
##callback-return
|
||||
##fixnum-mul-tail
|
||||
##fixnum-add-tail
|
||||
##fixnum-sub-tail ;
|
||||
|
||||
M: poison-insn visit call-next-method poison-state ;
|
||||
|
||||
! Instructions that kill all live vregs
|
||||
UNION: kill-vreg-insn
|
||||
poison-insn
|
||||
##stack-frame
|
||||
##call
|
||||
##prologue
|
||||
##epilogue
|
||||
##fixnum-mul
|
||||
##fixnum-add
|
||||
##fixnum-sub
|
||||
##alien-invoke
|
||||
##alien-indirect ;
|
||||
|
||||
M: kill-vreg-insn visit sync-state , ;
|
||||
|
||||
: visit-alien-node ( node -- )
|
||||
params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
|
||||
|
||||
M: ##alien-invoke visit
|
||||
[ call-next-method ] [ visit-alien-node ] bi ;
|
||||
|
||||
M: ##alien-indirect visit
|
||||
[ call-next-method ] [ visit-alien-node ] bi ;
|
||||
|
||||
M: ##alien-callback visit , ;
|
||||
|
||||
! Maps basic-blocks to states
|
||||
SYMBOLS: state-in state-out ;
|
||||
|
||||
: initial-state ( bb states -- state ) 2drop <state> ;
|
||||
|
||||
: single-predecessor ( bb states -- state ) nip first clone ;
|
||||
|
||||
ERROR: must-equal-failed seq ;
|
||||
|
||||
: must-equal ( seq -- elt )
|
||||
dup all-equal? [ first ] [ must-equal-failed ] if ;
|
||||
|
||||
: merge-heights ( state predecessors states -- state )
|
||||
nip
|
||||
[ [ ds-height>> ] map must-equal >>ds-height ]
|
||||
[ [ rs-height>> ] map must-equal >>rs-height ] bi ;
|
||||
|
||||
: insert-peek ( predecessor loc -- vreg )
|
||||
! XXX critical edges
|
||||
'[ _ ^^peek ] add-instructions ;
|
||||
|
||||
: merge-loc ( predecessors locs>vregs loc -- vreg )
|
||||
! Insert a ##phi in the current block where the input
|
||||
! is the vreg storing loc from each predecessor block
|
||||
[ '[ [ _ ] dip at ] map ] keep
|
||||
'[ [ ] [ _ insert-peek ] ?if ] 2map
|
||||
dup all-equal? [ first ] [ ^^phi ] if ;
|
||||
|
||||
: (merge-locs) ( predecessors assocs -- assoc )
|
||||
dup [ keys ] map concat prune
|
||||
[ [ 2nip ] [ merge-loc ] 3bi ] with with
|
||||
H{ } map>assoc ;
|
||||
|
||||
: merge-locs ( state predecessors states -- state )
|
||||
[ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
|
||||
|
||||
: merge-loc' ( locs>vregs loc -- vreg )
|
||||
! Insert a ##phi in the current block where the input
|
||||
! is the vreg storing loc from each predecessor block
|
||||
'[ [ _ ] dip at ] map
|
||||
dup all-equal? [ first ] [ drop f ] if ;
|
||||
|
||||
: merge-actual-locs ( state predecessors states -- state )
|
||||
nip
|
||||
[ actual-locs>vregs>> ] map
|
||||
dup [ keys ] map concat prune
|
||||
[ [ nip ] [ merge-loc' ] 2bi ] with
|
||||
H{ } map>assoc
|
||||
[ nip ] assoc-filter
|
||||
>>actual-locs>vregs ;
|
||||
|
||||
: merge-changed-locs ( state predecessors states -- state )
|
||||
nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
|
||||
|
||||
ERROR: cannot-merge-poisoned states ;
|
||||
|
||||
: multiple-predecessors ( bb states -- state )
|
||||
dup [ not ] any? [
|
||||
[ <state> ] 2dip
|
||||
sift merge-heights
|
||||
] [
|
||||
dup [ poisoned?>> ] any? [
|
||||
cannot-merge-poisoned
|
||||
] [
|
||||
[ state new ] 2dip
|
||||
[ predecessors>> ] dip
|
||||
{
|
||||
[ merge-locs ]
|
||||
[ merge-actual-locs ]
|
||||
[ merge-heights ]
|
||||
[ merge-changed-locs ]
|
||||
} 2cleave
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: merge-states ( bb states -- state )
|
||||
! If any states are poisoned, save all registers
|
||||
! to the stack in each branch
|
||||
dup length {
|
||||
{ 0 [ initial-state ] }
|
||||
{ 1 [ single-predecessor ] }
|
||||
[ drop multiple-predecessors ]
|
||||
} case ;
|
||||
|
||||
: block-in-state ( bb -- states )
|
||||
dup predecessors>> state-out get '[ _ at ] map merge-states ;
|
||||
|
||||
: set-block-in-state ( state bb -- )
|
||||
[ clone ] dip state-in get set-at ;
|
||||
|
||||
: set-block-out-state ( state bb -- )
|
||||
[ clone ] dip state-out get set-at ;
|
||||
|
||||
: visit-block ( bb -- )
|
||||
! block-in-state may add phi nodes at the start of the basic block
|
||||
! so we wrap the whole thing with a 'make'
|
||||
[
|
||||
dup basic-block set
|
||||
dup block-in-state
|
||||
[ swap set-block-in-state ] [
|
||||
state [
|
||||
[ instructions>> [ visit ] each ]
|
||||
[ [ state get ] dip set-block-out-state ]
|
||||
[ ]
|
||||
tri
|
||||
] with-variable
|
||||
] 2bi
|
||||
] V{ } make >>instructions drop ;
|
||||
|
||||
: stack-analysis ( cfg -- cfg' )
|
||||
[
|
||||
H{ } clone copies set
|
||||
H{ } clone state-in set
|
||||
H{ } clone state-out set
|
||||
dup [ visit-block ] each-basic-block
|
||||
] with-scope ;
|
||||
|
|
@ -32,8 +32,8 @@ M: insn compute-stack-frame*
|
|||
frame-required? on
|
||||
] when ;
|
||||
|
||||
\ _gc t frame-required? set-word-prop
|
||||
\ _spill t frame-required? set-word-prop
|
||||
\ ##gc t frame-required? set-word-prop
|
||||
\ ##fixnum-add t frame-required? set-word-prop
|
||||
\ ##fixnum-sub t frame-required? set-word-prop
|
||||
\ ##fixnum-mul t frame-required? set-word-prop
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel sequences compiler.utilities
|
||||
compiler.cfg.instructions cpu.architecture ;
|
||||
USING: accessors arrays kernel sequences make compiler.cfg.instructions
|
||||
compiler.cfg.rpo cpu.architecture ;
|
||||
IN: compiler.cfg.two-operand
|
||||
|
||||
! On x86, instructions take the form x = x op y
|
||||
|
|
@ -11,26 +11,26 @@ IN: compiler.cfg.two-operand
|
|||
! has a LEA instruction which is effectively a three-operand
|
||||
! addition
|
||||
|
||||
: make-copy ( dst src -- insn ) f \ ##copy boa ; inline
|
||||
: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline
|
||||
|
||||
: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline
|
||||
: make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline
|
||||
|
||||
: convert-two-operand/integer ( insn -- insns )
|
||||
[ [ dst>> ] [ src1>> ] bi make-copy ]
|
||||
[ dup dst>> >>src1 ]
|
||||
bi 2array ; inline
|
||||
: convert-two-operand/integer ( insn -- )
|
||||
[ [ dst>> ] [ src1>> ] bi ##copy ]
|
||||
[ dup dst>> >>src1 , ]
|
||||
bi ; inline
|
||||
|
||||
: convert-two-operand/float ( insn -- insns )
|
||||
[ [ dst>> ] [ src1>> ] bi make-copy/float ]
|
||||
[ dup dst>> >>src1 ]
|
||||
bi 2array ; inline
|
||||
: convert-two-operand/float ( insn -- )
|
||||
[ [ dst>> ] [ src1>> ] bi ##copy-float ]
|
||||
[ dup dst>> >>src1 , ]
|
||||
bi ; inline
|
||||
|
||||
GENERIC: convert-two-operand* ( insn -- insns )
|
||||
GENERIC: convert-two-operand* ( insn -- )
|
||||
|
||||
M: ##not convert-two-operand*
|
||||
[ [ dst>> ] [ src>> ] bi make-copy ]
|
||||
[ dup dst>> >>src ]
|
||||
bi 2array ;
|
||||
[ [ dst>> ] [ src>> ] bi ##copy ]
|
||||
[ dup dst>> >>src , ]
|
||||
bi ;
|
||||
|
||||
M: ##sub convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##mul convert-two-operand* convert-two-operand/integer ;
|
||||
|
|
@ -50,11 +50,13 @@ M: ##sub-float convert-two-operand* convert-two-operand/float ;
|
|||
M: ##mul-float convert-two-operand* convert-two-operand/float ;
|
||||
M: ##div-float convert-two-operand* convert-two-operand/float ;
|
||||
|
||||
M: insn convert-two-operand* ;
|
||||
M: insn convert-two-operand* , ;
|
||||
|
||||
: convert-two-operand ( mr -- mr' )
|
||||
[
|
||||
: convert-two-operand ( cfg -- cfg' )
|
||||
two-operand? [
|
||||
[ convert-two-operand* ] map-flat
|
||||
] when
|
||||
] change-instructions ;
|
||||
dup [
|
||||
[
|
||||
[ [ convert-two-operand* ] each ] V{ } make
|
||||
] change-instructions drop
|
||||
] each-basic-block
|
||||
] when ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
IN: compiler.cfg.useless-blocks.tests
|
||||
USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
|
||||
compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
|
||||
|
||||
{
|
||||
[ [ drop 1 ] when ]
|
||||
[ [ drop 1 ] unless ]
|
||||
} [
|
||||
[ [ ] ] dip
|
||||
'[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
|
||||
] each
|
||||
|
|
@ -1,10 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences combinators classes vectors
|
||||
compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
|
||||
USING: kernel accessors sequences combinators combinators.short-circuit
|
||||
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.useless-blocks
|
||||
|
||||
: update-predecessor-for-delete ( bb -- )
|
||||
! We have to replace occurrences of bb with bb's successor
|
||||
! in bb's predecessor's list of successors.
|
||||
dup predecessors>> first [
|
||||
[
|
||||
2dup eq? [ drop successors>> first ] [ nip ] if
|
||||
|
|
@ -12,9 +14,13 @@ IN: compiler.cfg.useless-blocks
|
|||
] change-successors drop ;
|
||||
|
||||
: update-successor-for-delete ( bb -- )
|
||||
[ predecessors>> first ]
|
||||
[ successors>> first predecessors>> ]
|
||||
bi set-first ;
|
||||
! We have to replace occurrences of bb with bb's predecessor
|
||||
! in bb's sucessor's list of predecessors.
|
||||
dup successors>> first [
|
||||
[
|
||||
2dup eq? [ drop predecessors>> first ] [ nip ] if
|
||||
] with map
|
||||
] change-predecessors drop ;
|
||||
|
||||
: delete-basic-block ( bb -- )
|
||||
[ update-predecessor-for-delete ]
|
||||
|
|
@ -23,21 +29,21 @@ IN: compiler.cfg.useless-blocks
|
|||
|
||||
: delete-basic-block? ( bb -- ? )
|
||||
{
|
||||
{ [ dup instructions>> length 1 = not ] [ f ] }
|
||||
{ [ dup predecessors>> length 1 = not ] [ f ] }
|
||||
{ [ dup successors>> length 1 = not ] [ f ] }
|
||||
{ [ dup instructions>> first ##branch? not ] [ f ] }
|
||||
[ t ]
|
||||
} cond nip ;
|
||||
[ instructions>> length 1 = ]
|
||||
[ predecessors>> length 1 = ]
|
||||
[ successors>> length 1 = ]
|
||||
[ instructions>> first ##branch? ]
|
||||
} 1&& ;
|
||||
|
||||
: delete-useless-blocks ( cfg -- cfg' )
|
||||
dup [
|
||||
dup delete-basic-block? [ delete-basic-block ] [ drop ] if
|
||||
] each-basic-block ;
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
|
||||
: delete-conditional? ( bb -- ? )
|
||||
dup instructions>> [ drop f ] [
|
||||
peek class {
|
||||
last class {
|
||||
##compare-branch
|
||||
##compare-imm-branch
|
||||
##compare-float-branch
|
||||
|
|
@ -46,10 +52,11 @@ IN: compiler.cfg.useless-blocks
|
|||
|
||||
: delete-conditional ( bb -- )
|
||||
dup successors>> first 1vector >>successors
|
||||
[ but-last f \ ##branch boa suffix ] change-instructions
|
||||
[ but-last \ ##branch new-insn suffix ] change-instructions
|
||||
drop ;
|
||||
|
||||
: delete-useless-conditionals ( cfg -- cfg' )
|
||||
dup [
|
||||
dup delete-conditional? [ delete-conditional ] [ drop ] if
|
||||
] each-basic-block ;
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
|
|
|
|||
|
|
@ -35,5 +35,8 @@ IN: compiler.cfg.utilities
|
|||
|
||||
: stop-iterating ( -- next ) end-basic-block f ;
|
||||
|
||||
: call-height ( ##call -- n )
|
||||
[ out-d>> length ] [ in-d>> length ] bi - ;
|
||||
|
||||
: emit-primitive ( node -- )
|
||||
word>> ##call ##branch begin-basic-block ;
|
||||
[ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
|
||||
|
|
|
|||
|
|
@ -22,17 +22,17 @@ M: constant-expr equal?
|
|||
and
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
SYMBOL: input-expr-counter
|
||||
|
||||
: next-input-expr ( -- n )
|
||||
input-expr-counter [ dup 1 + ] change ;
|
||||
|
||||
! Expressions whose values are inputs to the basic block. We
|
||||
! can eliminate a second computation having the same 'n' as
|
||||
! the first one; we can also eliminate input-exprs whose
|
||||
! result is not used.
|
||||
TUPLE: input-expr < expr n ;
|
||||
|
||||
SYMBOL: input-expr-counter
|
||||
|
||||
: next-input-expr ( class -- expr )
|
||||
input-expr-counter [ dup 1 + ] change input-expr boa ;
|
||||
|
||||
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
|
||||
|
||||
GENERIC: >expr ( insn -- expr )
|
||||
|
|
@ -80,7 +80,7 @@ M: ##compare-imm >expr compare-imm>expr ;
|
|||
|
||||
M: ##compare-float >expr compare>expr ;
|
||||
|
||||
M: ##flushable >expr class next-input-expr input-expr boa ;
|
||||
M: ##flushable >expr class next-input-expr ;
|
||||
|
||||
: init-expressions ( -- )
|
||||
0 input-expr-counter set ;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ GENERIC: rewrite ( insn -- insn' )
|
|||
|
||||
M: ##mul-imm rewrite
|
||||
dup src2>> dup power-of-2? [
|
||||
[ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa
|
||||
[ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
|
||||
dup number-values
|
||||
] [ drop ] if ;
|
||||
|
||||
|
|
@ -36,9 +36,9 @@ M: ##mul-imm rewrite
|
|||
|
||||
: rewrite-boolean-comparison ( expr -- insn )
|
||||
src1>> vreg>expr dup op>> {
|
||||
{ \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
|
||||
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
|
||||
{ \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
|
||||
{ \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
|
||||
{ \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
|
||||
{ \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
|
||||
} case ;
|
||||
|
||||
: tag-fixnum-expr? ( expr -- ? )
|
||||
|
|
@ -60,11 +60,11 @@ M: ##mul-imm rewrite
|
|||
GENERIC: rewrite-tagged-comparison ( insn -- insn' )
|
||||
|
||||
M: ##compare-imm-branch rewrite-tagged-comparison
|
||||
(rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
|
||||
(rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
|
||||
|
||||
M: ##compare-imm rewrite-tagged-comparison
|
||||
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
|
||||
i f \ ##compare-imm boa ;
|
||||
i \ ##compare-imm new-insn ;
|
||||
|
||||
M: ##compare-imm-branch rewrite
|
||||
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
|
||||
|
|
@ -79,7 +79,7 @@ M: ##compare-imm-branch rewrite
|
|||
[ dst>> ]
|
||||
[ src2>> ]
|
||||
[ src1>> vreg>vn vn>constant ] tri
|
||||
cc= f i \ ##compare-imm boa ;
|
||||
cc= i \ ##compare-imm new-insn ;
|
||||
|
||||
M: ##compare rewrite
|
||||
dup flip-comparison? [
|
||||
|
|
@ -96,9 +96,9 @@ M: ##compare rewrite
|
|||
|
||||
: rewrite-redundant-comparison ( insn -- insn' )
|
||||
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
|
||||
{ \ ##compare [ >compare-expr< i f \ ##compare boa ] }
|
||||
{ \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
|
||||
{ \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
|
||||
{ \ ##compare [ >compare-expr< i \ ##compare new-insn ] }
|
||||
{ \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] }
|
||||
{ \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] }
|
||||
} case
|
||||
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
|
||||
|
||||
|
|
@ -114,18 +114,4 @@ M: ##compare-imm rewrite
|
|||
] when
|
||||
] when ;
|
||||
|
||||
: dispatch-offset ( expr -- n )
|
||||
[ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
|
||||
\ ##sub-imm eq? [ neg ] when ;
|
||||
|
||||
: add-dispatch-offset? ( insn -- expr ? )
|
||||
src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
|
||||
|
||||
M: ##dispatch rewrite
|
||||
dup add-dispatch-offset? [
|
||||
[ clone ] dip
|
||||
[ in1>> vn>vreg >>src ]
|
||||
[ dispatch-offset '[ _ + ] change-offset ] bi
|
||||
] [ drop ] if ;
|
||||
|
||||
M: insn rewrite ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ IN: compiler.cfg.value-numbering.tests
|
|||
USING: compiler.cfg.value-numbering compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
|
||||
tools.test kernel math combinators.short-circuit accessors
|
||||
sequences ;
|
||||
sequences compiler.cfg vectors arrays ;
|
||||
|
||||
: trim-temps ( insns -- insns )
|
||||
[
|
||||
|
|
@ -13,6 +13,10 @@ sequences ;
|
|||
} 1|| [ f >>temp ] when
|
||||
] map ;
|
||||
|
||||
: test-value-numbering ( insns -- insns )
|
||||
{ } init-value-numbering
|
||||
value-numbering-step ;
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##peek f V int-regs 45 D 1 }
|
||||
|
|
@ -24,7 +28,7 @@ sequences ;
|
|||
T{ ##peek f V int-regs 45 D 1 }
|
||||
T{ ##copy f V int-regs 48 V int-regs 45 }
|
||||
T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
|
||||
} value-numbering
|
||||
} test-value-numbering
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -40,14 +44,14 @@ sequences ;
|
|||
T{ ##peek f V int-regs 3 D 0 }
|
||||
T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
|
||||
T{ ##replace f V int-regs 4 D 0 }
|
||||
} value-numbering
|
||||
} test-value-numbering
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
{
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
|
||||
} dup value-numbering =
|
||||
T{ ##dispatch f V int-regs 1 V int-regs 2 }
|
||||
} dup test-value-numbering =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
@ -60,7 +64,7 @@ sequences ;
|
|||
T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
|
||||
T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
|
||||
T{ ##replace f V int-regs 23 D 0 }
|
||||
} dup value-numbering =
|
||||
} dup test-value-numbering =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -76,7 +80,7 @@ sequences ;
|
|||
T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
|
||||
T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
|
||||
T{ ##replace f V int-regs 3 D 0 }
|
||||
} value-numbering
|
||||
} test-value-numbering
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -94,7 +98,7 @@ sequences ;
|
|||
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
|
||||
T{ ##replace f V int-regs 6 D 0 }
|
||||
} value-numbering trim-temps
|
||||
} test-value-numbering trim-temps
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -112,7 +116,7 @@ sequences ;
|
|||
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
|
||||
T{ ##replace f V int-regs 6 D 0 }
|
||||
} value-numbering trim-temps
|
||||
} test-value-numbering trim-temps
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -134,7 +138,7 @@ sequences ;
|
|||
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
|
||||
T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
|
||||
T{ ##replace f V int-regs 14 D 0 }
|
||||
} value-numbering trim-temps
|
||||
} test-value-numbering trim-temps
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -150,5 +154,18 @@ sequences ;
|
|||
T{ ##peek f V int-regs 30 D -2 }
|
||||
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
|
||||
T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
|
||||
} value-numbering trim-temps
|
||||
} test-value-numbering trim-temps
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##copy f V int-regs 48 V int-regs 45 }
|
||||
T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
|
||||
}
|
||||
] [
|
||||
{ V int-regs 45 } init-value-numbering
|
||||
{
|
||||
T{ ##copy f V int-regs 48 V int-regs 45 }
|
||||
T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -2,6 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs biassocs classes kernel math accessors
|
||||
sorting sets sequences
|
||||
compiler.cfg.local
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.value-numbering.graph
|
||||
compiler.cfg.value-numbering.expressions
|
||||
compiler.cfg.value-numbering.propagate
|
||||
|
|
@ -9,7 +11,16 @@ compiler.cfg.value-numbering.simplify
|
|||
compiler.cfg.value-numbering.rewrite ;
|
||||
IN: compiler.cfg.value-numbering
|
||||
|
||||
: value-numbering ( insns -- insns' )
|
||||
: number-input-values ( live-in -- )
|
||||
[ [ f next-input-expr simplify ] dip set-vn ] each ;
|
||||
|
||||
: init-value-numbering ( live-in -- )
|
||||
init-value-graph
|
||||
init-expressions
|
||||
number-input-values ;
|
||||
|
||||
: value-numbering-step ( insns -- insns' )
|
||||
[ [ number-values ] [ rewrite propagate ] bi ] map ;
|
||||
|
||||
: value-numbering ( cfg -- cfg' )
|
||||
[ init-value-numbering ] [ value-numbering-step ] local-optimization ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,11 @@
|
|||
USING: compiler.cfg.write-barrier compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
|
||||
arrays tools.test ;
|
||||
arrays tools.test vectors compiler.cfg kernel accessors ;
|
||||
IN: compiler.cfg.write-barrier.tests
|
||||
|
||||
: test-write-barrier ( insns -- insns )
|
||||
write-barriers-step ;
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##peek f V int-regs 4 D 0 f }
|
||||
|
|
@ -24,7 +27,7 @@ IN: compiler.cfg.write-barrier.tests
|
|||
T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
|
||||
T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
|
||||
T{ ##replace f V int-regs 7 D 0 }
|
||||
} eliminate-write-barriers
|
||||
} test-write-barrier
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -42,7 +45,7 @@ IN: compiler.cfg.write-barrier.tests
|
|||
T{ ##peek f V int-regs 6 D -2 }
|
||||
T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
|
||||
T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
|
||||
} eliminate-write-barriers
|
||||
} test-write-barrier
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -69,5 +72,5 @@ IN: compiler.cfg.write-barrier.tests
|
|||
T{ ##copy f V int-regs 29 V int-regs 19 }
|
||||
T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
|
||||
T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
|
||||
} eliminate-write-barriers
|
||||
} test-write-barrier
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors namespaces assocs sets sequences locals
|
||||
compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ;
|
||||
compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
|
||||
compiler.cfg.liveness compiler.cfg.local ;
|
||||
IN: compiler.cfg.write-barrier
|
||||
|
||||
! Eliminate redundant write barrier hits.
|
||||
|
|
@ -35,8 +36,11 @@ M: ##set-slot-imm eliminate-write-barrier
|
|||
|
||||
M: insn eliminate-write-barrier ;
|
||||
|
||||
: eliminate-write-barriers ( insns -- insns' )
|
||||
: write-barriers-step ( insns -- insns' )
|
||||
H{ } clone safe set
|
||||
H{ } clone mutated set
|
||||
H{ } clone copies set
|
||||
[ eliminate-write-barrier ] map sift ;
|
||||
|
||||
: eliminate-write-barriers ( cfg -- cfg' )
|
||||
[ drop ] [ write-barriers-step ] local-optimization ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
IN: compiler.codegen.tests
|
||||
USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
|
||||
compiler.constants ;
|
||||
|
||||
[ ] [ [ ] with-fixup drop ] unit-test
|
||||
[ ] [ [ \ + %call ] with-fixup drop ] unit-test
|
||||
|
||||
[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
|
||||
[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
|
||||
|
||||
! Error checking
|
||||
[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
|
||||
[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
|
||||
[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail
|
||||
|
|
@ -26,14 +26,6 @@ SYMBOL: registers
|
|||
: ?register ( obj -- operand )
|
||||
dup vreg? [ register ] when ;
|
||||
|
||||
: generate-insns ( insns -- code )
|
||||
[
|
||||
[
|
||||
dup regs>> registers set
|
||||
generate-insn
|
||||
] each
|
||||
] { } make fixup ;
|
||||
|
||||
TUPLE: asm label code calls ;
|
||||
|
||||
SYMBOL: calls
|
||||
|
|
@ -51,17 +43,22 @@ SYMBOL: labels
|
|||
|
||||
: init-generator ( word -- )
|
||||
H{ } clone labels set
|
||||
V{ } clone literal-table set
|
||||
V{ } clone calls set
|
||||
compiling-word set
|
||||
compiled-stack-traces? [ compiling-word get add-literal ] when ;
|
||||
|
||||
: generate-insns ( asm -- code )
|
||||
[
|
||||
[ word>> init-generator ]
|
||||
[
|
||||
instructions>>
|
||||
[ [ regs>> registers set ] [ generate-insn ] bi ] each
|
||||
] bi
|
||||
] with-fixup ;
|
||||
|
||||
: generate ( mr -- asm )
|
||||
[
|
||||
[ label>> ]
|
||||
[ word>> init-generator ]
|
||||
[ instructions>> generate-insns ] tri
|
||||
calls get
|
||||
[ label>> ] [ generate-insns ] bi calls get
|
||||
asm boa
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -92,10 +89,11 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
|
|||
|
||||
M: ##return generate-insn drop %return ;
|
||||
|
||||
M: ##dispatch-label generate-insn label>> %dispatch-label ;
|
||||
M: _dispatch generate-insn
|
||||
[ src>> register ] [ temp>> register ] bi %dispatch ;
|
||||
|
||||
M: ##dispatch generate-insn
|
||||
[ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
|
||||
M: _dispatch-label generate-insn
|
||||
label>> lookup-label %dispatch-label ;
|
||||
|
||||
: >slot< ( insn -- dst obj slot tag )
|
||||
{
|
||||
|
|
@ -236,7 +234,7 @@ M: ##write-barrier generate-insn
|
|||
[ table>> register ]
|
||||
tri %write-barrier ;
|
||||
|
||||
M: _gc generate-insn drop %gc ;
|
||||
M: ##gc generate-insn drop %gc ;
|
||||
|
||||
M: ##loop-entry generate-insn drop %loop-entry ;
|
||||
|
||||
|
|
@ -486,7 +484,7 @@ M: _epilogue generate-insn
|
|||
stack-frame>> total-size>> %epilogue ;
|
||||
|
||||
M: _label generate-insn
|
||||
id>> lookup-label , ;
|
||||
id>> lookup-label resolve-label ;
|
||||
|
||||
M: _branch generate-insn
|
||||
label>> lookup-label %jump-label ;
|
||||
|
|
|
|||
|
|
@ -4,48 +4,48 @@ USING: arrays byte-arrays byte-vectors generic assocs hashtables
|
|||
io.binary kernel kernel.private math namespaces make sequences
|
||||
words quotations strings alien.accessors alien.strings layouts
|
||||
system combinators math.bitwise math.order
|
||||
accessors growable cpu.architecture compiler.constants ;
|
||||
accessors growable compiler.constants ;
|
||||
IN: compiler.codegen.fixup
|
||||
|
||||
GENERIC: fixup* ( obj -- )
|
||||
! Literal table
|
||||
SYMBOL: literal-table
|
||||
|
||||
: add-literal ( obj -- ) literal-table get push ;
|
||||
|
||||
! Labels
|
||||
SYMBOL: label-table
|
||||
|
||||
TUPLE: label offset ;
|
||||
|
||||
: <label> ( -- label ) label new ;
|
||||
: define-label ( name -- ) <label> swap set ;
|
||||
|
||||
: compiled-offset ( -- n ) building get length ;
|
||||
|
||||
: resolve-label ( label/name -- )
|
||||
dup label? [ get ] unless
|
||||
compiled-offset >>offset drop ;
|
||||
|
||||
: offset-for-class ( class -- n )
|
||||
rc-absolute-cell = cell 4 ? compiled-offset swap - ;
|
||||
|
||||
TUPLE: label-fixup { label label } { class integer } { offset integer } ;
|
||||
|
||||
: label-fixup ( label class -- )
|
||||
dup offset-for-class \ label-fixup boa label-table get push ;
|
||||
|
||||
! Relocation table
|
||||
SYMBOL: relocation-table
|
||||
SYMBOL: label-table
|
||||
|
||||
M: label fixup* compiled-offset >>offset drop ;
|
||||
|
||||
TUPLE: label-fixup label class ;
|
||||
|
||||
: label-fixup ( label class -- ) \ label-fixup boa , ;
|
||||
|
||||
M: label-fixup fixup*
|
||||
dup class>> rc-absolute?
|
||||
[ "Absolute labels not supported" throw ] when
|
||||
[ class>> ] [ label>> ] bi compiled-offset 4 - swap
|
||||
3array label-table get push ;
|
||||
|
||||
TUPLE: rel-fixup class type ;
|
||||
|
||||
: rel-fixup ( class type -- ) \ rel-fixup boa , ;
|
||||
|
||||
: push-4 ( value vector -- )
|
||||
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
|
||||
swap set-alien-unsigned-4 ;
|
||||
|
||||
M: rel-fixup fixup*
|
||||
[ type>> ]
|
||||
[ class>> ]
|
||||
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
|
||||
{ 0 24 28 } bitfield
|
||||
relocation-table get push-4 ;
|
||||
: add-relocation-entry ( type class offset -- )
|
||||
{ 0 24 28 } bitfield relocation-table get push-4 ;
|
||||
|
||||
M: integer fixup* , ;
|
||||
|
||||
SYMBOL: literal-table
|
||||
|
||||
: add-literal ( obj -- ) literal-table get push ;
|
||||
: rel-fixup ( class type -- )
|
||||
swap dup offset-for-class add-relocation-entry ;
|
||||
|
||||
: add-dlsym-literals ( symbol dll -- )
|
||||
[ string>symbol add-literal ] [ add-literal ] bi* ;
|
||||
|
|
@ -74,22 +74,34 @@ SYMBOL: literal-table
|
|||
: rel-here ( offset class -- )
|
||||
[ add-literal ] dip rt-here rel-fixup ;
|
||||
|
||||
! And the rest
|
||||
: resolve-offset ( label-fixup -- offset )
|
||||
label>> offset>> [ "Unresolved label" throw ] unless* ;
|
||||
|
||||
: resolve-absolute-label ( label-fixup -- )
|
||||
dup resolve-offset neg add-literal
|
||||
[ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
|
||||
|
||||
: resolve-relative-label ( label-fixup -- label )
|
||||
[ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
|
||||
|
||||
: resolve-labels ( label-fixups -- labels' )
|
||||
[ class>> rc-absolute? ] partition
|
||||
[ [ resolve-absolute-label ] each ]
|
||||
[ [ resolve-relative-label ] map concat ]
|
||||
bi* ;
|
||||
|
||||
: init-fixup ( -- )
|
||||
BV{ } clone relocation-table set
|
||||
V{ } clone label-table set ;
|
||||
V{ } clone literal-table set
|
||||
V{ } clone label-table set
|
||||
BV{ } clone relocation-table set ;
|
||||
|
||||
: resolve-labels ( labels -- labels' )
|
||||
[
|
||||
first3 offset>>
|
||||
[ "Unresolved label" throw ] unless*
|
||||
3array
|
||||
] map concat ;
|
||||
|
||||
: fixup ( fixup-directives -- code )
|
||||
: with-fixup ( quot -- code )
|
||||
[
|
||||
init-fixup
|
||||
[ fixup* ] each
|
||||
call
|
||||
label-table [ resolve-labels ] change
|
||||
literal-table get >array
|
||||
relocation-table get >byte-array
|
||||
label-table get resolve-labels
|
||||
] B{ } make 4array ;
|
||||
label-table get
|
||||
] B{ } make 4array ; inline
|
||||
|
|
|
|||
|
|
@ -2,14 +2,21 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces arrays sequences io words fry
|
||||
continuations vocabs assocs dlists definitions math graphs generic
|
||||
generic.single combinators deques search-deques macros io
|
||||
source-files.errors stack-checker stack-checker.state
|
||||
stack-checker.inlining stack-checker.errors combinators.short-circuit
|
||||
compiler.errors compiler.units compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
||||
compiler.cfg.linearization compiler.cfg.two-operand
|
||||
compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
|
||||
compiler.utilities ;
|
||||
generic.single combinators deques search-deques macros
|
||||
source-files.errors combinators.short-circuit
|
||||
|
||||
stack-checker stack-checker.state stack-checker.inlining stack-checker.errors
|
||||
|
||||
compiler.errors compiler.units compiler.utilities
|
||||
|
||||
compiler.tree.builder
|
||||
compiler.tree.optimizer
|
||||
|
||||
compiler.cfg.builder
|
||||
compiler.cfg.optimizer
|
||||
compiler.cfg.mr
|
||||
|
||||
compiler.codegen ;
|
||||
IN: compiler
|
||||
|
||||
SYMBOL: compile-queue
|
||||
|
|
@ -89,11 +96,11 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
|
|||
: not-compiled-def ( word error -- def )
|
||||
'[ _ _ not-compiled ] [ ] like ;
|
||||
|
||||
: deoptimize* ( word -- * )
|
||||
dup def>> deoptimize-with ;
|
||||
|
||||
: ignore-error ( word error -- * )
|
||||
drop
|
||||
[ clear-compiler-error ]
|
||||
[ dup def>> deoptimize-with ]
|
||||
bi ;
|
||||
drop [ clear-compiler-error ] [ deoptimize* ] bi ;
|
||||
|
||||
: remember-error ( word error -- * )
|
||||
[ swap <compiler-error> compiler-error ]
|
||||
|
|
@ -117,13 +124,13 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
|
|||
: contains-breakpoints? ( -- ? )
|
||||
dependencies get keys [ "break?" word-prop ] any? ;
|
||||
|
||||
: frontend ( word -- nodes )
|
||||
: frontend ( word -- tree )
|
||||
#! If the word contains breakpoints, don't optimize it, since
|
||||
#! the walker does not support this.
|
||||
dup optimize? [
|
||||
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
|
||||
contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
|
||||
] [ dup def>> deoptimize-with ] if ;
|
||||
contains-breakpoints? [ nip deoptimize* ] [ drop ] if
|
||||
] [ deoptimize* ] if ;
|
||||
|
||||
: compile-dependency ( word -- )
|
||||
#! If a word calls an unoptimized word, try to compile the callee.
|
||||
|
|
@ -143,13 +150,10 @@ t compile-dependencies? set-global
|
|||
[ compile-dependencies ]
|
||||
bi ;
|
||||
|
||||
: backend ( nodes word -- )
|
||||
: backend ( tree word -- )
|
||||
build-cfg [
|
||||
optimize-cfg
|
||||
build-mr
|
||||
convert-two-operand
|
||||
linear-scan
|
||||
build-stack-frame
|
||||
generate
|
||||
save-asm
|
||||
] each ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
USING: alien alien.c-types alien.syntax compiler kernel
|
||||
namespaces namespaces tools.test sequences stack-checker
|
||||
stack-checker.errors words arrays parser quotations
|
||||
continuations effects namespaces.private io io.streams.string
|
||||
memory system threads tools.test math accessors combinators
|
||||
specialized-arrays.float alien.libraries io.pathnames
|
||||
USING: alien alien.c-types alien.syntax compiler kernel namespaces
|
||||
sequences stack-checker stack-checker.errors words arrays parser
|
||||
quotations continuations effects namespaces.private io
|
||||
io.streams.string memory system threads tools.test math accessors
|
||||
combinators specialized-arrays.float alien.libraries io.pathnames
|
||||
io.backend ;
|
||||
IN: compiler.tests.alien
|
||||
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue