Merge branch 'master' of git://factorcode.org/git/factor

basis/compiler/cfg/def-use/def-use.factor

@@ -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 ;

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -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

basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -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 -- )
+ERROR: dead-value-error vreg ;
-    dup live-interval? [ "No def" throw ] unless
-    [ (>>end) ] [ uses>> push ] 2bi ;
 
-: <live-interval> ( start vreg -- live-interval )
+: shorten-range ( n live-interval -- )
-    live-interval new
+    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
+        V{ } clone >>ranges
-        over >>start
+        swap >>vreg ;
-        [ add-use ] keep ;
+
+: 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 -- )
+: live-interval ( vreg live-intervals -- live-interval )
-    2dup key? [
+    [ <live-interval> ] cache ;
-        at add-use
-    ] [
-        [ [ <live-interval> ] keep ] dip set-at
-    ] if ;
 
 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 '[ [ _ ] dip _ handle-output ] each ]
-    [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+    [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
-    [ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] 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
+        <reversed> [ compute-live-intervals-step ] each
-    ] keep values ;
+    ] keep values dup finish-live-intervals ;

basis/compiler/tests/codegen.factor

@@ -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

basis/cpu/x86/32/32.factor

@@ -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.

basis/cpu/x86/x86.factor

@@ -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 }
+        { EAX RAX }
-        { ECX ECX }
+        { ECX RCX }
-        { EDX EDX }
+        { EDX RDX }
-        { EBX EBX }
+        { EBX RBX }
-        { ESP ESP }
+        { ESP RSP }
-        { EBP EBP }
+        { EBP RBP }
-        { ESI ESP }
+        { ESI RSP }
-        { EDI EDI }
+        { 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

basis/opengl/gl/gl.factor

@@ -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

basis/ui/gadgets/worlds/worlds.factor

@@ -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
-

basis/ui/ui.factor

@@ -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) ;

extra/game-loop/game-loop.factor

@@ -1,5 +1,5 @@
-USING: accessors calendar destructors kernel math math.order namespaces
+USING: accessors calendar continuations destructors kernel math
-system threads ;
+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

extra/game-loop/prettyprint/prettyprint.factor

@@ -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. ;

extra/ui/gadgets/worlds/null/null.factor

@@ -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
+
+