Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
0c0f796267
|
|
@ -8,14 +8,6 @@ GENERIC: temp-vregs ( insn -- seq )
|
|||
GENERIC: uses-vregs ( insn -- seq )
|
||||
|
||||
M: ##flushable defs-vregs dst>> 1array ;
|
||||
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>> 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 ;
|
||||
|
|
|
|||
|
|
@ -242,11 +242,12 @@ SYMBOL: max-uses
|
|||
max-insns get [ 0 ] replicate taken set
|
||||
max-insns get [ dup ] H{ } map>assoc available set
|
||||
[
|
||||
live-interval new
|
||||
\ live-interval new
|
||||
swap int-regs swap vreg boa >>vreg
|
||||
max-uses get random 2 max [ not-taken ] replicate natural-sort
|
||||
[ >>uses ] [ first >>start ] bi
|
||||
dup uses>> last >>end
|
||||
dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
|
||||
] map
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -271,24 +272,6 @@ USING: math.private compiler.cfg.debugger ;
|
|||
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 }
|
||||
40
|
||||
array
|
||||
T{ vreg f int-regs 2 }
|
||||
f
|
||||
}
|
||||
}
|
||||
}
|
||||
} clone [ [ clone ] map ] change-instructions
|
||||
dup 1array (linear-scan) instructions>> first regs>> values all-equal?
|
||||
] unit-test
|
||||
|
||||
[ 0 1 ] [
|
||||
{
|
||||
T{ live-interval
|
||||
|
|
|
|||
|
|
@ -1,26 +1,56 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel assocs accessors sequences math fry
|
||||
USING: namespaces kernel assocs accessors sequences math math.order fry
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.def-use ;
|
||||
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
|
||||
IN: compiler.cfg.linear-scan.live-intervals
|
||||
|
||||
TUPLE: live-range from to ;
|
||||
|
||||
C: <live-range> live-range
|
||||
|
||||
TUPLE: live-interval
|
||||
vreg
|
||||
reg spill-to reload-from split-before split-after
|
||||
start end uses
|
||||
start end ranges uses
|
||||
copy-from ;
|
||||
|
||||
: add-use ( n live-interval -- )
|
||||
dup live-interval? [ "No def" throw ] unless
|
||||
[ (>>end) ] [ uses>> push ] 2bi ;
|
||||
ERROR: dead-value-error vreg ;
|
||||
|
||||
: <live-interval> ( start vreg -- live-interval )
|
||||
live-interval new
|
||||
: shorten-range ( n live-interval -- )
|
||||
dup ranges>> empty?
|
||||
[ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ;
|
||||
|
||||
: extend-range ( from to live-range -- )
|
||||
ranges>> last
|
||||
[ max ] change-to
|
||||
[ min ] change-from
|
||||
drop ;
|
||||
|
||||
: add-new-range ( from to live-interval -- )
|
||||
[ <live-range> ] dip ranges>> push ;
|
||||
|
||||
: extend-range? ( to live-interval -- ? )
|
||||
ranges>> [ drop f ] [ last from>> >= ] if-empty ;
|
||||
|
||||
: add-range ( from to live-interval -- )
|
||||
2dup extend-range?
|
||||
[ extend-range ] [ add-new-range ] if ;
|
||||
|
||||
: add-use ( n live-interval -- )
|
||||
uses>> push ;
|
||||
|
||||
: <live-interval> ( vreg -- live-interval )
|
||||
\ live-interval new
|
||||
V{ } clone >>uses
|
||||
swap >>vreg
|
||||
over >>start
|
||||
[ add-use ] keep ;
|
||||
V{ } clone >>ranges
|
||||
swap >>vreg ;
|
||||
|
||||
: block-from ( -- n )
|
||||
basic-block get instructions>> first insn#>> ;
|
||||
|
||||
: block-to ( -- n )
|
||||
basic-block get instructions>> last insn#>> ;
|
||||
|
||||
M: live-interval hashcode*
|
||||
nip [ start>> ] [ end>> 1000 * ] bi + ;
|
||||
|
|
@ -31,23 +61,31 @@ M: live-interval clone
|
|||
! Mapping from vreg to live-interval
|
||||
SYMBOL: live-intervals
|
||||
|
||||
: new-live-interval ( n vreg live-intervals -- )
|
||||
2dup key? [
|
||||
at add-use
|
||||
] [
|
||||
[ [ <live-interval> ] keep ] dip set-at
|
||||
] if ;
|
||||
: live-interval ( vreg live-intervals -- live-interval )
|
||||
[ <live-interval> ] cache ;
|
||||
|
||||
GENERIC: compute-live-intervals* ( insn -- )
|
||||
|
||||
M: insn compute-live-intervals* drop ;
|
||||
|
||||
: handle-output ( n vreg live-intervals -- )
|
||||
live-interval
|
||||
[ add-use ] [ shorten-range ] 2bi ;
|
||||
|
||||
: handle-input ( n vreg live-intervals -- )
|
||||
live-interval
|
||||
[ [ block-from ] 2dip add-range ] [ add-use ] 2bi ;
|
||||
|
||||
: handle-temp ( n vreg live-intervals -- )
|
||||
live-interval
|
||||
[ dupd add-range ] [ add-use ] 2bi ;
|
||||
|
||||
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 ]
|
||||
[ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
|
||||
[ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ]
|
||||
[ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
|
||||
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
|
||||
3tri ;
|
||||
|
||||
: record-copy ( insn -- )
|
||||
|
|
@ -59,8 +97,32 @@ M: ##copy compute-live-intervals*
|
|||
M: ##copy-float compute-live-intervals*
|
||||
[ call-next-method ] [ record-copy ] bi ;
|
||||
|
||||
: handle-live-out ( bb -- )
|
||||
live-out keys block-from block-to live-intervals get '[
|
||||
[ _ _ ] dip _ live-interval add-range
|
||||
] each ;
|
||||
|
||||
: compute-live-intervals-step ( bb -- )
|
||||
[ basic-block set ]
|
||||
[ handle-live-out ]
|
||||
[ instructions>> <reversed> [ compute-live-intervals* ] each ] tri ;
|
||||
|
||||
: compute-start/end ( live-interval -- )
|
||||
dup ranges>> [ first from>> ] [ last to>> ] bi
|
||||
[ >>start ] [ >>end ] bi* drop ;
|
||||
|
||||
: finish-live-intervals ( live-intervals -- )
|
||||
! Since live intervals are computed in a backward order, we have
|
||||
! to reverse some sequences, and compute the start and end.
|
||||
[
|
||||
[ ranges>> reverse-here ]
|
||||
[ uses>> reverse-here ]
|
||||
[ compute-start/end ]
|
||||
tri
|
||||
] each ;
|
||||
|
||||
: compute-live-intervals ( rpo -- live-intervals )
|
||||
H{ } clone [
|
||||
live-intervals set
|
||||
[ instructions>> [ compute-live-intervals* ] each ] each
|
||||
] keep values ;
|
||||
<reversed> [ compute-live-intervals-step ] each
|
||||
] keep values dup finish-live-intervals ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: generalizations accessors arrays compiler kernel kernel.private
|
|||
math hashtables.private math.private namespaces sequences tools.test
|
||||
namespaces.private slots.private sequences.private byte-arrays alien
|
||||
alien.accessors layouts words definitions compiler.units io
|
||||
combinators vectors grouping make ;
|
||||
combinators vectors grouping make alien.c-types ;
|
||||
QUALIFIED: namespaces.private
|
||||
IN: compiler.tests.codegen
|
||||
|
||||
|
|
@ -282,3 +282,10 @@ TUPLE: cucumber ;
|
|||
M: cucumber equal? "The cucumber has no equal" throw ;
|
||||
|
||||
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
|
||||
|
||||
[ 4294967295 B{ 255 255 255 255 } -1 ]
|
||||
[
|
||||
-1 <int> -1 <int>
|
||||
[ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
|
||||
compile-call
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays grouping sequences ;
|
||||
IN: compression.run-length
|
||||
|
||||
: run-length-uncompress8 ( byte-array -- byte-array' )
|
||||
2 group [ first2 <array> ] map concat ;
|
||||
|
|
@ -3,10 +3,11 @@
|
|||
USING: locals alien.c-types alien.syntax arrays kernel
|
||||
math namespaces sequences system layouts io vocabs.loader
|
||||
accessors init combinators command-line cpu.x86.assembler
|
||||
cpu.x86 cpu.architecture compiler compiler.units
|
||||
cpu.x86 cpu.architecture make compiler compiler.units
|
||||
compiler.constants compiler.alien compiler.codegen
|
||||
compiler.codegen.fixup compiler.cfg.instructions
|
||||
compiler.cfg.builder compiler.cfg.intrinsics make ;
|
||||
compiler.cfg.builder compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
! We implement the FFI for Linux, OS X and Windows all at once.
|
||||
|
|
|
|||
|
|
@ -327,17 +327,29 @@ M:: x86 %box-alien ( dst src temp -- )
|
|||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
: small-reg-4 ( reg -- reg' )
|
||||
: small-reg-8 ( reg -- reg' )
|
||||
H{
|
||||
{ EAX EAX }
|
||||
{ ECX ECX }
|
||||
{ EDX EDX }
|
||||
{ EBX EBX }
|
||||
{ ESP ESP }
|
||||
{ EBP EBP }
|
||||
{ ESI ESP }
|
||||
{ EDI EDI }
|
||||
{ EAX RAX }
|
||||
{ ECX RCX }
|
||||
{ EDX RDX }
|
||||
{ EBX RBX }
|
||||
{ ESP RSP }
|
||||
{ EBP RBP }
|
||||
{ ESI RSP }
|
||||
{ EDI RDI }
|
||||
|
||||
{ RAX RAX }
|
||||
{ RCX RCX }
|
||||
{ RDX RDX }
|
||||
{ RBX RBX }
|
||||
{ RSP RSP }
|
||||
{ RBP RBP }
|
||||
{ RSI RSP }
|
||||
{ RDI RDI }
|
||||
} at ; inline
|
||||
|
||||
: small-reg-4 ( reg -- reg' )
|
||||
small-reg-8 H{
|
||||
{ RAX EAX }
|
||||
{ RCX ECX }
|
||||
{ RDX EDX }
|
||||
|
|
@ -373,12 +385,21 @@ M:: x86 %box-alien ( dst src temp -- )
|
|||
{ 1 [ small-reg-1 ] }
|
||||
{ 2 [ small-reg-2 ] }
|
||||
{ 4 [ small-reg-4 ] }
|
||||
{ 8 [ small-reg-8 ] }
|
||||
} case ;
|
||||
|
||||
: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
|
||||
HOOK: small-regs cpu ( -- regs )
|
||||
|
||||
M: x86.32 small-regs { EAX ECX EDX EBX } ;
|
||||
M: x86.64 small-regs { RAX RCX RDX RBX } ;
|
||||
|
||||
HOOK: small-reg-native cpu ( reg -- reg' )
|
||||
|
||||
M: x86.32 small-reg-native small-reg-4 ;
|
||||
M: x86.64 small-reg-native small-reg-8 ;
|
||||
|
||||
: small-reg-that-isn't ( exclude -- reg' )
|
||||
small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ;
|
||||
small-regs swap [ small-reg-native ] map '[ _ memq? not ] find nip ;
|
||||
|
||||
: with-save/restore ( reg quot -- )
|
||||
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
|
||||
|
|
@ -388,7 +409,7 @@ M:: x86 %box-alien ( dst src temp -- )
|
|||
#! call the quot with that. Otherwise, we find a small
|
||||
#! register that is not in exclude, and call quot, saving
|
||||
#! and restoring the small register.
|
||||
dst small-reg-4 small-regs memq? [ dst quot call ] [
|
||||
dst small-reg-native small-regs memq? [ dst quot call ] [
|
||||
exclude small-reg-that-isn't
|
||||
[ quot call ] with-save/restore
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2007, 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types arrays byte-arrays columns
|
||||
combinators fry grouping io io.binary io.encodings.binary io.files
|
||||
kernel macros math math.bitwise math.functions namespaces sequences
|
||||
strings images endian summary locals images.loader ;
|
||||
combinators compression.run-length endian fry grouping images
|
||||
images.loader io io.binary io.encodings.binary io.files kernel
|
||||
locals macros math math.bitwise math.functions namespaces
|
||||
sequences strings summary ;
|
||||
IN: images.bitmap
|
||||
|
||||
: assert-sequence= ( a b -- )
|
||||
|
|
@ -21,7 +22,8 @@ TUPLE: bitmap-image < image ;
|
|||
TUPLE: loading-bitmap
|
||||
size reserved offset header-length width
|
||||
height planes bit-count compression size-image
|
||||
x-pels y-pels color-used color-important rgb-quads color-index ;
|
||||
x-pels y-pels color-used color-important color-palette color-index
|
||||
uncompressed-bytes ;
|
||||
|
||||
ERROR: bitmap-magic magic ;
|
||||
|
||||
|
|
@ -31,7 +33,7 @@ M: bitmap-magic summary
|
|||
<PRIVATE
|
||||
|
||||
: 8bit>buffer ( bitmap -- array )
|
||||
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
|
||||
[ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ]
|
||||
[ color-index>> >array ] bi [ swap nth ] with map concat ;
|
||||
|
||||
ERROR: bmp-not-supported n ;
|
||||
|
|
@ -39,7 +41,7 @@ ERROR: bmp-not-supported n ;
|
|||
: reverse-lines ( byte-array width -- byte-array )
|
||||
<sliced-groups> <reversed> concat ; inline
|
||||
|
||||
: raw-bitmap>seq ( loading-bitmap -- array )
|
||||
: bitmap>bytes ( loading-bitmap -- array )
|
||||
dup bit-count>>
|
||||
{
|
||||
{ 32 [ color-index>> ] }
|
||||
|
|
@ -48,6 +50,21 @@ ERROR: bmp-not-supported n ;
|
|||
[ bmp-not-supported ]
|
||||
} case >byte-array ;
|
||||
|
||||
ERROR: unsupported-bitmap-compression compression ;
|
||||
|
||||
: uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
|
||||
dup compression>> {
|
||||
{ 0 [ ] }
|
||||
{ 1 [ [ run-length-uncompress8 ] change-color-index ] }
|
||||
{ 2 [ "run-length encoding 4" unsupported-bitmap-compression ] }
|
||||
{ 3 [ "bitfields" unsupported-bitmap-compression ] }
|
||||
{ 4 [ "jpeg" unsupported-bitmap-compression ] }
|
||||
{ 5 [ "png" unsupported-bitmap-compression ] }
|
||||
} case ;
|
||||
|
||||
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
|
||||
uncompress-bitmap bitmap>bytes ;
|
||||
|
||||
: parse-file-header ( loading-bitmap -- loading-bitmap )
|
||||
2 read "BM" assert-sequence=
|
||||
read4 >>size
|
||||
|
|
@ -67,7 +84,7 @@ ERROR: bmp-not-supported n ;
|
|||
read4 >>color-used
|
||||
read4 >>color-important ;
|
||||
|
||||
: rgb-quads-length ( loading-bitmap -- n )
|
||||
: color-palette-length ( loading-bitmap -- n )
|
||||
[ offset>> 14 - ] [ header-length>> ] bi - ;
|
||||
|
||||
: color-index-length ( loading-bitmap -- n )
|
||||
|
|
@ -98,11 +115,11 @@ ERROR: bmp-not-supported n ;
|
|||
] when ;
|
||||
|
||||
: parse-bitmap ( loading-bitmap -- loading-bitmap )
|
||||
dup rgb-quads-length read >>rgb-quads
|
||||
dup color-palette-length read >>color-palette
|
||||
dup color-index-length read >>color-index
|
||||
fixup-color-index ;
|
||||
|
||||
: load-bitmap-data ( path -- loading-bitmap )
|
||||
: load-bitmap ( path -- loading-bitmap )
|
||||
binary [
|
||||
loading-bitmap new
|
||||
parse-file-header parse-bitmap-header parse-bitmap
|
||||
|
|
@ -120,14 +137,14 @@ ERROR: unknown-component-order bitmap ;
|
|||
|
||||
: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
|
||||
{
|
||||
[ raw-bitmap>seq >>bitmap ]
|
||||
[ loading-bitmap>bytes >>bitmap ]
|
||||
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
|
||||
[ height>> 0 < [ t >>upside-down? ] when ]
|
||||
[ bitmap>component-order >>component-order ]
|
||||
} cleave ;
|
||||
|
||||
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
|
||||
swap load-bitmap-data loading-bitmap>bitmap-image ;
|
||||
swap load-bitmap loading-bitmap>bitmap-image ;
|
||||
|
||||
"bmp" bitmap-image register-image-class
|
||||
|
||||
|
|
@ -185,7 +202,7 @@ PRIVATE>
|
|||
! color-important
|
||||
[ drop 0 write4 ]
|
||||
|
||||
! rgb-quads
|
||||
! color-palette
|
||||
[
|
||||
[ bitmap>color-index ]
|
||||
[ dim>> first 3 * ]
|
||||
|
|
|
|||
|
|
@ -1872,7 +1872,7 @@ GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint*
|
|||
GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ;
|
||||
|
||||
GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
|
||||
GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
|
||||
GL-FUNCTION: GLint glGetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
|
||||
|
||||
CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD
|
||||
CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0
|
||||
|
|
|
|||
|
|
@ -217,4 +217,3 @@ M: world check-world-pixel-format
|
|||
: with-world-pixel-format ( world quot -- )
|
||||
[ dup dup world-pixel-format-attributes <pixel-format> ]
|
||||
dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -206,8 +206,11 @@ PRIVATE>
|
|||
: open-world-window ( world -- )
|
||||
dup pref-dim >>dim dup relayout graft ;
|
||||
|
||||
: open-window* ( gadget title/attributes -- window )
|
||||
?attributes <world> [ open-world-window ] keep ;
|
||||
|
||||
: open-window ( gadget title/attributes -- )
|
||||
?attributes <world> open-world-window ;
|
||||
open-window* drop ;
|
||||
|
||||
: set-fullscreen ( gadget ? -- )
|
||||
[ find-world ] dip (set-fullscreen) ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,27 @@
|
|||
USING: accessors kernel ui ui.backend ui.gadgets
|
||||
ui.gadgets.worlds ui.pixel-formats ;
|
||||
IN: ui.gadgets.worlds.null
|
||||
|
||||
TUPLE: null-world < world ;
|
||||
M: null-world begin-world drop ;
|
||||
M: null-world end-world drop ;
|
||||
M: null-world draw-world* drop ;
|
||||
M: null-world resize-world drop ;
|
||||
M: null-world pref-dim* drop { 512 512 } ;
|
||||
|
||||
: null-window ( title -- world )
|
||||
<world-attributes>
|
||||
swap >>title
|
||||
null-world >>world-class
|
||||
{
|
||||
windowed
|
||||
double-buffered
|
||||
backing-store
|
||||
T{ depth-bits f 24 }
|
||||
} >>pixel-format-attributes
|
||||
f swap open-window* ;
|
||||
|
||||
: into-window ( world quot -- world )
|
||||
[ dup handle>> ] dip with-gl-context ; inline
|
||||
|
||||
|
||||
Loading…
Reference in New Issue