Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
a506ddbbfc
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: accessors calendar destructors kernel math math.order namespaces
|
||||
system threads ;
|
||||
USING: accessors calendar continuations destructors kernel math
|
||||
math.order namespaces system threads ui ui.gadgets.worlds ;
|
||||
IN: game-loop
|
||||
|
||||
TUPLE: game-loop
|
||||
|
|
@ -27,6 +27,16 @@ SYMBOL: game-loop
|
|||
|
||||
CONSTANT: MAX-FRAMES-TO-SKIP 5
|
||||
|
||||
DEFER: stop-loop
|
||||
|
||||
TUPLE: game-loop-error game-loop error ;
|
||||
|
||||
: ?ui-error ( error -- )
|
||||
ui-running? [ ui-error ] [ rethrow ] if ;
|
||||
|
||||
: game-loop-error ( game-loop error -- )
|
||||
[ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: redraw ( loop -- )
|
||||
|
|
@ -54,7 +64,9 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
|
|||
[ drop ] if ;
|
||||
|
||||
: run-loop ( loop -- )
|
||||
dup game-loop [ (run-loop) ] with-variable ;
|
||||
dup game-loop
|
||||
[ [ (run-loop) ] [ game-loop-error ] recover ]
|
||||
with-variable ;
|
||||
|
||||
: benchmark-millis ( loop -- millis )
|
||||
millis swap benchmark-time>> - ;
|
||||
|
|
@ -91,3 +103,6 @@ PRIVATE>
|
|||
M: game-loop dispose
|
||||
stop-loop ;
|
||||
|
||||
USING: vocabs vocabs.loader ;
|
||||
|
||||
"prettyprint" vocab [ "game-loop.prettyprint" require ] when
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors debugger game-loop io ;
|
||||
IN: game-loop.prettyprint
|
||||
|
||||
M: game-loop-error error.
|
||||
"An error occurred inside a game loop." print
|
||||
"The game loop has been stopped to prevent runaway errors." print
|
||||
"The error was:" print nl
|
||||
error>> error. ;
|
||||
|
|
@ -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