From 796e5f58eb5b237e9bb6fa887cd26cae2b9d8d75 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 2 May 2008 17:52:17 +1000 Subject: [PATCH 01/22] starting to add bouncing to jamshred --- extra/jamshred/oint/oint.factor | 4 ++++ extra/jamshred/player/player.factor | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 11a89b314f..4680be4575 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -74,3 +74,7 @@ TUPLE: oint location forward up left ; : perpendicular-distance ( oint oint -- distance ) tuck distance-vector swap 2dup oint-left scalar-projection abs -rot oint-up scalar-projection abs + ; + +:: reflect ( v l -- v' ) + #! reflect v on l + v l v. l l v. / 2 * l n*v v v- ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 17843ef9c2..3e143a845e 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -28,7 +28,8 @@ TUPLE: player name tunnel nearest-segment ; 0.3 ; : player-speed ( player -- speed ) - dup player-nearest-segment fraction-from-wall sq max-speed * ; + max-speed ; + ! dup player-nearest-segment fraction-from-wall sq max-speed * ; : move-player ( player -- ) dup player-speed over go-forward update-nearest-segment ; From 78712fef1b7f68df705287b1912caac198bc7c32 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 7 May 2008 13:58:03 +1000 Subject: [PATCH 02/22] jamshred: some dodgy debug logging, and some dodgy collision detection :) --- extra/jamshred/game/game.factor | 9 ++-- extra/jamshred/jamshred.factor | 26 ++++----- extra/jamshred/log/log.factor | 10 ++++ extra/jamshred/oint/oint.factor | 64 +++++++++------------- extra/jamshred/player/player.factor | 55 +++++++++++++------ extra/jamshred/tunnel/tunnel.factor | 82 ++++++++++++++++++++++++----- 6 files changed, 157 insertions(+), 89 deletions(-) create mode 100644 extra/jamshred/log/log.factor diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index 3842816f0e..2a5fefcaed 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel opengl arrays sequences jamshred.tunnel -jamshred.player math.vectors ; +USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.tunnel math.vectors ; IN: jamshred.game TUPLE: jamshred tunnel players running ; @@ -12,15 +11,15 @@ TUPLE: jamshred tunnel players running ; : jamshred-player ( jamshred -- player ) ! TODO: support more than one player - jamshred-players first ; + players>> first ; : jamshred-update ( jamshred -- ) - dup jamshred-running [ + dup running>> [ jamshred-player update-player ] [ drop ] if ; : toggle-running ( jamshred -- ) - dup jamshred-running not swap set-jamshred-running ; + [ running>> not ] [ (>>running) ] bi ; : mouse-moved ( x-radians y-radians jamshred -- ) jamshred-player -rot turn-player ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 42414b9893..3a7047929f 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,14 +1,12 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: alarms arrays calendar jamshred.game jamshred.gl kernel math -math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render -math.vectors ; +USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.log kernel math math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render math.vectors ; IN: jamshred TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; : ( jamshred -- gadget ) - jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ; + jamshred-gadget construct-gadget swap >>jamshred ; : default-width ( -- x ) 1024 ; : default-height ( -- y ) 768 ; @@ -17,22 +15,21 @@ M: jamshred-gadget pref-dim* drop default-width default-height 2array ; M: jamshred-gadget draw-gadget* ( gadget -- ) - dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ; + [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ; : tick ( gadget -- ) - dup jamshred-gadget-jamshred jamshred-update relayout-1 ; + [ jamshred>> jamshred-update ] [ relayout-1 ] bi ; M: jamshred-gadget graft* ( gadget -- ) [ [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm - ] keep set-jamshred-gadget-alarm ; + ] keep (>>alarm) ; M: jamshred-gadget ungraft* ( gadget -- ) - [ jamshred-gadget-alarm cancel-alarm f ] keep - set-jamshred-gadget-alarm ; + [ alarm>> cancel-alarm ] [ f >>alarm drop ] bi ; : jamshred-restart ( jamshred-gadget -- ) - swap set-jamshred-gadget-jamshred ; + >>jamshred drop ; : pix>radians ( n m -- theta ) 2 / / pi 2 * * ; @@ -46,21 +43,20 @@ M: jamshred-gadget ungraft* ( gadget -- ) rect-dim second pix>radians ; : (handle-mouse-motion) ( jamshred-gadget mouse-motion -- ) - over jamshred-gadget-jamshred >r + over jamshred>> >r [ first swap x>radians ] 2keep second swap y>radians r> mouse-moved ; : handle-mouse-motion ( jamshred-gadget -- ) hand-loc get [ - over jamshred-gadget-last-hand-loc [ + over last-hand-loc>> [ v- (handle-mouse-motion) ] [ 2drop ] if* - ] 2keep swap set-jamshred-gadget-last-hand-loc ; + ] 2keep >>last-hand-loc drop ; -USE: vocabs.loader jamshred-gadget H{ { T{ key-down f f "r" } [ jamshred-restart ] } - { T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] } + { T{ key-down f f " " } [ jamshred>> toggle-running ] } { T{ motion } [ handle-mouse-motion ] } } set-gestures diff --git a/extra/jamshred/log/log.factor b/extra/jamshred/log/log.factor new file mode 100644 index 0000000000..33498d8a2e --- /dev/null +++ b/extra/jamshred/log/log.factor @@ -0,0 +1,10 @@ +USING: kernel logging ; +IN: jamshred.log + +LOG: (jamshred-log) DEBUG + +: with-jamshred-log ( quot -- ) + "jamshred" swap with-logging ; + +: jamshred-log ( message -- ) + [ (jamshred-log) ] with-jamshred-log ; ! ugly... diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 4680be4575..6b4f22bb9e 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; +USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; IN: jamshred.oint ! An oint is a point with three linearly independent unit vectors @@ -10,46 +10,23 @@ IN: jamshred.oint TUPLE: oint location forward up left ; -: ( location forward up left -- oint ) - oint boa ; - -! : x-rotation ( theta -- matrix ) -! #! construct this matrix: -! #! { { 1 0 0 } -! #! { 0 cos(theta) sin(theta) } -! #! { 0 -sin(theta) cos(theta) } } -! dup sin neg swap cos 2dup 0 -rot 3float-array >r -! swap neg 0 -rot 3float-array >r -! { 1 0 0 } r> r> 3float-array ; -! -! : y-rotation ( theta -- matrix ) -! #! costruct this matrix: -! #! { { cos(theta) 0 -sin(theta) } -! #! { 0 1 0 } -! #! { sin(theta) 0 cos(theta) } } -! dup sin swap cos 2dup -! 0 swap 3float-array >r -! { 0 1 0 } >r -! 0 rot neg 3float-array r> r> 3float-array ; - -: apply-to-oint ( oint quot -- ) - #! apply quot to each of forward, up, and left, storing the results - over oint-forward over call pick set-oint-forward - over oint-up over call pick set-oint-up - over oint-left swap call swap set-oint-left ; - : rotation-quaternion ( theta axis -- quaternion ) swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ; +: rotate-vector ( q qrecip v -- v ) + v>q swap q* q* q>v ; + : rotate-oint ( oint theta axis -- ) - rotation-quaternion dup qrecip - [ rot v>q swap q* q* q>v ] curry curry apply-to-oint ; + rotation-quaternion dup qrecip pick + [ forward>> rotate-vector >>forward ] + [ up>> rotate-vector >>up ] + [ left>> rotate-vector >>left ] 3tri drop ; : left-pivot ( oint theta -- ) - over oint-left rotate-oint ; + over left>> rotate-oint ; : up-pivot ( oint theta -- ) - over oint-up rotate-oint ; + over up>> rotate-oint ; : random-float+- ( n -- m ) #! find a random float between -n/2 and n/2 @@ -59,10 +36,10 @@ TUPLE: oint location forward up left ; 2 / 2dup random-float+- left-pivot random-float+- up-pivot ; : go-forward ( distance oint -- ) - tuck oint-forward n*v over oint-location v+ swap set-oint-location ; + [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ; : distance-vector ( oint oint -- vector ) - oint-location swap oint-location v- ; + [ location>> ] bi@ swap v- ; : distance ( oint oint -- distance ) distance-vector norm ; @@ -72,9 +49,16 @@ TUPLE: oint location forward up left ; tuck v. swap norm / ; : perpendicular-distance ( oint oint -- distance ) - tuck distance-vector swap 2dup oint-left scalar-projection abs - -rot oint-up scalar-projection abs + ; + tuck distance-vector swap 2dup left>> scalar-projection abs + -rot up>> scalar-projection abs + ; -:: reflect ( v l -- v' ) - #! reflect v on l - v l v. l l v. / 2 * l n*v v v- ; +: proj-perp ( v u -- w ) + dupd proj v- ; + +! :: reflect ( v l -- v' ) +! #! reflect v on l +! v l v. l l v. / 2 * l n*v v v- ; + +:: reflect ( vec n -- v' ) + #! bounce v on a surface with normal n + vec n v. n n*v -2 * vec v+ ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 3e143a845e..6feca27366 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,39 +1,64 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: colors jamshred.oint jamshred.tunnel kernel -math math.constants sequences ; +USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences ; IN: jamshred.player -TUPLE: player name tunnel nearest-segment ; +TUPLE: player < oint name tunnel nearest-segment ; : ( name -- player ) - f f player boa - F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } over set-delegate ; + [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f player boa ; : turn-player ( player x-radians y-radians -- ) >r over r> left-pivot up-pivot ; : to-tunnel-start ( player -- ) - dup player-tunnel first dup oint-location pick set-oint-location - swap set-player-nearest-segment ; + [ tunnel>> first dup location>> ] + [ tuck (>>location) (>>nearest-segment) ] bi ; : play-in-tunnel ( player segments -- ) - over set-player-tunnel to-tunnel-start ; + >>tunnel to-tunnel-start ; : update-nearest-segment ( player -- ) - dup player-tunnel over dup player-nearest-segment nearest-segment - swap set-player-nearest-segment ; + [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] + [ (>>nearest-segment) ] tri ; : max-speed ( -- speed ) - 0.3 ; + 0.01 ; : player-speed ( player -- speed ) - max-speed ; - ! dup player-nearest-segment fraction-from-wall sq max-speed * ; + drop max-speed ; + ! dup nearest-segment>> fraction-from-wall sq max-speed * ; + +! : move-player ( player -- ) +! dup player-speed over go-forward update-nearest-segment ; +DEFER: (move-player) + +: ?bounce ( distance-remaining player -- ) + over 0 > [ + [ dup nearest-segment>> bounce ] + ! [ (move-player) ] ! uncomment when bounce works... + [ 2drop ] + bi + ] [ + 2drop + ] if ; + +: move-player-distance ( distance-remaining player distance -- distance-remaining player ) + pick min tuck over go-forward [ - ] dip ; + +USE: prettyprint +USE: io.streams.string +: (move-player) ( distance-remaining player -- ) + over 0 <= [ + 2drop + ] [ + dup dup nearest-segment>> distance-to-collision ! [ .s ] with-string-writer jamshred-log + move-player-distance ?bounce + ] if ; : move-player ( player -- ) - dup player-speed over go-forward update-nearest-segment ; + [ player-speed ] [ (move-player) ] [ update-nearest-segment ] tri ; : update-player ( player -- ) - dup move-player player-nearest-segment + dup move-player nearest-segment>> white swap set-segment-color ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index c3f6b37fb8..7c6740f139 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,23 +1,20 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: arrays float-arrays kernel jamshred.oint math math.functions -math.ranges math.vectors math.constants random sequences vectors ; +USING: accessors arrays float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors random sequences vectors ; IN: jamshred.tunnel : n-segments ( -- n ) 5000 ; inline -TUPLE: segment number color radius ; - -: ( number color radius location forward up left -- segment ) - >r segment boa r> over set-delegate ; +TUPLE: segment < oint number color radius ; +C: segment : segment-vertex ( theta segment -- vertex ) - tuck 2dup oint-up swap sin v*n - >r oint-left swap cos v*n r> v+ - swap oint-location v+ ; + tuck 2dup up>> swap sin v*n + >r left>> swap cos v*n r> v+ + swap location>> v+ ; : segment-vertex-normal ( vertex segment -- normal ) - oint-location swap v- normalize ; + location>> swap v- normalize ; : segment-vertex-and-normal ( segment theta -- vertex normal ) swap [ segment-vertex ] keep dupd segment-vertex-normal ; @@ -50,15 +47,15 @@ TUPLE: segment number color radius ; : default-segment-radius ( -- r ) 1 ; : initial-segment ( -- segment ) - 0 random-color default-segment-radius - F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ; + F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } + 0 random-color default-segment-radius ; : random-segments ( n -- segments ) initial-segment 1vector swap (random-segments) ; : simple-segment ( n -- segment ) - random-color default-segment-radius pick F{ 0 0 -1 } n*v - F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ; + [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep + random-color default-segment-radius ; : simple-segments ( n -- segments ) [ simple-segment ] map ; @@ -111,3 +108,60 @@ TUPLE: segment number color radius ; : fraction-from-wall ( oint segment -- fraction ) fraction-from-centre 1 swap - ; + +: sideways-heading ( oint segment -- v ) + [ forward>> ] bi@ proj-perp ; + +! : facing-nearest-wall? ( oint segment -- ? ) +! [ [ location>> ] bi@ distance ] +! [ sideways-heading ] +! [ [ location>> ] bi@ [ v+ ] dip distance ] tri < ; + +! : distance-to-collision ( oint segment -- distance ) +! ! TODO: this isn't right. If oint is facing away from the wall then it should return a much bigger distance... +! #! distance on the oint's heading to the segment wall +! facing-nearest-wall? [ +! [ sideways-heading norm ] +! [ distance-from-wall ] 2bi swap / +! ] [ +! ] if ; + +:: (collision-coefficient) ( -2b sqrt(b^2-2ac) 2a -- c ) + -2b sqrt(b^2-2ac) + 2a / + -2b sqrt(b^2-2ac) - 2a / max ; ! the -ve answer is behind us (I think..) + +:: collision-coefficient ( v w -- c ) + [let* | a [ v dup v. ] + b [ v w v. 2 * ] + c [ w dup v. v dup v. - ] | + b -2 * b sq a c * 2 * - sqrt a 2 * (collision-coefficient) ] ; + +: distance-to-collision ( oint segment -- distance ) + [ sideways-heading ] [ [ location>> ] bi@ v- collision-coefficient ] + [ drop forward>> n*v norm ] 2tri ; + +:: (wall-normal) ( seg loc -- n ) + [let* | back [ loc seg location>> v- ] + back-proj [ back seg forward>> proj ] + perp-point [ loc back-proj v- ] | + perp-point seg location>> v- normalize ] ; + +: wall-normal ( segment oint -- n ) + location>> (wall-normal) ; + +: bounce-forward ( segment oint -- ) + [ wall-normal ] [ swap reflect ] [ (>>forward) ] tri ; + +: bounce-up ( oint segment -- ) + 2drop ; ! TODO + +: bounce-left ( oint segment -- ) + 2drop ; ! TODO + +! : bounce ( oint segment -- ) +! [ swap bounce-forward ] +! [ bounce-up ] +! [ bounce-left ] 2tri ; + +: bounce ( oint segment -- ) + drop 0.01 left-pivot ; ! just temporary From 805f025cc5802fc7115309493aa44cd39ee04382 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 7 May 2008 16:15:14 +1000 Subject: [PATCH 03/22] jamshred: some very wrong bounce code... --- extra/jamshred/game/game.factor | 12 +++++++--- extra/jamshred/jamshred.factor | 23 +++++++++++-------- extra/jamshred/oint/oint-tests.factor | 4 ++++ extra/jamshred/oint/oint.factor | 8 ++----- extra/jamshred/player/player.factor | 23 +++++++++++-------- extra/jamshred/tunnel/tunnel.factor | 33 +++++++++++++++------------ 6 files changed, 61 insertions(+), 42 deletions(-) create mode 100644 extra/jamshred/oint/oint-tests.factor diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index 2a5fefcaed..e187d26a17 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -3,10 +3,10 @@ USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.tunnel math.vectors ; IN: jamshred.game -TUPLE: jamshred tunnel players running ; +TUPLE: jamshred tunnel players running quit ; : ( -- jamshred ) - "Player 1" 2dup swap play-in-tunnel 1array f + "Player 1" 2dup swap play-in-tunnel 1array f f jamshred boa ; : jamshred-player ( jamshred -- player ) @@ -19,7 +19,13 @@ TUPLE: jamshred tunnel players running ; ] [ drop ] if ; : toggle-running ( jamshred -- ) - [ running>> not ] [ (>>running) ] bi ; + dup running>> [ + f >>running drop + ] [ + [ jamshred-player moved ] + [ t >>running drop ] bi + ] if ; : mouse-moved ( x-radians y-radians jamshred -- ) jamshred-player -rot turn-player ; + diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 3a7047929f..bdec1e57e5 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.log kernel math math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render math.vectors ; +USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.log kernel math math.constants namespaces sequences threads ui ui.gadgets ui.gestures ui.render math.vectors ; IN: jamshred TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; @@ -8,8 +8,8 @@ TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; : ( jamshred -- gadget ) jamshred-gadget construct-gadget swap >>jamshred ; -: default-width ( -- x ) 1024 ; -: default-height ( -- y ) 768 ; +: default-width ( -- x ) 640 ; +: default-height ( -- y ) 480 ; M: jamshred-gadget pref-dim* drop default-width default-height 2array ; @@ -17,16 +17,19 @@ M: jamshred-gadget pref-dim* M: jamshred-gadget draw-gadget* ( gadget -- ) [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ; -: tick ( gadget -- ) - [ jamshred>> jamshred-update ] [ relayout-1 ] bi ; +: jamshred-loop ( gadget -- ) + dup jamshred>> quit>> [ + drop + ] [ + dup [ jamshred>> jamshred-update ] + [ relayout-1 ] bi + 50 sleep jamshred-loop + ] if ; M: jamshred-gadget graft* ( gadget -- ) - [ - [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm - ] keep (>>alarm) ; - + [ jamshred-loop ] in-thread drop ; M: jamshred-gadget ungraft* ( gadget -- ) - [ alarm>> cancel-alarm ] [ f >>alarm drop ] bi ; + jamshred>> t >>quit drop ; : jamshred-restart ( jamshred-gadget -- ) >>jamshred drop ; diff --git a/extra/jamshred/oint/oint-tests.factor b/extra/jamshred/oint/oint-tests.factor new file mode 100644 index 0000000000..cf9f22261a --- /dev/null +++ b/extra/jamshred/oint/oint-tests.factor @@ -0,0 +1,4 @@ +USING: jamshred.oint tools.test ; +IN: jamshred.oint-tests + +[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 6b4f22bb9e..9f4eada11e 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -55,10 +55,6 @@ TUPLE: oint location forward up left ; : proj-perp ( v u -- w ) dupd proj v- ; -! :: reflect ( v l -- v' ) -! #! reflect v on l -! v l v. l l v. / 2 * l n*v v v- ; - -:: reflect ( vec n -- v' ) +:: reflect ( v n -- v' ) #! bounce v on a surface with normal n - vec n v. n n*v -2 * vec v+ ; + v v n v. n n v. / 2 * n n*v v- ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 6feca27366..4aba302a75 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences ; +USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences system ; IN: jamshred.player -TUPLE: player < oint name tunnel nearest-segment ; +TUPLE: player < oint name tunnel nearest-segment last-move ; : ( name -- player ) - [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f player boa ; + [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f f player boa ; : turn-player ( player x-radians y-radians -- ) >r over r> left-pivot up-pivot ; @@ -22,19 +22,23 @@ TUPLE: player < oint name tunnel nearest-segment ; [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] [ (>>nearest-segment) ] tri ; -: max-speed ( -- speed ) - 0.01 ; +: moved ( player -- ) millis swap (>>last-move) ; +: max-speed ( -- speed ) 1.0 ; ! units/second : player-speed ( player -- speed ) drop max-speed ; ! dup nearest-segment>> fraction-from-wall sq max-speed * ; -! : move-player ( player -- ) -! dup player-speed over go-forward update-nearest-segment ; +: distance-to-move ( player -- distance ) + [ player-speed ] [ last-move>> millis dup >r swap - 1000 / * r> ] + [ (>>last-move) ] tri ; + DEFER: (move-player) +USE: morse : ?bounce ( distance-remaining player -- ) over 0 > [ + "e" play-as-morse [ dup nearest-segment>> bounce ] ! [ (move-player) ] ! uncomment when bounce works... [ 2drop ] @@ -52,12 +56,13 @@ USE: io.streams.string over 0 <= [ 2drop ] [ - dup dup nearest-segment>> distance-to-collision ! [ .s ] with-string-writer jamshred-log + dup dup nearest-segment>> distance-to-collision + [ dup . ] with-string-writer jamshred-log move-player-distance ?bounce ] if ; : move-player ( player -- ) - [ player-speed ] [ (move-player) ] [ update-nearest-segment ] tri ; + [ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ; : update-player ( player -- ) dup move-player nearest-segment>> diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 7c6740f139..3ac864a7f7 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -126,15 +126,23 @@ C: segment ! ] [ ! ] if ; +USING: jamshred.log prettyprint io.streams.string ; + +: distant 10 ; inline + :: (collision-coefficient) ( -2b sqrt(b^2-2ac) 2a -- c ) - -2b sqrt(b^2-2ac) + 2a / - -2b sqrt(b^2-2ac) - 2a / max ; ! the -ve answer is behind us (I think..) + sqrt(b^2-2ac) complex? [ + distant + ] [ + -2b sqrt(b^2-2ac) + 2a / + -2b sqrt(b^2-2ac) - 2a / max ! the -ve answer is behind us + ] if ; :: collision-coefficient ( v w -- c ) [let* | a [ v dup v. ] b [ v w v. 2 * ] c [ w dup v. v dup v. - ] | - b -2 * b sq a c * 2 * - sqrt a 2 * (collision-coefficient) ] ; + b neg b sq a c * 4 * - sqrt a 2 * (collision-coefficient) ] ; : distance-to-collision ( oint segment -- distance ) [ sideways-heading ] [ [ location>> ] bi@ v- collision-coefficient ] @@ -150,18 +158,15 @@ C: segment location>> (wall-normal) ; : bounce-forward ( segment oint -- ) - [ wall-normal ] [ swap reflect ] [ (>>forward) ] tri ; + [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ; -: bounce-up ( oint segment -- ) - 2drop ; ! TODO +: bounce-left ( segment oint -- ) + [ forward>> vneg ] dip [ left>> swap reflect ] [ (>>left) ] bi ; -: bounce-left ( oint segment -- ) - 2drop ; ! TODO - -! : bounce ( oint segment -- ) -! [ swap bounce-forward ] -! [ bounce-up ] -! [ bounce-left ] 2tri ; +: bounce-up ( segment oint -- ) + #! must be done after forward and left! + nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ; : bounce ( oint segment -- ) - drop 0.01 left-pivot ; ! just temporary + swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ; + From d61683ecdbfd34d163d50a78568e698a25f2e12d Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 8 May 2008 01:08:48 +1000 Subject: [PATCH 04/22] jamshred: collision detection half working (half broken) --- extra/jamshred/oint/oint-tests.factor | 4 ++ extra/jamshred/oint/oint.factor | 7 +- extra/jamshred/player/player.factor | 11 +--- extra/jamshred/tunnel/tunnel-tests.factor | 31 ++++++++- extra/jamshred/tunnel/tunnel.factor | 79 ++++++++++------------- 5 files changed, 71 insertions(+), 61 deletions(-) diff --git a/extra/jamshred/oint/oint-tests.factor b/extra/jamshred/oint/oint-tests.factor index cf9f22261a..401935fd01 100644 --- a/extra/jamshred/oint/oint-tests.factor +++ b/extra/jamshred/oint/oint-tests.factor @@ -2,3 +2,7 @@ USING: jamshred.oint tools.test ; IN: jamshred.oint-tests [ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test +[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test +[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test +[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test +[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 9f4eada11e..e2104b6f41 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -9,6 +9,7 @@ IN: jamshred.oint ! segment's location and orientation are given by an oint. TUPLE: oint location forward up left ; +C: oint : rotation-quaternion ( theta axis -- quaternion ) swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ; @@ -48,13 +49,13 @@ TUPLE: oint location forward up left ; #! the scalar projection of v1 onto v2 tuck v. swap norm / ; +: proj-perp ( u v -- w ) + dupd proj v- ; + : perpendicular-distance ( oint oint -- distance ) tuck distance-vector swap 2dup left>> scalar-projection abs -rot up>> scalar-projection abs + ; -: proj-perp ( v u -- w ) - dupd proj v- ; - :: reflect ( v n -- v' ) #! bounce v on a surface with normal n v v n v. n n v. / 2 * n n*v v- ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 4aba302a75..979ad136d3 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -27,7 +27,6 @@ TUPLE: player < oint name tunnel nearest-segment last-move ; : player-speed ( player -- speed ) drop max-speed ; - ! dup nearest-segment>> fraction-from-wall sq max-speed * ; : distance-to-move ( player -- distance ) [ player-speed ] [ last-move>> millis dup >r swap - 1000 / * r> ] @@ -35,14 +34,9 @@ TUPLE: player < oint name tunnel nearest-segment last-move ; DEFER: (move-player) -USE: morse : ?bounce ( distance-remaining player -- ) over 0 > [ - "e" play-as-morse - [ dup nearest-segment>> bounce ] - ! [ (move-player) ] ! uncomment when bounce works... - [ 2drop ] - bi + [ dup nearest-segment>> bounce ] [ (move-player) ] bi ] [ 2drop ] if ; @@ -50,14 +44,11 @@ USE: morse : move-player-distance ( distance-remaining player distance -- distance-remaining player ) pick min tuck over go-forward [ - ] dip ; -USE: prettyprint -USE: io.streams.string : (move-player) ( distance-remaining player -- ) over 0 <= [ 2drop ] [ dup dup nearest-segment>> distance-to-collision - [ dup . ] with-string-writer jamshred-log move-player-distance ?bounce ] if ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 8031678896..c6755318e6 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -3,8 +3,8 @@ USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ; IN: jamshred.tunnel.tests -[ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 } - T{ segment T{ oint f { 1 1 1 } } 1 } +[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 } + T{ segment f { 1 1 1 } f f f 1 } T{ oint f { 0 0 0.25 } } nearer-segment segment-number ] unit-test @@ -15,3 +15,30 @@ IN: jamshred.tunnel.tests [ 3 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test [ F{ 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test + +: test-segment-oint ( -- oint ) + { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } ; + +[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test +[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test +[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test +[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test +[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test +[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test +[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test +[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test + +: simplest-straight-ahead ( -- oint segment ) + { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } + initial-segment ; + +[ { 0 0 0 } ] [ simplest-straight-ahead sideways-heading ] unit-test +[ { 0 0 0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test + +: simple-collision-up ( -- oint segment ) + { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } + initial-segment ; + +[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test +[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test +[ { 0 1 0 } ] [ simple-collision-up collision-vector ] unit-test diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 3ac864a7f7..9b0257d372 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors random sequences vectors ; +USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ; IN: jamshred.tunnel : n-segments ( -- n ) 5000 ; inline @@ -24,7 +24,7 @@ C: segment dup [ / pi 2 * * ] curry map ; : segment-number++ ( segment -- ) - dup segment-number 1+ swap set-segment-number ; + [ number>> 1+ ] keep (>>number) ; : random-color ( -- color ) { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ; @@ -47,8 +47,8 @@ C: segment : default-segment-radius ( -- r ) 1 ; : initial-segment ( -- segment ) - F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } - 0 random-color default-segment-radius ; + F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } + 0 random-color default-segment-radius ; : random-segments ( n -- segments ) initial-segment 1vector swap (random-segments) ; @@ -97,65 +97,52 @@ C: segment [ nearest-segment-forward ] 3keep nearest-segment-backward r> nearer-segment ; -: distance-from-centre ( oint segment -- distance ) - perpendicular-distance ; +: vector-to-centre ( seg loc -- v ) + over location>> swap v- swap forward>> proj-perp ; -: distance-from-wall ( oint segment -- distance ) - tuck distance-from-centre swap segment-radius swap - ; +: distance-from-centre ( seg loc -- distance ) + vector-to-centre norm ; -: fraction-from-centre ( oint segment -- fraction ) - tuck distance-from-centre swap segment-radius / ; +: wall-normal ( seg oint -- n ) + location>> vector-to-centre normalize ; -: fraction-from-wall ( oint segment -- fraction ) +: from ( seg loc -- radius d-f-c ) + dupd location>> distance-from-centre [ radius>> ] dip ; + +: distance-from-wall ( seg loc -- distance ) from - ; +: fraction-from-centre ( seg loc -- fraction ) from / ; +: fraction-from-wall ( seg loc -- fraction ) fraction-from-centre 1 swap - ; -: sideways-heading ( oint segment -- v ) - [ forward>> ] bi@ proj-perp ; - -! : facing-nearest-wall? ( oint segment -- ? ) -! [ [ location>> ] bi@ distance ] -! [ sideways-heading ] -! [ [ location>> ] bi@ [ v+ ] dip distance ] tri < ; - -! : distance-to-collision ( oint segment -- distance ) -! ! TODO: this isn't right. If oint is facing away from the wall then it should return a much bigger distance... -! #! distance on the oint's heading to the segment wall -! facing-nearest-wall? [ -! [ sideways-heading norm ] -! [ distance-from-wall ] 2bi swap / -! ] [ -! ] if ; - -USING: jamshred.log prettyprint io.streams.string ; - : distant 10 ; inline -:: (collision-coefficient) ( -2b sqrt(b^2-2ac) 2a -- c ) - sqrt(b^2-2ac) complex? [ +:: (collision-coefficient) ( -b sqrt(b^2-4ac) 2a -- c ) + sqrt(b^2-4ac) complex? [ distant ] [ - -2b sqrt(b^2-2ac) + 2a / - -2b sqrt(b^2-2ac) - 2a / max ! the -ve answer is behind us + -b sqrt(b^2-4ac) + 2a / + -b sqrt(b^2-4ac) - 2a / max ! the -ve answer is behind us ] if ; :: collision-coefficient ( v w -- c ) [let* | a [ v dup v. ] b [ v w v. 2 * ] c [ w dup v. v dup v. - ] | - b neg b sq a c * 4 * - sqrt a 2 * (collision-coefficient) ] ; + c b a quadratic [ real-part ] bi@ max ] ; +: sideways-heading ( oint segment -- v ) + [ forward>> ] bi@ proj-perp ; + +: sideways-relative-location ( oint segment -- loc ) + [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; + +: collision-vector ( oint segment -- v ) + dupd [ sideways-heading ] [ sideways-relative-location ] 2bi + collision-coefficient swap forward>> n*v ; + +USING: prettyprint jamshred.log io.streams.string ; : distance-to-collision ( oint segment -- distance ) - [ sideways-heading ] [ [ location>> ] bi@ v- collision-coefficient ] - [ drop forward>> n*v norm ] 2tri ; - -:: (wall-normal) ( seg loc -- n ) - [let* | back [ loc seg location>> v- ] - back-proj [ back seg forward>> proj ] - perp-point [ loc back-proj v- ] | - perp-point seg location>> v- normalize ] ; - -: wall-normal ( segment oint -- n ) - location>> (wall-normal) ; + collision-vector norm [ dup . ] with-string-writer jamshred-log ; : bounce-forward ( segment oint -- ) [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ; From 1d60d722fe13d831c55577ceccc6d06c96605d93 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 7 May 2008 17:42:41 -0500 Subject: [PATCH 05/22] Improve time word, faster card scan --- core/bootstrap/primitives.factor | 2 +- core/inference/known-words/known-words.factor | 2 +- extra/benchmark/benchmark.factor | 2 +- extra/optimizer/report/report.factor | 2 +- .../ave-time/ave-time-docs.factor | 6 +- extra/project-euler/ave-time/ave-time.factor | 13 +-- extra/reports/optimizer/optimizer.factor | 2 +- extra/tools/test/test.factor | 4 +- extra/tools/time/time-docs.factor | 4 +- extra/tools/time/time.factor | 34 ++++++-- vm/data_gc.c | 82 ++++++++++++++----- vm/data_gc.h | 7 +- vm/primitives.c | 2 +- 13 files changed, 107 insertions(+), 55 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6149e83893..753464ab80 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -607,7 +607,7 @@ tuple { "(exists?)" "io.files.private" } { "(directory)" "io.files.private" } { "gc" "memory" } - { "gc-time" "memory" } + { "gc-stats" "memory" } { "save-image" "memory" } { "save-image-and-exit" "memory" } { "datastack" "kernel" } diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index b68c98d25d..a6dd089db1 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -362,7 +362,7 @@ M: object infer-call \ gc { } { } set-primitive-effect -\ gc-time { } { integer } set-primitive-effect +\ gc-stats { } { array } set-primitive-effect \ save-image { string } { } set-primitive-effect diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index a75251331f..c00087fc9f 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -6,7 +6,7 @@ continuations debugger ; IN: benchmark : run-benchmark ( vocab -- result ) - [ [ require ] [ [ run ] benchmark nip ] bi ] curry + [ [ require ] [ [ run ] benchmark ] bi ] curry [ error. f ] recover ; : run-benchmarks ( -- assoc ) diff --git a/extra/optimizer/report/report.factor b/extra/optimizer/report/report.factor index 70756e81c2..60b83819d5 100755 --- a/extra/optimizer/report/report.factor +++ b/extra/optimizer/report/report.factor @@ -20,7 +20,7 @@ IN: optimizer.report [ dup [ word-dataflow nip 1 count-optimization-passes - ] benchmark nip 2array + ] benchmark 2array ] { } map>assoc [ first ] "Worst number of optimizer passes:" results [ second ] "Worst compile times:" results ; diff --git a/extra/project-euler/ave-time/ave-time-docs.factor b/extra/project-euler/ave-time/ave-time-docs.factor index cc40ae4bf1..d8ee0846b0 100644 --- a/extra/project-euler/ave-time/ave-time-docs.factor +++ b/extra/project-euler/ave-time/ave-time-docs.factor @@ -16,9 +16,7 @@ HELP: ave-time "This word can be used to compare performance of the non-optimizing and optimizing compilers." $nl "First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:" - { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run / 6 ms GC ave time - 10 trials" } + { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run time - 10 trials" } "Now we define a word and compile it with the optimizing word compiler. This results is faster execution:" - { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run / 13 ms GC ave time - 10 trials" } + { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run time - 10 trials" } } ; - -{ benchmark collect-benchmarks gc-time millis time ave-time } related-words diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index b908dbd7b0..c8212b4009 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/extra/project-euler/ave-time/ave-time.factor @@ -4,20 +4,13 @@ USING: arrays combinators io kernel math math.functions math.parser math.statistics namespaces sequences tools.time ; IN: project-euler.ave-time - - : collect-benchmarks ( quot n -- seq ) [ - >r >r datastack r> [ benchmark 2array , ] curry tuck + >r >r datastack r> [ benchmark , ] curry tuck [ with-datastack drop ] 2curry r> swap times call ] { } make ; : ave-time ( quot n -- ) - [ collect-benchmarks ] keep swap ave-benchmarks [ - dup second # " ms run / " % first # " ms GC ave time - " % # " trials" % + [ collect-benchmarks ] keep swap mean round [ + # " ms run time - " % # " trials" % ] "" make print flush ; inline diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor index 06e76d0a99..51eae24333 100755 --- a/extra/reports/optimizer/optimizer.factor +++ b/extra/reports/optimizer/optimizer.factor @@ -20,7 +20,7 @@ IN: report.optimizer [ dup [ word-dataflow nip 1 count-optimization-passes - ] benchmark nip 2array + ] benchmark 2array ] { } map>assoc ; : optimizer-measurements. ( alist -- ) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 854ef7af0e..8ef80c6add 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators -continuations debugger io io.files vocabs tools.time +continuations debugger io io.files vocabs vocabs.loader source-files compiler.units inspector inference effects tools.vocabs ; IN: tools.test @@ -19,7 +19,7 @@ SYMBOL: this-test : (unit-test) ( what quot -- ) swap dup . flush this-test set - [ time ] curry failures get [ + failures get [ [ this-test get failure ] recover ] [ call diff --git a/extra/tools/time/time-docs.factor b/extra/tools/time/time-docs.factor index 36ab3c01d4..46d356bef5 100644 --- a/extra/tools/time/time-docs.factor +++ b/extra/tools/time/time-docs.factor @@ -6,9 +6,9 @@ ARTICLE: "timing" "Timing code" { $subsection time } "A lower-level word puts timings on the stack, intead of printing:" { $subsection benchmark } -"You can also read the system clock and total garbage collection time directly:" +"You can also read the system clock and garbage collection statistics directly:" { $subsection millis } -{ $subsection gc-time } +{ $subsection gc-stats } { $see-also "profiling" } ; ABOUT: "timing" diff --git a/extra/tools/time/time.factor b/extra/tools/time/time.factor index 4862cc2b27..3ddea1b74d 100644 --- a/extra/tools/time/time.factor +++ b/extra/tools/time/time.factor @@ -1,14 +1,32 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math memory io namespaces system -math.parser ; +USING: kernel math math.vectors memory io io.styles prettyprint +namespaces system sequences assocs ; IN: tools.time : benchmark ( quot -- gctime runtime ) - millis >r gc-time >r call gc-time r> - millis r> - ; - inline + millis >r call millis r> - ; inline + +: stats. ( data -- ) + { + "Run time" + "GC time" + "Nursery collections" + "Aging collections" + "Tenured collections" + "Cards checked" + "Cards scanned" + "Code literal collections" + } swap zip [ nip 0 > ] assoc-filter + standard-table-style [ + [ + [ + [ [ write ] with-cell ] [ pprint-cell ] bi* + ] with-row + ] assoc-each + ] tabular-output ; + +: stats gc-stats millis prefix ; : time ( quot -- ) - benchmark - [ # " ms run / " % # " ms GC time" % ] "" make print flush ; - inline + stats >r call stats r> v- stats. ; inline diff --git a/vm/data_gc.c b/vm/data_gc.c index 5aa47c8c6c..da112edb31 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -144,7 +144,10 @@ void init_data_heap(CELL gens, gc_time = 0; aging_collections = 0; nursery_collections = 0; + tenured_collections = 0; + cards_checked = 0; cards_scanned = 0; + code_heap_scans = 0; secure_gc = secure_gc_; } @@ -283,7 +286,7 @@ DEFINE_PRIMITIVE(end_scan) } /* Scan all the objects in the card */ -INLINE void collect_card(F_CARD *ptr, CELL gen, CELL here) +void collect_card(F_CARD *ptr, CELL gen, CELL here) { F_CARD c = *ptr; CELL offset = (c & CARD_BASE_MASK); @@ -305,14 +308,49 @@ INLINE void collect_card(F_CARD *ptr, CELL gen, CELL here) cards_scanned++; } -/* Copy all newspace objects referenced from marked cards to the destination */ -INLINE void collect_gen_cards(CELL gen) +void collect_card_deck(CELL gen, + F_CARD *first_card, F_CARD *last_card, + F_CARD mask, F_CARD unmask) { - F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[gen].start); CELL here = data_heap->generations[gen].here; - F_CARD *last_card = ADDR_TO_CARD(here - 1); - CELL mask, unmask; + long long cards_checked_ = 0; + + u32 *quad_ptr; + u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24); + + u32 *last_card_aligned = (u32 *)(((CELL)last_card + 3) & ~3); + + for(quad_ptr = (u32 *)first_card; quad_ptr <= (u32 *)last_card_aligned; quad_ptr++) + { + cards_checked_ += 4; + + if(*quad_ptr & quad_mask) + { + F_CARD *ptr = (F_CARD *)quad_ptr; + + int card; + for(card = 0; card < 4; card++) + { + if(ptr[card] & mask) + { + collect_card(&ptr[card],gen,here); + ptr[card] &= ~unmask; + } + } + } + } + + cards_checked += cards_checked_; +} + +/* Copy all newspace objects referenced from marked cards to the destination */ +void collect_gen_cards(CELL gen) +{ + F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[gen].start); + F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[gen].here - 1); + + F_CARD mask, unmask; /* if we are collecting the nursery, we care about old->nursery pointers but not old->aging pointers */ @@ -360,14 +398,7 @@ INLINE void collect_gen_cards(CELL gen) return; } - for(; ptr <= last_card; ptr++) - { - if(*ptr & mask) - { - collect_card(ptr,gen,here); - *ptr &= ~unmask; - } - } + collect_card_deck(gen,first_card,last_card,mask,unmask); } /* Scan cards in all generations older than the one being collected, copying @@ -657,17 +688,13 @@ void end_gc(void) if(collecting_gen == TENURED) { + tenured_collections++; GC_PRINT(END_AGING_GC,aging_collections,cards_scanned); - aging_collections = 0; - cards_scanned = 0; } else if(HAVE_AGING_P && collecting_gen == AGING) { aging_collections++; - GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned); - nursery_collections = 0; - cards_scanned = 0; } } else @@ -758,7 +785,10 @@ void garbage_collection(CELL gen, literals from any code block which gets marked as live. if we are not doing code GC, just consider all literals as roots. */ + code_heap_scans++; + collect_literals(); + if(collecting_accumulation_gen_p()) last_code_heap_scan = collecting_gen; else @@ -794,9 +824,19 @@ DEFINE_PRIMITIVE(gc) } /* Push total time spent on GC */ -DEFINE_PRIMITIVE(gc_time) +DEFINE_PRIMITIVE(gc_stats) { - box_unsigned_8(gc_time); + CELL array = tag_object(allot_array(ARRAY_TYPE,7,F)); + REGISTER_ROOT(array); + set_array_nth(untag_object(array),0,tag_bignum(long_long_to_bignum(gc_time))); + set_array_nth(untag_object(array),1,allot_cell(nursery_collections)); + set_array_nth(untag_object(array),2,allot_cell(aging_collections)); + set_array_nth(untag_object(array),3,allot_cell(tenured_collections)); + set_array_nth(untag_object(array),4,tag_bignum(long_long_to_bignum(cards_scanned))); + set_array_nth(untag_object(array),5,tag_bignum(long_long_to_bignum(cards_checked))); + set_array_nth(untag_object(array),6,allot_cell(code_heap_scans)); + UNREGISTER_ROOT(array); + dpush(array); } DEFINE_PRIMITIVE(become) diff --git a/vm/data_gc.h b/vm/data_gc.h index be9ed159b7..1b42eafb36 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -145,7 +145,10 @@ void init_data_heap(CELL gens, s64 gc_time; CELL nursery_collections; CELL aging_collections; -CELL cards_scanned; +CELL tenured_collections; +s64 cards_checked; +s64 cards_scanned; +CELL code_heap_scans; /* only meaningful during a GC */ bool performing_gc; @@ -364,7 +367,7 @@ INLINE void* allot_object(CELL type, CELL a) CELL collect_next(CELL scan); DECLARE_PRIMITIVE(gc); -DECLARE_PRIMITIVE(gc_time); +DECLARE_PRIMITIVE(gc_stats); DECLARE_PRIMITIVE(become); CELL find_all_words(void); diff --git a/vm/primitives.c b/vm/primitives.c index da04870ecd..cc8cf61013 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -91,7 +91,7 @@ void *primitives[] = { primitive_existsp, primitive_read_dir, primitive_gc, - primitive_gc_time, + primitive_gc_stats, primitive_save_image, primitive_save_image_and_exit, primitive_datastack, From ea2107e4637a9037aab3a02b307c378725dfdfc6 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 8 May 2008 12:17:05 +1000 Subject: [PATCH 06/22] jamshred: collision detection better, bounce still buggy --- extra/jamshred/tunnel/tunnel.factor | 23 ++++++----------------- 1 file changed, 6 insertions(+), 17 deletions(-) diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 9b0257d372..4369944e9e 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -114,21 +114,11 @@ C: segment : fraction-from-wall ( seg loc -- fraction ) fraction-from-centre 1 swap - ; -: distant 10 ; inline - -:: (collision-coefficient) ( -b sqrt(b^2-4ac) 2a -- c ) - sqrt(b^2-4ac) complex? [ - distant - ] [ - -b sqrt(b^2-4ac) + 2a / - -b sqrt(b^2-4ac) - 2a / max ! the -ve answer is behind us - ] if ; - -:: collision-coefficient ( v w -- c ) +:: collision-coefficient ( v w r -- c ) [let* | a [ v dup v. ] b [ v w v. 2 * ] - c [ w dup v. v dup v. - ] | - c b a quadratic [ real-part ] bi@ max ] ; + c [ w dup v. r sq - ] | + c b a quadratic max ] ; : sideways-heading ( oint segment -- v ) [ forward>> ] bi@ proj-perp ; @@ -137,12 +127,11 @@ C: segment [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; : collision-vector ( oint segment -- v ) - dupd [ sideways-heading ] [ sideways-relative-location ] 2bi - collision-coefficient swap forward>> n*v ; + [ sideways-heading ] [ sideways-relative-location ] [ radius>> ] 2tri + swap [ collision-coefficient ] dip forward>> n*v ; -USING: prettyprint jamshred.log io.streams.string ; : distance-to-collision ( oint segment -- distance ) - collision-vector norm [ dup . ] with-string-writer jamshred-log ; + collision-vector norm ; : bounce-forward ( segment oint -- ) [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ; From 3ada291e8a1f2ff4902dcc095851a847999bbad6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 7 May 2008 21:37:12 -0500 Subject: [PATCH 07/22] Fix binary-trees benchmark --- extra/benchmark/binary-trees/binary-trees.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/benchmark/binary-trees/binary-trees.factor b/extra/benchmark/binary-trees/binary-trees.factor index 6e63877989..bd3d460961 100644 --- a/extra/benchmark/binary-trees/binary-trees.factor +++ b/extra/benchmark/binary-trees/binary-trees.factor @@ -53,3 +53,5 @@ M: f item-check drop 0 ; : binary-trees-main ( -- ) 16 binary-trees ; + +MAIN: binary-trees-main From 739a75f2bb7956fe7ce0b70bc7c2332c75661af5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 7 May 2008 21:39:20 -0500 Subject: [PATCH 08/22] More efficient minor GC --- core/compiler/constants/constants.factor | 1 + core/cpu/x86/intrinsics/intrinsics.factor | 6 + core/inference/known-words/known-words.factor | 2 +- core/memory/memory-docs.factor | 4 - vm/data_gc.c | 107 ++++++++++++------ vm/data_gc.h | 40 +++++-- 6 files changed, 108 insertions(+), 52 deletions(-) diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 11f64c9373..9594cf7b23 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -5,6 +5,7 @@ IN: compiler.constants ! These constants must match vm/memory.h : card-bits 6 ; +: deck-bits 12 ; : card-mark HEX: 40 HEX: 80 bitor ; ! These constants must match vm/layouts.h diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index c48f33b765..a8bcf00d15 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -63,9 +63,15 @@ IN: cpu.x86.intrinsics : generate-write-barrier ( -- ) #! Mark the card pointed to by vreg. "val" get operand-immediate? "obj" get fresh-object? or [ + ! Mark the card "obj" operand card-bits SHR "cards_offset" f temp-reg v>operand %alien-global temp-reg v>operand "obj" operand [+] card-mark OR + + ! Mark the card deck + "obj" operand deck-bits card-bits - SHR + "decks_offset" f temp-reg v>operand %alien-global + temp-reg v>operand "obj" operand [+] card-mark OR ] unless ; \ set-slot { diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index a6dd089db1..ff5fc478ca 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -372,7 +372,7 @@ M: object infer-call t over set-effect-terminated? set-primitive-effect -\ data-room { } { integer array } set-primitive-effect +\ data-room { } { integer integer array } set-primitive-effect \ data-room make-flushable \ code-room { } { integer integer integer integer } set-primitive-effect diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index 75876a3c8f..38f39ec588 100755 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -40,10 +40,6 @@ HELP: instances HELP: gc ( -- ) { $description "Performs a full garbage collection." } ; -HELP: gc-time ( -- n ) -{ $values { "n" "a timestamp in milliseconds" } } -{ $description "Outputs the total time spent in garbage collection during this Factor session." } ; - HELP: data-room ( -- cards generations ) { $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } } { $description "Queries the runtime for memory usage information." } ; diff --git a/vm/data_gc.c b/vm/data_gc.c index da112edb31..a0440b575f 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -21,10 +21,11 @@ CELL init_zone(F_ZONE *z, CELL size, CELL start) return z->end; } -void init_cards_offset(void) +void init_card_decks(void) { - cards_offset = (CELL)data_heap->cards - - (data_heap->segment->start >> CARD_BITS); + CELL start = data_heap->segment->start & ~(DECK_SIZE - 1); + cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS); + decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS); } F_DATA_HEAP *alloc_data_heap(CELL gens, @@ -62,10 +63,14 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); - CELL cards_size = total_size / CARD_SIZE; + CELL cards_size = (total_size + DECK_SIZE) / CARD_SIZE; data_heap->cards = safe_malloc(cards_size); data_heap->cards_end = data_heap->cards + cards_size; + CELL decks_size = (total_size + DECK_SIZE) / DECK_SIZE; + data_heap->decks = safe_malloc(decks_size); + data_heap->decks_end = data_heap->decks + decks_size; + CELL alloter = data_heap->segment->start; alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter); @@ -105,6 +110,7 @@ void dealloc_data_heap(F_DATA_HEAP *data_heap) free(data_heap->generations); free(data_heap->semispaces); free(data_heap->cards); + free(data_heap->decks); free(data_heap); } @@ -113,17 +119,28 @@ cleared when a generation has been cleared */ void clear_cards(CELL from, CELL to) { /* NOTE: reverse order due to heap layout. */ + F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start); F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end); - F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[to].start); - for(; ptr < last_card; ptr++) - clear_card(ptr); + F_CARD *ptr; + for(ptr = first_card; ptr < last_card; ptr++) + *ptr = CARD_BASE_MASK; /* invalid value */ +} + +void clear_decks(CELL from, CELL to) +{ + /* NOTE: reverse order due to heap layout. */ + F_CARD *first_deck = ADDR_TO_CARD(data_heap->generations[to].start); + F_CARD *last_deck = ADDR_TO_CARD(data_heap->generations[from].end); + F_CARD *ptr; + for(ptr = first_deck; ptr < last_deck; ptr++) + *ptr = 0; } void set_data_heap(F_DATA_HEAP *data_heap_) { data_heap = data_heap_; nursery = data_heap->generations[NURSERY]; - init_cards_offset(); + init_card_decks(); clear_cards(NURSERY,TENURED); } @@ -141,13 +158,16 @@ void init_data_heap(CELL gens, extra_roots_region = alloc_segment(getpagesize()); extra_roots = extra_roots_region->start - CELLS; - gc_time = 0; - aging_collections = 0; + nursery_gc_time = 0; nursery_collections = 0; + aging_gc_time = 0; + aging_collections = 0; + tenured_gc_time = 0; tenured_collections = 0; - cards_checked = 0; cards_scanned = 0; + decks_scanned = 0; code_heap_scans = 0; + bytes_copied = 0; secure_gc = secure_gc_; } @@ -231,6 +251,7 @@ DEFINE_PRIMITIVE(data_room) int gen; dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10)); + dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10)); for(gen = 0; gen < data_heap->gen_count; gen++) { @@ -293,9 +314,9 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here) if(offset == CARD_BASE_MASK) { - if(c == 0xff) + /* if(c == 0xff) critical_error("bad card",(CELL)ptr); - else + else */ return; } @@ -308,23 +329,18 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here) cards_scanned++; } -void collect_card_deck(CELL gen, - F_CARD *first_card, F_CARD *last_card, - F_CARD mask, F_CARD unmask) +void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) { - CELL here = data_heap->generations[gen].here; + F_CARD *first_card = DECK_TO_CARD(deck); + F_CARD *last_card = DECK_TO_CARD(deck + 1); - long long cards_checked_ = 0; + CELL here = data_heap->generations[gen].here; u32 *quad_ptr; u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24); - u32 *last_card_aligned = (u32 *)(((CELL)last_card + 3) & ~3); - - for(quad_ptr = (u32 *)first_card; quad_ptr <= (u32 *)last_card_aligned; quad_ptr++) + for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++) { - cards_checked_ += 4; - if(*quad_ptr & quad_mask) { F_CARD *ptr = (F_CARD *)quad_ptr; @@ -341,14 +357,14 @@ void collect_card_deck(CELL gen, } } - cards_checked += cards_checked_; + decks_scanned++; } /* Copy all newspace objects referenced from marked cards to the destination */ void collect_gen_cards(CELL gen) { - F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[gen].start); - F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[gen].here - 1); + F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start); + F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end); F_CARD mask, unmask; @@ -398,7 +414,16 @@ void collect_gen_cards(CELL gen) return; } - collect_card_deck(gen,first_card,last_card,mask,unmask); + F_DECK *ptr; + + for(ptr = first_deck; ptr < last_deck; ptr++) + { + if(*ptr & mask) + { + collect_card_deck(ptr,gen,mask,unmask); + *ptr &= ~unmask; + } + } } /* Scan cards in all generations older than the one being collected, copying @@ -485,6 +510,7 @@ INLINE void *copy_untagged_object(void *pointer, CELL size) longjmp(gc_jmp,1); allot_barrier(newspace->here); newpointer = allot_zone(newspace,size); + bytes_copied += size; memcpy(newpointer,pointer,size); return newpointer; } @@ -615,6 +641,7 @@ CELL collect_next(CELL scan) INLINE void reset_generation(CELL i) { F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]); + bytes_collected += (z->here - z->start); z->here = z->start; if(secure_gc) memset((void*)z->start,69,z->size); @@ -669,7 +696,7 @@ void begin_gc(CELL requested_bytes) #endif } -void end_gc(void) +void end_gc(CELL gc_elapsed) { if(growing_data_heap) { @@ -689,11 +716,13 @@ void end_gc(void) if(collecting_gen == TENURED) { tenured_collections++; + tenured_gc_time += gc_elapsed; GC_PRINT(END_AGING_GC,aging_collections,cards_scanned); } else if(HAVE_AGING_P && collecting_gen == AGING) { aging_collections++; + aging_gc_time += gc_elapsed; GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned); } } @@ -704,6 +733,7 @@ void end_gc(void) reset_generations(NURSERY,collecting_gen); nursery_collections++; + nursery_gc_time += gc_elapsed; } if(collecting_gen == TENURED) @@ -802,9 +832,8 @@ void garbage_collection(CELL gen, CELL gc_elapsed = (current_millis() - start); GC_PRINT(END_GC,gc_elapsed); - end_gc(); + end_gc(gc_elapsed); - gc_time += gc_elapsed; performing_gc = false; } @@ -826,15 +855,19 @@ DEFINE_PRIMITIVE(gc) /* Push total time spent on GC */ DEFINE_PRIMITIVE(gc_stats) { - CELL array = tag_object(allot_array(ARRAY_TYPE,7,F)); + CELL array = tag_object(allot_array(ARRAY_TYPE,11,F)); REGISTER_ROOT(array); - set_array_nth(untag_object(array),0,tag_bignum(long_long_to_bignum(gc_time))); + set_array_nth(untag_object(array),0,allot_cell(nursery_gc_time)); set_array_nth(untag_object(array),1,allot_cell(nursery_collections)); - set_array_nth(untag_object(array),2,allot_cell(aging_collections)); - set_array_nth(untag_object(array),3,allot_cell(tenured_collections)); - set_array_nth(untag_object(array),4,tag_bignum(long_long_to_bignum(cards_scanned))); - set_array_nth(untag_object(array),5,tag_bignum(long_long_to_bignum(cards_checked))); - set_array_nth(untag_object(array),6,allot_cell(code_heap_scans)); + set_array_nth(untag_object(array),2,allot_cell(aging_gc_time)); + set_array_nth(untag_object(array),3,allot_cell(aging_collections)); + set_array_nth(untag_object(array),4,allot_cell(tenured_gc_time)); + set_array_nth(untag_object(array),5,allot_cell(tenured_collections)); + set_array_nth(untag_object(array),6,tag_bignum(long_long_to_bignum(cards_scanned))); + set_array_nth(untag_object(array),7,tag_bignum(long_long_to_bignum(decks_scanned))); + set_array_nth(untag_object(array),8,allot_cell(code_heap_scans)); + set_array_nth(untag_object(array),9,tag_bignum(long_long_to_bignum(bytes_copied))); + set_array_nth(untag_object(array),10,tag_bignum(long_long_to_bignum(bytes_collected))); UNREGISTER_ROOT(array); dpush(array); } diff --git a/vm/data_gc.h b/vm/data_gc.h index 1b42eafb36..149c55d97f 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -46,6 +46,9 @@ typedef struct { CELL *cards; CELL *cards_end; + + CELL *decks; + CELL *decks_end; } F_DATA_HEAP; F_DATA_HEAP *data_heap; @@ -71,17 +74,27 @@ offset within the card */ #define CARD_BITS 6 #define ADDR_CARD_MASK (CARD_SIZE-1) -INLINE void clear_card(F_CARD *c) -{ - *c = CARD_BASE_MASK; /* invalid value */ -} - DLLEXPORT CELL cards_offset; -void init_cards_offset(void); #define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset) #define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> DECK_BITS) + decks_offset) +#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset)< Date: Wed, 7 May 2008 21:54:41 -0500 Subject: [PATCH 09/22] Fixes --- extra/tools/memory/memory.factor | 1 + extra/tools/time/time-docs.factor | 12 ++---------- extra/tools/time/time.factor | 22 +++++++++++++--------- 3 files changed, 16 insertions(+), 19 deletions(-) diff --git a/extra/tools/memory/memory.factor b/extra/tools/memory/memory.factor index b8fdcab280..9628b218e9 100644 --- a/extra/tools/memory/memory.factor +++ b/extra/tools/memory/memory.factor @@ -36,6 +36,7 @@ IN: tools.memory [ first2 ] [ number>string "Generation " prepend ] bi* write-total/used/free ] 2each + "Decks" write-total "Cards" write-total ; : write-labelled-size ( n string -- ) diff --git a/extra/tools/time/time-docs.factor b/extra/tools/time/time-docs.factor index 46d356bef5..c0afa920c4 100644 --- a/extra/tools/time/time-docs.factor +++ b/extra/tools/time/time-docs.factor @@ -20,14 +20,6 @@ HELP: benchmark HELP: time { $values { "quot" "a quotation" } } -{ $description "Runs a quotation and then prints the total run time and time spent in the garbage collector." } -{ $examples - "This word can be used to compare performance of the non-optimizing and optimizing compilers." - $nl - "First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:" - { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] time" "1116 ms run / 6 ms GC time" } - "Now we define a word and compile it with the optimizing word compiler. This results is faster execution:" - { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] time" "202 ms run / 13 ms GC time" } -} ; +{ $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ; -{ gc-time benchmark millis time } related-words +{ benchmark millis time } related-words diff --git a/extra/tools/time/time.factor b/extra/tools/time/time.factor index 3ddea1b74d..bca5e3c573 100644 --- a/extra/tools/time/time.factor +++ b/extra/tools/time/time.factor @@ -9,15 +9,19 @@ IN: tools.time : stats. ( data -- ) { - "Run time" - "GC time" - "Nursery collections" - "Aging collections" - "Tenured collections" - "Cards checked" - "Cards scanned" - "Code literal collections" - } swap zip [ nip 0 > ] assoc-filter + "Run time (ms):" + "Nursery GC time (ms):" + "Nursery GC #:" + "Aging GC time (ms):" + "Aging GC #:" + "Tenured GC time (ms):" + "Tenured GC #:" + "Cards scanned:" + "Decks scanned:" + "Code literal GC #:" + "Bytes copied:" + "Bytes collected:" + } swap zip standard-table-style [ [ [ From 052962d3b8dd9d5ea37bf515965f56c03421688e Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 8 May 2008 13:04:44 +1000 Subject: [PATCH 10/22] jamshred is playable! (scroll to acc/decelerate) --- extra/jamshred/jamshred.factor | 13 +++++++++---- extra/jamshred/player/player.factor | 21 ++++++++++++++------- extra/jamshred/tunnel/tunnel.factor | 4 +++- 3 files changed, 26 insertions(+), 12 deletions(-) diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index bdec1e57e5..44dcdc8659 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.log kernel math math.constants namespaces sequences threads ui ui.gadgets ui.gestures ui.render math.vectors ; +USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.gadgets ui.gestures ui.render math.vectors ; IN: jamshred TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; @@ -8,8 +8,8 @@ TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; : ( jamshred -- gadget ) jamshred-gadget construct-gadget swap >>jamshred ; -: default-width ( -- x ) 640 ; -: default-height ( -- y ) 480 ; +: default-width ( -- x ) 800 ; +: default-height ( -- y ) 600 ; M: jamshred-gadget pref-dim* drop default-width default-height 2array ; @@ -23,7 +23,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) ] [ dup [ jamshred>> jamshred-update ] [ relayout-1 ] bi - 50 sleep jamshred-loop + 10 sleep jamshred-loop ] if ; M: jamshred-gadget graft* ( gadget -- ) @@ -57,10 +57,15 @@ M: jamshred-gadget ungraft* ( gadget -- ) ] [ 2drop ] if* ] 2keep >>last-hand-loc drop ; +: handle-mouse-scroll ( jamshred-gadget -- ) + jamshred>> jamshred-player scroll-direction get + second neg swap change-player-speed ; + jamshred-gadget H{ { T{ key-down f f "r" } [ jamshred-restart ] } { T{ key-down f f " " } [ jamshred>> toggle-running ] } { T{ motion } [ handle-mouse-motion ] } + { T{ mouse-scroll } [ handle-mouse-scroll ] } } set-gestures : jamshred-window ( -- ) diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 979ad136d3..1ff73d51e4 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,12 +1,17 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences system ; +USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order math.ranges sequences system ; IN: jamshred.player -TUPLE: player < oint name tunnel nearest-segment last-move ; +TUPLE: player < oint name tunnel nearest-segment last-move speed ; + +! speeds are in GL units / second +: default-speed ( -- speed ) 1.0 ; +: max-speed ( -- speed ) 10.0 ; : ( name -- player ) - [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f f player boa ; + [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip + f f f default-speed player boa ; : turn-player ( player x-radians y-radians -- ) >r over r> left-pivot up-pivot ; @@ -23,13 +28,15 @@ TUPLE: player < oint name tunnel nearest-segment last-move ; [ (>>nearest-segment) ] tri ; : moved ( player -- ) millis swap (>>last-move) ; -: max-speed ( -- speed ) 1.0 ; ! units/second -: player-speed ( player -- speed ) - drop max-speed ; +: speed-range ( -- range ) + max-speed [0,b] ; + +: change-player-speed ( inc player -- ) + [ + speed-range clamp-to-range ] change-speed drop ; : distance-to-move ( player -- distance ) - [ player-speed ] [ last-move>> millis dup >r swap - 1000 / * r> ] + [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ] [ (>>last-move) ] tri ; DEFER: (move-player) diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 4369944e9e..139cdbfb53 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -137,7 +137,9 @@ C: segment [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ; : bounce-left ( segment oint -- ) - [ forward>> vneg ] dip [ left>> swap reflect ] [ (>>left) ] bi ; + #! must be done after forward + [ forward>> vneg ] dip [ left>> swap reflect ] + [ forward>> proj-perp normalize ] [ (>>left) ] tri ; : bounce-up ( segment oint -- ) #! must be done after forward and left! From 22a9a8b95e75d6f648a2729bd605545101c85ebd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 7 May 2008 23:09:18 -0500 Subject: [PATCH 11/22] More improvements to 'time' word --- extra/tools/time/time.factor | 58 +++++++++++------ vm/data_gc.c | 121 +++++++++++++++++++---------------- vm/data_gc.h | 20 +++--- vm/primitives.c | 1 + 4 files changed, 116 insertions(+), 84 deletions(-) diff --git a/extra/tools/time/time.factor b/extra/tools/time/time.factor index bca5e3c573..0a0121c74e 100644 --- a/extra/tools/time/time.factor +++ b/extra/tools/time/time.factor @@ -1,36 +1,54 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.vectors memory io io.styles prettyprint -namespaces system sequences assocs ; +namespaces system sequences splitting assocs strings ; IN: tools.time : benchmark ( quot -- gctime runtime ) millis >r call millis r> - ; inline -: stats. ( data -- ) - { - "Run time (ms):" - "Nursery GC time (ms):" - "Nursery GC #:" - "Aging GC time (ms):" - "Aging GC #:" - "Tenured GC time (ms):" - "Tenured GC #:" - "Cards scanned:" - "Decks scanned:" - "Code literal GC #:" - "Bytes copied:" - "Bytes collected:" - } swap zip +: simple-table. ( values -- ) standard-table-style [ [ [ - [ [ write ] with-cell ] [ pprint-cell ] bi* + [ + dup string? + [ [ write ] with-cell ] + [ pprint-cell ] + if + ] each ] with-row - ] assoc-each + ] each ] tabular-output ; -: stats gc-stats millis prefix ; +: time. ( data -- ) + unclip + "==== RUNNING TIME" print nl pprint " ms" print nl + 4 cut* + "==== GARBAGE COLLECTION" print nl + [ + 6 group + { + "GC count:" + "Cumulative GC time (ms):" + "Longest GC pause (ms):" + "Average GC pause (ms):" + "Objects copied:" + "Bytes copied:" + } prefix + flip + { "" "Nursery" "Aging" "Tenured" } prefix + simple-table. + ] + [ + nl + { + "Total GC time (ms):" + "Cards scanned:" + "Decks scanned:" + "Code heap literal scans:" + } swap zip simple-table. + ] bi* ; : time ( quot -- ) - stats >r call stats r> v- stats. ; inline + gc-reset millis >r call gc-stats millis r> - prefix time. ; inline diff --git a/vm/data_gc.c b/vm/data_gc.c index a0440b575f..aed2cef4d1 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -144,6 +144,13 @@ void set_data_heap(F_DATA_HEAP *data_heap_) clear_cards(NURSERY,TENURED); } +void gc_reset(void) +{ + int i; + for(i = 0; i < MAX_GEN_COUNT; i++) + memset(&gc_stats[i],0,sizeof(F_GC_STATS)); +} + void init_data_heap(CELL gens, CELL young_size, CELL aging_size, @@ -158,17 +165,13 @@ void init_data_heap(CELL gens, extra_roots_region = alloc_segment(getpagesize()); extra_roots = extra_roots_region->start - CELLS; - nursery_gc_time = 0; - nursery_collections = 0; - aging_gc_time = 0; - aging_collections = 0; - tenured_gc_time = 0; - tenured_collections = 0; + secure_gc = secure_gc_; + + gc_reset(); + cards_scanned = 0; decks_scanned = 0; code_heap_scans = 0; - bytes_copied = 0; - secure_gc = secure_gc_; } /* Size of the object pointed to by a tagged pointer */ @@ -312,21 +315,16 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here) F_CARD c = *ptr; CELL offset = (c & CARD_BASE_MASK); - if(offset == CARD_BASE_MASK) + if(offset != CARD_BASE_MASK) { - /* if(c == 0xff) - critical_error("bad card",(CELL)ptr); - else */ - return; + CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset; + CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); + + while(card_scan < card_end && card_scan < here) + card_scan = collect_next(card_scan); + + cards_scanned++; } - - CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset; - CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); - - while(card_scan < card_end && card_scan < here) - card_scan = collect_next(card_scan); - - cards_scanned++; } void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) @@ -510,7 +508,11 @@ INLINE void *copy_untagged_object(void *pointer, CELL size) longjmp(gc_jmp,1); allot_barrier(newspace->here); newpointer = allot_zone(newspace,size); - bytes_copied += size; + + F_GC_STATS *s = &gc_stats[collecting_gen]; + s->object_count++; + s->bytes_copied += size; + memcpy(newpointer,pointer,size); return newpointer; } @@ -641,7 +643,7 @@ CELL collect_next(CELL scan) INLINE void reset_generation(CELL i) { F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]); - bytes_collected += (z->here - z->start); + z->here = z->start; if(secure_gc) memset((void*)z->start,69,z->size); @@ -652,7 +654,9 @@ their allocation pointers and cards reset. */ void reset_generations(CELL from, CELL to) { CELL i; - for(i = from; i <= to; i++) reset_generation(i); + for(i = from; i <= to; i++) + reset_generation(i); + clear_cards(from,to); } @@ -698,6 +702,13 @@ void begin_gc(CELL requested_bytes) void end_gc(CELL gc_elapsed) { + F_GC_STATS *s = &gc_stats[collecting_gen]; + + s->collections++; + s->gc_time += gc_elapsed; + if(s->max_gc_time < gc_elapsed) + s->max_gc_time = gc_elapsed; + if(growing_data_heap) { dealloc_data_heap(old_data_heap); @@ -712,28 +723,12 @@ void end_gc(CELL gc_elapsed) old-school Cheney collector */ if(collecting_gen != NURSERY) reset_generations(NURSERY,collecting_gen - 1); - - if(collecting_gen == TENURED) - { - tenured_collections++; - tenured_gc_time += gc_elapsed; - GC_PRINT(END_AGING_GC,aging_collections,cards_scanned); - } - else if(HAVE_AGING_P && collecting_gen == AGING) - { - aging_collections++; - aging_gc_time += gc_elapsed; - GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned); - } } else { /* all generations up to and including the one collected are now empty */ reset_generations(NURSERY,collecting_gen); - - nursery_collections++; - nursery_gc_time += gc_elapsed; } if(collecting_gen == TENURED) @@ -852,24 +847,38 @@ DEFINE_PRIMITIVE(gc) gc(); } -/* Push total time spent on GC */ DEFINE_PRIMITIVE(gc_stats) { - CELL array = tag_object(allot_array(ARRAY_TYPE,11,F)); - REGISTER_ROOT(array); - set_array_nth(untag_object(array),0,allot_cell(nursery_gc_time)); - set_array_nth(untag_object(array),1,allot_cell(nursery_collections)); - set_array_nth(untag_object(array),2,allot_cell(aging_gc_time)); - set_array_nth(untag_object(array),3,allot_cell(aging_collections)); - set_array_nth(untag_object(array),4,allot_cell(tenured_gc_time)); - set_array_nth(untag_object(array),5,allot_cell(tenured_collections)); - set_array_nth(untag_object(array),6,tag_bignum(long_long_to_bignum(cards_scanned))); - set_array_nth(untag_object(array),7,tag_bignum(long_long_to_bignum(decks_scanned))); - set_array_nth(untag_object(array),8,allot_cell(code_heap_scans)); - set_array_nth(untag_object(array),9,tag_bignum(long_long_to_bignum(bytes_copied))); - set_array_nth(untag_object(array),10,tag_bignum(long_long_to_bignum(bytes_collected))); - UNREGISTER_ROOT(array); - dpush(array); + GROWABLE_ARRAY(stats); + + CELL i; + CELL total_gc_time = 0; + + for(i = 0; i < MAX_GEN_COUNT; i++) + { + F_GC_STATS *s = &gc_stats[i]; + GROWABLE_ADD(stats,allot_cell(s->collections)); + GROWABLE_ADD(stats,allot_cell(s->gc_time)); + GROWABLE_ADD(stats,allot_cell(s->max_gc_time)); + GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); + GROWABLE_ADD(stats,allot_cell(s->object_count)); + GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied))); + + total_gc_time += s->gc_time; + } + + GROWABLE_ADD(stats,allot_cell(total_gc_time)); + GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned))); + GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned))); + GROWABLE_ADD(stats,allot_cell(code_heap_scans)); + + GROWABLE_TRIM(stats); + dpush(stats); +} + +DEFINE_PRIMITIVE(gc_reset) +{ + gc_reset(); } DEFINE_PRIMITIVE(become) diff --git a/vm/data_gc.h b/vm/data_gc.h index 149c55d97f..c1023b8043 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -138,6 +138,8 @@ void collect_cards(void); /* the oldest generation */ #define TENURED (data_heap->gen_count-1) +#define MAX_GEN_COUNT 3 + /* used during garbage collection only */ F_ZONE *newspace; @@ -158,16 +160,17 @@ void init_data_heap(CELL gens, bool secure_gc_); /* statistics */ -CELL nursery_gc_time; -CELL nursery_collections; -CELL aging_gc_time; -CELL aging_collections; -CELL tenured_gc_time; -CELL tenured_collections; +typedef struct { + CELL collections; + CELL gc_time; + CELL max_gc_time; + CELL object_count; + u64 bytes_copied; +} F_GC_STATS; + +F_GC_STATS gc_stats[MAX_GEN_COUNT]; u64 cards_scanned; u64 decks_scanned; -u64 bytes_copied; -u64 bytes_collected; CELL code_heap_scans; /* only meaningful during a GC */ @@ -388,6 +391,7 @@ CELL collect_next(CELL scan); DECLARE_PRIMITIVE(gc); DECLARE_PRIMITIVE(gc_stats); +DECLARE_PRIMITIVE(gc_reset); DECLARE_PRIMITIVE(become); CELL find_all_words(void); diff --git a/vm/primitives.c b/vm/primitives.c index cc8cf61013..133ca38567 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -186,4 +186,5 @@ void *primitives[] = { primitive_resize_float_array, primitive_dll_validp, primitive_unimplemented, + primitive_gc_reset, }; From 28d7fc37b87e57d5c7314a2fd2f9af8326fed8c0 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 8 May 2008 17:41:49 +1000 Subject: [PATCH 12/22] jamshred: attempts at deployment, bangs on hitting the wall --- extra/jamshred/deploy.factor | 12 ++++++++++++ extra/jamshred/game/game.factor | 8 ++++---- extra/jamshred/jamshred.factor | 19 +++++++++++++++++-- extra/jamshred/player/player.factor | 13 +++++++------ extra/jamshred/sound/bang.wav | Bin 0 -> 20460 bytes extra/jamshred/sound/sound.factor | 13 +++++++++++++ 6 files changed, 53 insertions(+), 12 deletions(-) create mode 100644 extra/jamshred/deploy.factor create mode 100644 extra/jamshred/sound/bang.wav create mode 100644 extra/jamshred/sound/sound.factor diff --git a/extra/jamshred/deploy.factor b/extra/jamshred/deploy.factor new file mode 100644 index 0000000000..9a18cf1f9b --- /dev/null +++ b/extra/jamshred/deploy.factor @@ -0,0 +1,12 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { deploy-name "Jamshred" } +} diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index e187d26a17..dcb82d1de0 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.tunnel math.vectors ; +USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math.vectors ; IN: jamshred.game -TUPLE: jamshred tunnel players running quit ; +TUPLE: jamshred sounds tunnel players running quit ; : ( -- jamshred ) - "Player 1" 2dup swap play-in-tunnel 1array f f - jamshred boa ; + "Player 1" pick + 2dup swap play-in-tunnel 1array f f jamshred boa ; : jamshred-player ( jamshred -- player ) ! TODO: support more than one player diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 44dcdc8659..6b305696e5 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.gadgets ui.gestures ui.render math.vectors ; +USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ; IN: jamshred TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; @@ -26,10 +26,20 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) 10 sleep jamshred-loop ] if ; +: fullscreen ( gadget -- ) + find-world t swap set-fullscreen* ; + +: no-fullscreen ( gadget -- ) + find-world f swap set-fullscreen* ; + +: toggle-fullscreen ( world -- ) + [ fullscreen? not ] keep set-fullscreen* ; + M: jamshred-gadget graft* ( gadget -- ) [ jamshred-loop ] in-thread drop ; + M: jamshred-gadget ungraft* ( gadget -- ) - jamshred>> t >>quit drop ; + jamshred>> t swap (>>quit) ; : jamshred-restart ( jamshred-gadget -- ) >>jamshred drop ; @@ -61,9 +71,14 @@ M: jamshred-gadget ungraft* ( gadget -- ) jamshred>> jamshred-player scroll-direction get second neg swap change-player-speed ; +: quit ( gadget -- ) + [ no-fullscreen ] [ close-window ] bi ; + jamshred-gadget H{ { T{ key-down f f "r" } [ jamshred-restart ] } { T{ key-down f f " " } [ jamshred>> toggle-running ] } + { T{ key-down f f "f" } [ find-world toggle-fullscreen ] } + { T{ key-down f f "q" } [ quit ] } { T{ motion } [ handle-mouse-motion ] } { T{ mouse-scroll } [ handle-mouse-scroll ] } } set-gestures diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 1ff73d51e4..bea4ab4836 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,16 +1,16 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order math.ranges sequences system ; +USING: accessors colors jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ; IN: jamshred.player -TUPLE: player < oint name tunnel nearest-segment last-move speed ; +TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; ! speeds are in GL units / second : default-speed ( -- speed ) 1.0 ; -: max-speed ( -- speed ) 10.0 ; +: max-speed ( -- speed ) 30.0 ; -: ( name -- player ) - [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip +: ( name sounds -- player ) + [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip f f f default-speed player boa ; : turn-player ( player x-radians y-radians -- ) @@ -43,7 +43,8 @@ DEFER: (move-player) : ?bounce ( distance-remaining player -- ) over 0 > [ - [ dup nearest-segment>> bounce ] [ (move-player) ] bi + [ dup nearest-segment>> bounce ] [ sounds>> bang ] + [ (move-player) ] tri ] [ 2drop ] if ; diff --git a/extra/jamshred/sound/bang.wav b/extra/jamshred/sound/bang.wav new file mode 100644 index 0000000000000000000000000000000000000000..b15af141eca5d69222fe90ae594afe407ae971a5 GIT binary patch literal 20460 zcmXB64J>r~z9zW7*Q!$Lt=DUNYuB+I$8qawS8MHRaYY*~#<i(Yz;_v@m?f=;Nzx5>B2!bH-NU0@=k`02O2piGzAA0`75%#$- zN{NtBLs+rRL2$$&5l2)IEkr7|WD@s=&v-B{jU^(3s3hi%RbvMK7ZYxygeW6)qn^ko z=7?KjljtQjh&5uB$RiqvK|&`Mi8CS_`;-zVII?UU8B@lEv1{xbE<7iVL8ISjH~I_* zv0|hVeK_)>VK!2Yd*f2yFdlK9(Qo@P#=KEx6d4`ZQfq7&bH=nWV4N6xxQ<~Q^&HO& zqs8zWl}1R9C%O#I$TU>F*9hwM21VTA8+L;sE{!9-$Vep2#0~ztB^Z3Ni2qbWH=d0{ zT-k{cz`0g%?jHQ@F_w%q!(nV1IYz0mW4MhPoN30e7y|B%Alh-4b4EOIYuGUY?{`v< z`?VA4L@Tyu5F^C0F-SZa2}A->fU`x6aol48k&DsK$Myh@)<9fgd`EERkTHv^SixNc zjVz;*NFgj3xgH{iD8Y!@Fhh3i8^UL+*pDJoamRTCg=@UWCvM}$h$9A#1|tc_PR6&V zhyna9BHhFiQHPmXC6aIreK?aJJNF;gv3f_MlnV=-|*{;7|kBs)eVjo!brB`nx=5>pplFt9^h)?iGCsu_b^5* z5FB|<6p%KmfLteB#3O929_Jq<9taD$3+tOFycmfFVge(%Pc#$fMlCT7TlN}tMzzsT zG!Z4nG2tXcV+ThK84=@wu#ps*j_)+X;_q;*L?VPe4u~53pGq9UGu#-l8T{8p%;J1K z*c!oc&oDcMF;gz%m2&u|Jv1(+R$AU_iz3G>iXX#e$Eihw|oC@)&DU(K@9!>kM(iKh(0p)zi*EX zjGrx>&rU7$|EG%8-T!#7M*OF}jg-xX|Fdzc^8ZTR7Poi)@2(x^f4=_DL%Ui3<>tS1 z?%DtA?tjhOKicp9e+mx@4txG!eLOw(9Tgrph`7J${I@m#gRgA9o%x50!JAtBAM}67 z{MUyy`ahhNJ!_fXIcLJ}^xt>?i>ZIyc8)Z6#JQ<~UsF}$zq$WO|A(%ByerR=l74dh z{=hi;NA;WWjBer?~=a^G@)esBNhwtwFJ=g>cwJd8e^KiK|M^{2T%J^sn=YH%&N zo?J)k4{cXUm;b zsT3N!`mO0auG@0|Vff>sxrbVaCL3PWtF;l<@0Qt#*pAp+o--PleDl(Wsh9=x(1-h^ z%I`}}J7)8DdVPr2w_ov)HCI8cvd+_I4Pu-V?P)cMwni{@+jgxJ` z!N5dt%i+vW4oj~(vmuW6B@7q2)K zdQvij=SGg=R?~$$y;@(5Nn%U1ZL%%Y@MY=Erg+%OxJQR2`6ziIx&HUW@4L-~rj(d# zv+%K6STF`yv+fZybw7KA5#B#?K*Ic{nX~#^K86Kyr%l^1C7yC zy+Q9Xc9mm8Cpb#}lKkb-HTf{+PJb@*4@i^B)Yk)dUT{upcnwIsoT}{6?znrQmB}JP z(F?jSW+MJsaDKWmSH}36h+G=V3FZ0j{S6-9KX?2&@MYzfJMXD?;MYg*`GfmsF*x|T z8g3@m^lQ}_jVKo1sZztbxE@P9*UlGli{z4WWND92O(^|7JH9ueDpvo#QRbKN`(@_WqHswxJ?srHz3qk4f^FebZB98;mb5W{Rb(`B`!!CQH_XZ+Bb%IR zYII&Z(QkQMO!bEm+fLj}?AoX54|!~qe zYjICPk;QLMviWSc34_ULiO0WjBv(5cVrKM1Df?|Ha2Z~Uo~uE!Tuvd&qMTZzj;fpF zhBi$033=wSn1YXv__@zdKU{pSh#UTJM(@+lLixu$TcIuGw_S0RWih5McK*X*{O#x7 z-#sM?@pZN$x6yeyJ6i8c z{i*hT`+oK^^S=lG(DzW`8ho1jx##ESKVJQ5=||@uY_2s=%`Z#-fl%7h^82I;#~0LwIejF4=RUbHoc+NQ!`vLxoX(86y}T@)(iDgdWs1e9sDg{i=&9V z$kZ5Jbe=pwmzn1nm0RHM7>+J84RX^=H<8A6MyptlUdXJAjjvR+ELg9u64~6ju>Rf6 z$Bvj3HlXgvJ^G_5ThN6Q;egqquZ?|W#;8~OBdgk=u+3$gu9#DLQqEJaxl>}Bx-)9D za=L_hWS?SsO%9<`7^e@6F@2huqb}ITnBABmQ^4G3tzf6ROXH_2 z$La5HQr&-%YhRA5{ZJd5W44;hOtT-x6Q>g!Kh=ER|Gx9Hm>Bm%hke13@I$6u{!Q-h zcAPhVCI5B*UluzLlIK20Vh5NwCJ^I|7vr$3m|Jtb zw#uEx7IIEgJRdM02^ZGh58M2hdCxZXx%4le|K-?UdYxB)nVnSsgD3epnfMoLf5l~; zIfK6y?WaGaB-j4My3?Cd=%`A_j&sF7f4B3o-) z50!;i1EUdlF!z_EUzh!v{)u02yt6;$JeEE>e{BBo^rw!;ygya_;q(voyV;*=0%PIl zS4(guyeE47y}|gD@o7ala_4C@-b6@^1n}ItY6^IKQz1(=Ke_eK`e5w5P{CV%i5y|$;&)p$=usGoG z&p%&$34ZB%8u@dAtMSjmPsdN|?zE@uKb8Es`*Hi}(x3X8^<~yG>OFAR{B-T*eD`0s z-zvm?H7J&Ty?(8G&G7F0I`4mcS$i#bOZZY5nttsHI70_t?|xqL_WttZ9}gACjH;5B zj{~1(tXmcrGs>oD=BV&C`EupW@>#z$2CgD!N}SrK&&W2VQ$J&y*$dLIJZW~#7xqN$ z%D(21lZ;knE&43wtCtaX`2I}})IQIA$%tCR<>5BX$7XAH+Ku8+S|c0Mww$P3$nDAy zGhx)KdsHFK5gnlG7X4JU>t)OtwFyphMm7kSv9p%U?}~ot_^!zov~1H$MweWst|`^v zKzT+)UoqCzIO04s5K58F+K}-~) zC2rfAhFn}qEl}n3jma6eZC^2MjeO_)&Gz?wKg^|`{>zMv@l?z2j(>1EsvMX0%Wk~K zR9ihJ!E_Ykj@jjw_-S(o*Cn(HLQIimH}>g+Ze5RQv~1F4l+~1G8UN5`J>|0aMpK5c zXPGwTn+blx5^vdyRgtmFOqG@k>jFP#-ZU=?S4OIqqXqSK;+#6xvgKa2QL}?{_KN=3 z8Go5?>N)T_?RS6K4HZV6f!?pjuW7-jx58kVSf@P`ZRWC%+vW_$EHLJp59J?6;x9kU zeelIu?7knCe^~#)gJ^ES81Op~ipqY)%M{Ao?T@LsuME4???#6b$v>*)bhKgxtMIuOEpku z=@}G^b)UuJvxU+t^_$_y*IO#rmPe>?4vyv*?LVgxB9HB1hqAsZo4* z8-Kfa+j<%MlJd17u<_;(ZA&TPO0hC}|8^q9!#|4k3%Y<9P#?rZNmY;J(Qt!29xnB- zyq1N^-v-0Nn=i5!=@fUh6LCqNF>#R#SkLiw?jGeG-TPHu<^I0EOJ|$Yx zOhLiP_47?!BKgd3@SRKoTTa%=&(cmfC%6&%+Iq1;JDY9exSoZiAtab|s7Y?v|hWeqMP@a3}xT z?|%N#>~(&*^koDF!n@&)x96bw<;?%^a`}AqJo#((m%Ko2U^kfccKVtXdJgUe(_hnG zpWbqU^?~x&$(L&1R$wJE5`KK03#5eXZ{FA0x2@2F+@==FeX5m8Ags(jUCOqD0hCBR z(N4Kmnbm5EBV%7X*HV-`t$|hrGpuu)X@d&o;DYp_>C`mMRO@?MadaX&FPS43k#!@U z+9EF1W@$Av^2S6DLS>5PrAPA;UgDS!m`koE34(5vLqIIH8 zebQ}&E$Vt3h-600p@E<~*z_8D-HUEX#cHBH4HapYZYB1OWOjxuR34;;Xu+!-DUlZ< zBQF`h9RHm9%fxflTkqRWq*5Dze&@tY$iddPvB2tUY9PbE6P$Q0^soCay}D=N=fa=b z-4=K8&)hF#o;LTv&!fJhm!q#9KNCpt)dhrCA{Y=)aA$2%;%z7F5@*7bZ?4EO*g{cA zj%KRsYP-5EFDmE80%tKhVs~w07AmGPb{?T7jnLH@-AVPRoB9Pgr=IEAR14W?TxlM8 zPVI=UNZ0y}m>kWKtia;s;q*v-)EzDqXQVZ8GjtZ7kxO7F<$4y~#}twIdMmJ=!+2J! zJ(GiBT+UyNwC$ZwgfF+p=2m(6fTh1)Su>~KTu?Mj^)?6zWt6F^4Y}@2_SN1;p*r$Elg>XnasY|ZF z)NQG@WLbtR^RW-+5iW;c;5Rr6yTV2(>81n0!)L}c z#+=#uV#iF`yo++^jJ6^*MVM%rTt}Rery6CXlDn!`^&3tiQSVn)#8G)q3#lb~r+%w< z>FK&h-BvrKbTt6`oKXwaR`DiO8Y&Sd;#l>*eUJF_IoB ziK@z#oGh2iPSGyU>n&s(bIb4W$LtWR6CLEJDS>-p^_XYYMITaW#-es8Hi}bnn^dG_ zsJnWb5)AJ}=0YiN@ox{W7k=W)?XT@GRe}4r_P6Yy`7Jm66l#0f{5s(4eIEWI_*-7Z zmka+c@ZjJVU!YNJP-iqNc|fI7GU=yIgd5YGX(%SgvSQj5Mq>ueDsL5JrkXyW)}d6F zlTK13+~gFOXg-ClyG#e>km=5Jz}a~VGs{d1{pJf{nAtJzj1%Hi8&>PpF{w$uGWy9J zZPZvIJE;pMo%adX$mIvN;<%iT!I%!PlRkdkGH^N;>*4YDYpKfMl zcACkeUF1Cx)Z2|?IZsZKIpmExbwj^_Puq=3ZArb=n)DWRP0yqWev(^ZUlL9%x zotKT5i@?C!cBE68)H4i^@x*vcd9hR0qEB<*B_>pTUQ3wx)bp_!camc*j2#r*=2S~n zOrm)vCRcd(`4HXAYy&&oQnQ3p$rqcX2FWeWBjPQoqT*9~)g9fd9cr?+pzkP)`W<1@ zH?=L&L8^qEDxxghAbSNbiV%Z(zqV!E>LsYWTxs*799;-qMRFnoQolN+-vj$47(O{u zy-;(NEwM3di&Ve0hwG$+=vKrLafWt+hi`h+qRmnX^sQ+!CfRatO5hK9mr%f!upC(< z`6Y`~6gdf%gw!{C_&QYac8%CXQkLEFxvGAbx+SU`qgQ9O&wPvl1r*q zij`a`2iWOIE>uUfbkaeu6IoOiT|%rGllqlPNsFQ?Ii=@lk8~muG8JtNtp!Jeu3$p2 z=*<%Kh`QJYFIbX;6gYLph`LTyl?0fLou>#0x|pCgaq(qQXr#oKPME;tq%7B}U3okJAA zBeRK4qexv=eA*~EOU2XIR3TMPT~JeGt(Kr*mep3}P}3zs62wJuE1WA+`i(wS=xU`JDFlO!0t1LY(6{4 zIB0og6S?J@PSQx-Sh1-93~%uV<%w?Ri(Ctt(#5=Z(eGA3md z>DNlS>QtsBkCI6w>#alz(?gdrrOXUBV>&T+#Abask6E=m#*A_e%mQ1^w+i)ql90qN z30K0EdC@$_X9)#-1JuVh`jOb8Lv%6b%0>H)Mx#Q#RN8bAwXY82m|Ri^#7k*6(i63d z<%rKrv`FlVdgUj5NDt||hEo|*7v*`y3;t_U8{{=*Q7Mnqho9v^?N+l86NE#3h;D{! zLwmu_z=LnwH}bOmYI)lX1pOZWq2KJ^`nurH4&=Oaybv$hugih+*Sv6AWHl^CkHW<` zXP-Q1oY3R+E!9e*mPr;7J^Gz)1|CdSl5|d47e}Nz$u1?S9Ym1KM6L)@gH(WOr*qf~ zwwT-Hy}Z>_z@wgG$}>f{HDN}m;aj*IW`nM$os5NV5xRvEp^#7H8o_TW*(PqCt6)}{ zEcTk}qqgW|wp{RYd!|)XBO1+_<_?R?EPn`^>&y;IoVCQfEv%TB7_dXGmK&uW_yKc) zdDrAL7h4>$d9fDjh$VzdS>>%&^Twj~GE zWPO(CBr}L1x{GF*09VKLFpDh1R{>uYaYIaio}!M76SYXm*T#%C^+J>NMr~O>QifGQ z-y>U@Yt9el)h^hDK7p{Lo5%Q8Hb`5^ZmNgsCNHQhCZFZ_0`sV_02^#X&9g8j5_|t4 z#X23k_Tf2Z$ee51GwZ?@PB~ghu)&cDGoU>kM&dO^b*--%)%#2 z$qKRv_5EXA)J}j*E{p(4uobk64$@Wh0pk-qCcEI}##lE;3FoFVOQYo(%6~uG%#CyF z>@}Of7jsr-hj!EVghyLcFQlF5hIlVGDkG{}X;5r(g?uYt%LQ_k`~=Q+NF1X_q1ISZ zHxW+@5&cJi9&U*Nazig8z0@e143s-3$U-fD$ChGl&P=4xEbz&%B3f$ zQ`C$Z^4@sTFO6sIQV(ctT1Yw7dbLLNRH;yKHsuUe_$H$Sv)PCma~G9Ea9TMsP_;Uy z&7ohQ5QwjYJK^nY23O8!a{JttAo3pWncbk@yB2N@ogAhn$u=!lU6ht0ZIL7?L7D~z zm8A+5=5WWr>z+tq92w05c&#KZ9?bBc64!AbWzP#pXI%1eX*M3q#f z3D>!R$Y2g0(m-Qt9}5Q&7Z@ZE`UZkPzKgu5cP$Xz%o z5(v$Q215sLOOb`hIaIvTP+gDut~;N`Je2m4Oy3gXiJxXiYRNN<9l; z?$q=2N5iKlA<8i1dmqgRkx2&8k+F|Hl5Gw7Lwiu~)fIJAyVsYrTy0G+M2AlT?k=C) zCK{;(W|lr8d&ooTgu10ly4Kq!{Jst(hS*NDJ<#joK&Ys0@0R z@{r9`BUwhLG9z>=-OIMIZbXqLHVf}=xe;M0U5E{V-#%Md}2zxAe!GJV{v@L-xVw;03uKi%V_TQCW6c4a98p%a1N{#1YJeP|YUm+4!sPRUFl=r`ta8Nc zS`sZ=mhPBclLajFh!=TP7!sT@(-zKhgHD((b8^hOnL#FO;jXy?evixL?3|swW1pFR zCY=>eN&pbDrPjM9o#?HvLBmoP5ChLVef`%Z@=Y^*y5PoLo$@<4dIML5`e6>+$}9kVOiWyV!i>=E4FrhkfBJX z2p8-G?Eqp?$tJ3ma!@H`B2i!vx=r`%-9#VFv2{!%^vZlPNF zUfGn-q3UixV@g0&dqx(q%C+*6T=cFd$m>$Am@J+}gVC1gp;#eph^x{H;$*e#m0V(> zcpy$lE79FZUF1156Fv&hgs8BJSnUoihmXU{z~Sf712JBj6KztuJR~nG(~3))lS}2v zC>L>s3nH6{@MDq3NF|O!MdPARkqKxBJ7HTm6ec46P+wRKkB72DZDB678_ap#@u&Eg zzFK^DzUQyGe(~$m*Xgg$ukNpHFB^gTz}D;bYwzpw>u$gqPy?tIymr1`2g(AWm+}|K z%ah;huX}lTSqiiVG6F3x-TuLsfj~{5HBkM!7i}9GRx^E%-Y6dJ!0WX?|f|L}<1b zFI$0yx7yIt+d#NCvLBhlb1=Gs+%_y1VrCr5m{O^Y>RZM*`Vy_^$J+#AtE3(D4(un% zn9_65nb{1k(`8r<%1A*!;V3%jat({VuU4yb>WVg_J)k3S5__Z(Wu)IIAV=ta#tK|W zA&%98dDNlWvWO4R5G3L*d8{So8}6*AvTB2glD@r zKWg^ttea_PoV1Aj;qb#>-YnH6?brkYZ+s+m?z|we)1Zat)Dm|Hpx=* znY7TGjG4Jdzur8qqLbdEfi>wwc9C=O&B83dVwyBT9TE~v>82H7UlGJ>4pBuCKo=tW0p3HlLh;hBuyplzy6TA|)) zm7@Imp8Os4Vs=X6;6EL$R~z8(O8dq1EbJTAseFPwSYB>w*Xi)7y*ON!90z){4a#V<3;6-B$N}f*6lS#Py z8lu>+p?h@&-K*(DH5pGek$sd%U7$DMhOTCM7=h_yw!w-9n0vYyBa}erQB%|wl}|O| zm7<67St=8vC+JaT4EqLY57Uc2kZpQ|nxmd68;(@Sw6M?Y6H~>GBB!45S*T}*OeN++ z)J7}#Vp!=s&j|H`pI_p)`38QQWB6p@imPYSgmR&UUF97@H|OKpxn-b{3Pxb>k^knH zD^`U?mm%A`nGxUuGcV(tDnBPY34^9$lWe**1q8p~5nO`Vlpsv-c5amIXZ`FFn~38% z!ArY<5=yxPZiky>ZOk1k+Q+Q1@vNEkGc8OxIyj2xTl$WvXLgucR%Zgt6C*-#N$2~K z4Q-qg9y7|cF$`;G+`wHa%r$*RZWvX@xORo?QfRC}wHza?WB_)%U^MEKKBRR6x5a5* z)q$CN00s=|rBGbz^=o}a-_jF}3%q;QSG9UIRjHH{IsgRuhzCMO25>Zsk_7E2mPCxlT?}?&U>!To#}oH$gpU zM-ID{)}&*pMYiyXk|1hsz;N=-Dn^>6U~p7M}pz0Fcm%v4TTOv4Wa9h4OuiV zToD-y_lEOA7JM>>PoCbYLcO8*@I|OAlpL-M1>Um2ni7%YR>Rkk9C2Peh-OBcP#NXI zS)tjt<=}d-{Vfi<6NRHshwH%ZQ9c?xMHR)#wwL%W$+ink9CNgW{C5C>=^7Dgd|Q zjuezDlvU*RF}XqBmTcfq#pjXPGN>N1r0PH!$l^u+pHBm2#6@5As3;sC^vSq8_+5oz4aZGsA!O88=hT zhL~e~XAF^=;gX@(%k)ixA(amWWerkh&c-$*w0t;C;X(a3M}mrvQ2(?W+#7)n(#1R zAmpJ(tOdv~-)u3LfF*Di!g3wsiAj&CfW|g!o->V^4uxAG*L06Oq4LA{w$A%_2k+&I z;obGT51Da~D@8uKMIX{8m(QQ_R(P%zIVy{Dvz@pSf{#Gkd4hj=StqBn1<(-VnM}GH zz2!IbH0`9Hs5*?MgIQv2TseEk95L0*0L{^J)H&%Uw}8sqp`C3IbwG?qh|4Z$hz$Dq z3yD2q0W2v(d7#y{Q7IHd?I2_6U?p~FXewrInRHO4=!kCs2E8Q?uw{^_CPs+_vY2cH z@;t<0jfDu;+(uFvZi`V25|9vG=tf6(9ammjhGPEAy+pbyU|7SxKaO>)rs?6`?w)awWd?0EIK6*j1N$qV6lX%CmBzoGbC_ zfwG~@D!Njkwy00YeY;u_?jgtMHL{`G92gd?E>TgPt|t>Pl0}4ol_fpo2}UrHY$j*P zZBoYgJ`fCo~y8e;*?B6y=np| zMkfVw2kR$xkfF<=Q1@b8L_T>y`p8T$i%BYpZUc6xMm07OTymY|xHYznU1jfqz{=re zy=)!0aT&N>BCEsdGPxi-%zBwEW{N3-wwy)xL(iY1X24eaVR|zaNz3Wv2Fu>1gH$VwM2bDw;3tO%n8Plo~SnhuiWXP-iFm56jsFCBa7ET8}sS6 z+7$AB4N!> zX2DtW$R;4)E^?Plq>?EYSp?05p*Yl7Me+{1K^*EtC*&&G5A@nWx?nBn%As_it~6Su z?6BA#MEyf51PcnH4rZexR55A+6Z9qB$Z%{P+sSsILL6dCxKlO-nm{u52uxEA4qwI9 zAi8dI9Itb$z)N2Ck$qrm-+SK>U$>#aPJ(eTTpDGQOIBU%zvSRXkT*H$TN+0hhV?3c)Gd^P7AZR`eue zpE@8qC!f!Y+z4mkE^uX|td(^_MfX9OPDbwYGafJmU_q?L>2~$ z(kb}HFjj5VBbK~de;oWJ9T{6Ujtv>Bp=uB{Qn5P9LYxAxKVwy&8-C)2r#0%iP}kb@ zb;R}^eMEQbj&E4|Q5(``VHIZBM6t$cW9p%@qg=z5GZE#7)rjiQ1Wi`;cO0g!s;$^J zOS?ksJOENF10v5>1$6;+#wK(zq`+Gz5S44dS8U3(Yyrlblu9LCT9rzq8tDjLw}bcf zi0dhmPjbqqz;F-pjNA^Nnv)0QefU*|oCpt11VWsJpLNP+#i}sy|8pg%R4ZwUU#3vm zUW1;|j3W(76ViY*EU8i(jDmf=cIf)2j z?cl93N7RtRWGQm556C8iK8MQbr3iWk^O%neY^Kto-$ck8auJotC2|vfKAn7ga;eQvFc3Mv((1s5EL3_jE%hAaiWty343c ztX>*G2AiWSV42IvC*81GC+^3KqcgM}UVj9A>l9~iz@6`4Bnpr(Y=|y#VDGEYKiq^2 zCO1xwVw{E%ZyLyFjPn6>kazsy!r12%%UDr4PxygPZ%~zNc&~ba>8V(ax&CcErW0#F z=g=KBkJX`eC@YVcuXC(28HA3Rgtd+<@PZ_LP3r`2O-Ec55Jz*sQx{Q5l;ZNJxt5AK0eeMCjG%M+_WgB{qtK@uWbR)O3nPB4) zAeM3*r3kr920F@VF$*^K*cN%5h@*+h$BN}4mk6&d}tJn%4sU|j+Erj~2Gfwst%zTZJ89VF4b*8YJ z&=6K})yIq#t4Q+ERe45dp{ppL$)``?neFi1Qn~_ny#X(rqz7R6wTK0a@Rd5~Q(IV# zO%S`rn9+@O#M7|cJ)rDKXu+NMdk9rH7dU(qcG(UL?nI4#Os~@I`ka=cb%QBaLlZg1 zY|g6r>aMb;3T#+>My zn3K|_T4_RT2G&Uz3(z@|fjU-`$VlfvM$2HN9a26zRUA@C42qRf8s1q@b=((=(H-mt zvo02^pg(Vl5mdO=#49`(#Zx@SMZ1_Hwu%*Er+6lEQU`hy`w+8F&rzwAh2sG z0-Q4r)U%Ce2O@Y8u5b!|a1ARThc=+&ZkCjO+}$j!eG2zkk2{G&9;gO3DuoYa1ADm? zH+m_$pb@o0Kj??At-SAdq!K`V(?)71nF_V_WXGHSX_`r3owJE3uCI z2|0p!uMHti)nW~E2tCS&$k7~DqwhdTEG7q`Bw7)H%Ymc=R3+AV9nzb?;+u%?H|T86 zWJ;g~p{m17Bf_ULoAecZ4h8d&UPY%vF(UOeeMEb(^^V>}o*1BKfG+YF8UF|AL?$1| z;sol}G_#1;9^``kcccNfjj9tn&#u6;ZqVi6ME%Ucr2=Ec;o-!)Txh&K=nzeXUsQ7e zAhCV+3HsJFTM9o=nFCa)N8qnJKsslP4O>gu5~yHVtb;9PUFfe~M-IA$XH4P>HsSBB z;IQq`iIbQL<`^jG5|#O5dKrjl8R)13KGI4HbS_l56nIK4U5)x}m zCcO^%rWVf*aA!BLaS%D?8uPn=)&C+YuG^Sr5B{HmM_+$?FF=i52S?90E)ho)z<=^# zH#^8k)A&1vcN6$_H{z=URkm&Y5@=0?ebplu#lhM<_!fmxe$xzk-MIexw?>n zQnf9$3jFsDt6-9ld*Xr6*3?t=8ZjPSOUO1e>b`oZo*`Daz}Fw}=>U9U9f;@wTN1uy zvwd*+WBAKBo_VN-`@lEuQ2ap@rYm5YO^|ztJ_gGkyVp{$u87N z#IqdavK=T`!)hs5OfAsok$R-vMXCE?{i;p;SkVUd-AcW^x%bT}Nc$HxK;y&5TOS;3#G{4lK0@pYP*&Ntn_7&_HJ4 zw*vNvW^}mAb72~X>U>^kI!7)`l?T7{i z3|4tC^LQNN=neSv7`#274pGxoCzzX)s-Uu{diYowYQIfDtP~Wd5In|-J1?Sgfao5f zbF5=zCc*Ef$#SR?PST5NixpbP6UKG`nqeJOiw2?!bt)@ZNCA|?dHgm;27dFQ1D0Hm zUldVc%a2e$*70;>_8RpTVD4H}O5>2-95Lqd>yf*LakZPc(j551J3<_QCl0Hf@P!&E zv&U*C{G%P(`I>sIh15czun=rNQM(4#bg2b;J3OF5)753|QY(Y5{)mp+as3MG%Ww2n zjBzP`x8n*L(<9=_GhRzjfhvSPm4&%zdH)?5C{*c~vwR@#CSZ_haLYRAI`OCqT|x74 z!mi&np$qB~4B-swZUQ238E{(({gy00DZmZqFiXj zBAdg-gZ+Eh31lnufkGG9z;|x(O@X_@_D$f!6?P64k1Hr&2P}glxsaz;an=sj&dSiC z@4&`UzW{#YfHYmeoNh4hOJu@L2cA|$Vw~l-)``wT-pckX262X z=z!gW+O-5!I|Uvzi)SNM0_JoD_HqGU-T;O!Ap49ULo^d@@PHb`mR6`I_@rx!?U?&TxsEq{KsRH+=IdZ$vN z)B-ov;*kV)UWzJQ7c93M*4hZ3-HZ1#sL{_ui9H7EI6#-&2`qRGJzE0y4PeU_EPP#d z%L{m2MR!!2+zNYdgT*hSD_{v;v4&&yg2xO)74sv1!~=Vp(Ux`_f{ZN z4%gww+0JmDIoXA+XYi>b?6(H*I>vV$K&{otMzu--_>M!-Wz@!TQKh{!BK z)Dvrf2WOB^`t<>H;3N0NvVyXr-dhIs-K<26@^7v{wKA_Ksj{0y?N=Xnlw1eaZye>%x)SQEl%+ z+*rcv6maV*)V^aVVJASl{m?L0Q4t?N7HWl}U5x#j@OKM)jN!9OytV@aPT^4x#bXNp zzv~jsxT8wMqcS=kwe&>j8Vt@GqMX=X4gGADUPJD^0Lt6}mcGF8Mu3z%@EpW-jNwY! zaGo^!5mD|8YRCZcb_@D#%AiQRA7RTd zSwnV`Wq5XC7PH7S^y{U74L_iUe~+6)X#U+5hxRr@P?Cb81NXH#R9w}@(md> z(9i|M5&{nk&UlV~zEkxUdFdQ@@*0To20eZupt2GufOXm&Sk#{Oqw2Kj z4B_t~)VDL>1h;NQZJ+__+YoAz+d#`3@VQguJP)F0DiB-){I4F-wH#=D0_tZQd@!E$ zqq;SWS@olev4EKh5ZPoE_(Bq?6Ytq@23wCv54gb*X8aOZ&jVhO3oMj`IA0FcZWQX( zEcCKvybeJD>!*5w1BZc{ur3Sg9z(@J4;QEhsCfk5)!>sp>@^7#HHt?gwj=^iIVqKV zgn}EvIYd~Qg}TPOOY$66b&9iY!q$cnABMj1mMrAzLNfWiBNUyXB5FVs9t4!K0Kq{K zy8%``1SjdoJ$J&Y`tUjf?h^d=3ui}AgFP6X4LoLnz%Ic_N6^9125alV@3r+qV_3yF z79ht2P?L#3)v-Y*_M+xjgq26{ytnt~{HV)%HO`{zX0T*gk3+9U3KTX1Hot@DieetP_CEC1 zBmD&2=NQp<5A%Kw<#i4^Y&E!e18iXgtfvijR0_*k){f9Gas#Wsgbj{Do2&n(#igR} z#D(sdTg3SVSo9I>^-fLJ?(p{-ykZ4gg0Sd)@R1YjbA*iG#%F|>DL_FUuKVG|6 tZP4{xYL@1~ew)B)XUHMjcs+p^y?^`NS5o0wc2w4@;BQ^Pr# ( -- sounds ) + init-openal 1 gen-sources first sounds boa + dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ; + +: bang ( sounds -- ) bang>> source-play check-error ; From 70ac6fdc15fd82ba66aef0f1258b1592b5a5cf86 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 9 May 2008 00:09:12 +1000 Subject: [PATCH 13/22] jamshred: fixed hang bug with a call to yield (I think it's fixed) --- extra/jamshred/jamshred.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 6b305696e5..3fb7113fde 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -23,7 +23,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) ] [ dup [ jamshred>> jamshred-update ] [ relayout-1 ] bi - 10 sleep jamshred-loop + yield jamshred-loop ] if ; : fullscreen ( gadget -- ) From 8f969e9d91609d85ff73756c35cc9b56622c77c5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 8 May 2008 16:04:30 -0500 Subject: [PATCH 14/22] Clean up Ed's change --- extra/unix/unix.factor | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 38af4b8695..bc3e3ca162 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -80,14 +80,11 @@ FUNCTION: uint ntohl ( uint n ) ; FUNCTION: ushort ntohs ( ushort n ) ; FUNCTION: char* strerror ( int errno ) ; -TUPLE: open-error path flags prot message ; +ERROR: open-error path flags prot message ; : open ( path flags prot -- int ) - [ ] [ unix.ffi:open ] 3bi - dup 0 >= - [ nip nip nip ] - [ drop err_no strerror open-error boa throw ] - if ; + 3dup unix.ffi:open + dup 0 >= [ >r 3drop r> ] [ drop err_no strerror open-error ] if ; FUNCTION: int pclose ( void* file ) ; FUNCTION: int pipe ( int* filedes ) ; @@ -171,8 +168,6 @@ FUNCTION: int setpriority ( int which, int who, int prio ) ; FUNCTION: pid_t wait ( int* status ) ; FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { From 2164bcf784e45706c44ba912e97ee1455a65496b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 8 May 2008 16:05:46 -0500 Subject: [PATCH 15/22] Fix Ed's fix --- core/io/files/files-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index dd550070a4..ec74bb001e 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -273,11 +273,11 @@ $nl HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } -{ $description "Concatenates two pathnames." } ; +{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ; HELP: prepend-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } -{ $description "Appends str1 onto str2 to form a pathname." } ; +{ $description "Appends " { $snippet "str2" } " and " { $snippet "str1" } " to form a pathname." } ; { append-path prepend-path } related-words From 2f4571312f21528179c9fb4bf3437324dc0c5f90 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 8 May 2008 17:04:14 -0500 Subject: [PATCH 16/22] UI fix --- extra/cocoa/application/application.factor | 3 --- extra/ui/cocoa/cocoa.factor | 7 ++++++- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/extra/cocoa/application/application.factor b/extra/cocoa/application/application.factor index 2ae17a1604..90159c1656 100755 --- a/extra/cocoa/application/application.factor +++ b/extra/cocoa/application/application.factor @@ -29,9 +29,6 @@ IN: cocoa.application : do-event ( app -- ? ) dup next-event [ -> sendEvent: t ] [ drop f ] if* ; -: do-events ( app -- ) - dup do-event [ do-events ] [ drop ] if ; - : add-observer ( observer selector name object -- ) >r >r >r >r NSNotificationCenter -> defaultCenter r> r> sel_registerName diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 10980249f3..d1b7f22b41 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -15,7 +15,12 @@ C: handle SINGLETON: cocoa-ui-backend M: cocoa-ui-backend do-events ( -- ) - [ [ NSApp do-events ui-wait ] ui-try ] with-autorelease-pool ; + [ + [ + NSApp [ dup do-event ] [ ] [ ] while drop + ui-wait + ] ui-try + ] with-autorelease-pool ; TUPLE: pasteboard handle ; From 23d95c99f2fa967a4c1a70572e5e967875365f99 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 8 May 2008 17:04:28 -0500 Subject: [PATCH 17/22] Add primitive --- core/bootstrap/primitives.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 753464ab80..3ce783d620 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -702,6 +702,7 @@ tuple { "resize-float-array" "float-arrays" } { "dll-valid?" "alien" } { "unimplemented" "kernel.private" } + { "gc-reset" "memory" } } dup length [ >r first2 r> make-primitive ] 2each From 2148c5eb6c4eb04adf9b6070a68cb5cc2d29b6ec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 8 May 2008 17:29:53 -0500 Subject: [PATCH 18/22] Fix docs --- extra/cocoa/application/application-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/cocoa/application/application-docs.factor b/extra/cocoa/application/application-docs.factor index ad2f8ffbd9..01a79cf35a 100644 --- a/extra/cocoa/application/application-docs.factor +++ b/extra/cocoa/application/application-docs.factor @@ -26,7 +26,7 @@ HELP: with-cocoa { $values { "quot" quotation } } { $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ; -HELP: do-events +HELP: do-event { $values { "app" "an " { $snippet "NSApplication" } } } { $description "Processes any pending events in the queue. Does not block." } ; @@ -49,7 +49,7 @@ ARTICLE: "cocoa-application-utils" "Cocoa application utilities" { $subsection NSApp } { $subsection with-autorelease-pool } { $subsection with-cocoa } -{ $subsection do-events } +{ $subsection do-event } { $subsection add-observer } { $subsection remove-observer } { $subsection install-delegate } ; From 793c58f7a2dd84cb4779f2112b9fbd1f27c663d2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 8 May 2008 17:30:33 -0500 Subject: [PATCH 19/22] Simpler write barrier, upate PowerPC write barrier --- core/cpu/ppc/intrinsics/intrinsics.factor | 11 +++++++++++ core/cpu/x86/intrinsics/intrinsics.factor | 2 +- 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 34e9900893..95af9e4b4b 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -56,14 +56,25 @@ IN: cpu.ppc.intrinsics : load-cards-offset ( dest -- ) "cards_offset" f pick %load-dlsym dup 0 LWZ ; +: load-decks-offset ( dest -- ) + "decks_offset" f pick %load-dlsym dup 0 LWZ ; + : %write-barrier ( -- ) "val" get operand-immediate? "obj" get fresh-object? or [ + ! Mark the card "obj" operand "scratch" operand card-bits SRWI "val" operand load-cards-offset "scratch" operand dup "val" operand ADD "val" operand "scratch" operand 0 LBZ "val" operand dup card-mark ORI "val" operand "scratch" operand 0 STB + + ! Mark the card deck + "obj" operand "scratch" operand deck-bits SRWI + "val" operand load-decks-offset + "scratch" operand dup "val" operand ADD + card-mark "val" operand LI + "val" operand "scratch" operand 0 STB ] unless ; \ set-slot { diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index a8bcf00d15..e0004f5f61 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -71,7 +71,7 @@ IN: cpu.x86.intrinsics ! Mark the card deck "obj" operand deck-bits card-bits - SHR "decks_offset" f temp-reg v>operand %alien-global - temp-reg v>operand "obj" operand [+] card-mark OR + temp-reg v>operand "obj" operand [+] card-mark MOV ] unless ; \ set-slot { From 89de1282be90a870eeffd6b960f37241233aeade Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 8 May 2008 20:34:40 -0500 Subject: [PATCH 20/22] Better support for 8-bit instructions in x86 assembler, more efficient write barrier on x86 --- core/cpu/x86/assembler/assembler-tests.factor | 3 + core/cpu/x86/assembler/assembler.factor | 202 ++++++++++-------- core/cpu/x86/intrinsics/intrinsics.factor | 4 +- 3 files changed, 113 insertions(+), 96 deletions(-) diff --git a/core/cpu/x86/assembler/assembler-tests.factor b/core/cpu/x86/assembler/assembler-tests.factor index caa00bd618..4c0f04fcc2 100644 --- a/core/cpu/x86/assembler/assembler-tests.factor +++ b/core/cpu/x86/assembler/assembler-tests.factor @@ -36,3 +36,6 @@ IN: cpu.x86.assembler.tests [ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test [ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test + +[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 OR ] { } make ] unit-test +[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 MOV ] { } make ] unit-test diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index cabd81dad6..bc6a12d167 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator.fixup io.binary kernel combinators kernel.private math namespaces parser sequences -words system layouts math.order ; +words system layouts math.order accessors ; IN: cpu.x86.assembler ! A postfix assembler for x86 and AMD64. @@ -11,11 +11,6 @@ IN: cpu.x86.assembler ! In 64-bit mode, { 1234 } is RIP-relative. ! Beware! -: n, >le % ; inline -: 4, 4 n, ; inline -: 2, 2 n, ; inline -: cell, bootstrap-cell n, ; inline - ! Register operands -- eg, ECX << @@ -45,6 +40,10 @@ REGISTERS: 128 XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ; +TUPLE: byte value ; + +C: byte + ; ! Addressing modes TUPLE: indirect base index scale displacement ; -M: indirect extended? indirect-base extended? ; +M: indirect extended? base>> extended? ; : canonicalize-EBP #! { EBP } ==> { EBP 0 } - dup indirect-base { EBP RBP R13 } memq? [ - dup indirect-displacement [ - drop - ] [ - 0 swap set-indirect-displacement - ] if - ] [ - drop - ] if ; + dup base>> { EBP RBP R13 } member? [ + dup displacement>> [ 0 >>displacement ] unless + ] when drop ; : canonicalize-ESP #! { ESP } ==> { ESP ESP } - dup indirect-base { ESP RSP R12 } memq? [ - ESP swap set-indirect-index - ] [ - drop - ] if ; + dup base>> { ESP RSP R12 } member? [ ESP >>index ] when drop ; : canonicalize ( indirect -- ) #! Modify the indirect to work around certain addressing mode #! quirks. - dup canonicalize-EBP - canonicalize-ESP ; + [ canonicalize-EBP ] [ canonicalize-ESP ] bi ; : ( base index scale displacement -- indirect ) indirect boa dup canonicalize ; : reg-code "register" word-prop 7 bitand ; -: indirect-base* indirect-base EBP or reg-code ; +: indirect-base* base>> EBP or reg-code ; -: indirect-index* indirect-index ESP or reg-code ; +: indirect-index* index>> ESP or reg-code ; -: indirect-scale* indirect-scale 0 or ; +: indirect-scale* scale>> 0 or ; GENERIC: sib-present? ( op -- ? ) M: indirect sib-present? - dup indirect-base { ESP RSP } memq? - over indirect-index rot indirect-scale or or ; + [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ; M: register sib-present? drop f ; @@ -130,16 +117,23 @@ M: indirect r/m M: register r/m reg-code ; -: byte? -128 127 between? ; +! Immediate operands +UNION: immediate byte integer ; + +GENERIC: fits-in-byte? ( value -- ? ) + +M: byte fits-in-byte? drop t ; + +M: integer fits-in-byte? -128 127 between? ; GENERIC: modifier ( op -- n ) M: indirect modifier - dup indirect-base [ - indirect-displacement { - { [ dup not ] [ BIN: 00 ] } - { [ dup byte? ] [ BIN: 01 ] } - { [ dup integer? ] [ BIN: 10 ] } + dup base>> [ + displacement>> { + { [ dup not ] [ BIN: 00 ] } + { [ dup fits-in-byte? ] [ BIN: 01 ] } + { [ dup immediate? ] [ BIN: 10 ] } } cond nip ] [ drop BIN: 00 @@ -147,14 +141,23 @@ M: indirect modifier M: register modifier drop BIN: 11 ; +GENERIC# n, 1 ( value n -- ) + +M: integer n, >le % ; +M: byte n, >r value>> r> n, ; +: 1, 1 n, ; inline +: 4, 4 n, ; inline +: 2, 2 n, ; inline +: cell, bootstrap-cell n, ; inline + : mod-r/m, ( reg# indirect -- ) - dup modifier 6 shift rot 3 shift rot r/m bitor bitor , ; + [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ; : sib, ( indirect -- ) dup sib-present? [ - dup indirect-base* - over indirect-index* 3 shift bitor - swap indirect-scale* 6 shift bitor , + [ indirect-base* ] + [ indirect-index* 3 shift ] + [ indirect-scale* 6 shift ] tri bitor bitor , ] [ drop ] if ; @@ -162,9 +165,9 @@ M: register modifier drop BIN: 11 ; GENERIC: displacement, ( op -- ) M: indirect displacement, - dup indirect-displacement dup [ - swap indirect-base - [ dup byte? [ , ] [ 4, ] if ] [ 4, ] if + dup displacement>> dup [ + swap base>> + [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if ] [ 2drop ] if ; @@ -172,18 +175,19 @@ M: indirect displacement, M: register displacement, drop ; : addressing ( reg# indirect -- ) - [ mod-r/m, ] keep [ sib, ] keep displacement, ; + [ mod-r/m, ] [ sib, ] [ displacement, ] tri ; ! Utilities UNION: operand register indirect ; -: operand-64? ( operand -- ? ) - dup indirect? [ - dup indirect-base register-64? - swap indirect-index register-64? or - ] [ - register-64? - ] if ; +GENERIC: operand-64? ( operand -- ? ) + +M: indirect operand-64? + [ base>> ] [ index>> ] bi [ operand-64? ] either? ; + +M: register-64 operand-64? drop t ; + +M: object operand-64? drop f ; : rex.w? ( rex.w reg r/m -- ? ) { @@ -198,8 +202,7 @@ UNION: operand register indirect ; : rex.b [ extended? [ BIN: 00000001 bitor ] when ] keep dup indirect? [ - indirect-index extended? - [ BIN: 00000010 bitor ] when + index>> extended? [ BIN: 00000010 bitor ] when ] [ drop ] if ; @@ -230,25 +233,34 @@ UNION: operand register indirect ; : opcode-or ( opcode mask -- opcode' ) swap dup array? - [ 1 cut* first rot bitor suffix ] [ bitor ] if ; + [ unclip-last rot bitor suffix ] [ bitor ] if ; -: 1-operand ( op reg rex.w opcode -- ) +: 1-operand ( op reg,rex.w,opcode -- ) #! The 'reg' is not really a register, but a value for the #! 'reg' field of the mod-r/m byte. - >r >r over r> prefix-1 r> opcode, swap addressing ; + first3 >r >r over r> prefix-1 r> opcode, swap addressing ; -: immediate-1 ( imm dst reg rex.w opcode -- ) - 1-operand , ; +: immediate-operand-size-bit + pick integer? [ first3 BIN: 1 opcode-or 3array ] when ; -: immediate-1/4 ( imm dst reg rex.w opcode -- ) +: immediate-1 ( imm dst reg,rex.w,opcode -- ) + immediate-operand-size-bit 1-operand 1, ; + +: immediate-4 ( imm dst reg,rex.w,opcode -- ) + immediate-operand-size-bit 1-operand 4, ; + +: immediate-fits-in-size-bit + pick integer? [ first3 BIN: 10 opcode-or 3array ] when ; + +: immediate-1/4 ( imm dst reg,rex.w,opcode -- ) #! If imm is a byte, compile the opcode and the byte. - #! Otherwise, set the 32-bit operand flag in the opcode, and + #! Otherwise, set the 8-bit operand flag in the opcode, and #! compile the cell. The 'reg' is not really a register, but #! a value for the 'reg' field of the mod-r/m byte. - >r >r pick byte? [ - r> r> BIN: 10 opcode-or immediate-1 + pick fits-in-byte? [ + immediate-fits-in-size-bit immediate-1 ] [ - r> r> 1-operand 4, + immediate-4 ] if ; : (2-operand) ( dst src op -- ) @@ -283,22 +295,24 @@ PRIVATE> ! Moving stuff GENERIC: PUSH ( op -- ) M: register PUSH f HEX: 50 short-operand ; -M: integer PUSH HEX: 68 , 4, ; -M: operand PUSH BIN: 110 f HEX: ff 1-operand ; +M: immediate PUSH HEX: 68 , 4, ; +M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ; GENERIC: POP ( op -- ) M: register POP f HEX: 58 short-operand ; -M: operand POP BIN: 000 f HEX: 8f 1-operand ; +M: operand POP { BIN: 000 f HEX: 8f } 1-operand ; ! MOV where the src is immediate. GENERIC: (MOV-I) ( src dst -- ) M: register (MOV-I) t HEX: b8 short-operand cell, ; -M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ; +M: operand (MOV-I) + { BIN: 000 t HEX: c6 } + pick byte? [ immediate-1 ] [ immediate-4 ] if ; PREDICATE: callable < word register? not ; GENERIC: MOV ( dst src -- ) -M: integer MOV swap (MOV-I) ; +M: immediate MOV swap (MOV-I) ; M: callable MOV 0 rot (MOV-I) rc-absolute-cell rel-word ; M: operand MOV HEX: 88 2-operand ; @@ -309,13 +323,13 @@ GENERIC: JMP ( op -- ) : (JMP) HEX: e9 , 0 4, rc-relative ; M: callable JMP (JMP) rel-word ; M: label JMP (JMP) label-fixup ; -M: operand JMP BIN: 100 t HEX: ff 1-operand ; +M: operand JMP { BIN: 100 t HEX: ff } 1-operand ; GENERIC: CALL ( op -- ) : (CALL) HEX: e8 , 0 4, rc-relative ; M: callable CALL (CALL) rel-word ; M: label CALL (CALL) label-fixup ; -M: operand CALL BIN: 010 t HEX: ff 1-operand ; +M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; GENERIC# JUMPcc 1 ( addr opcode -- ) : (JUMPcc) extended-opcode, 0 4, rc-relative ; @@ -347,57 +361,57 @@ M: label JUMPcc (JUMPcc) label-fixup ; ! Arithmetic GENERIC: ADD ( dst src -- ) -M: integer ADD swap BIN: 000 t HEX: 81 immediate-1/4 ; +M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ; M: operand ADD OCT: 000 2-operand ; GENERIC: OR ( dst src -- ) -M: integer OR swap BIN: 001 t HEX: 81 immediate-1/4 ; +M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ; M: operand OR OCT: 010 2-operand ; GENERIC: ADC ( dst src -- ) -M: integer ADC swap BIN: 010 t HEX: 81 immediate-1/4 ; +M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ; M: operand ADC OCT: 020 2-operand ; GENERIC: SBB ( dst src -- ) -M: integer SBB swap BIN: 011 t HEX: 81 immediate-1/4 ; +M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ; M: operand SBB OCT: 030 2-operand ; GENERIC: AND ( dst src -- ) -M: integer AND swap BIN: 100 t HEX: 81 immediate-1/4 ; +M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ; M: operand AND OCT: 040 2-operand ; GENERIC: SUB ( dst src -- ) -M: integer SUB swap BIN: 101 t HEX: 81 immediate-1/4 ; +M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ; M: operand SUB OCT: 050 2-operand ; GENERIC: XOR ( dst src -- ) -M: integer XOR swap BIN: 110 t HEX: 81 immediate-1/4 ; +M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ; M: operand XOR OCT: 060 2-operand ; GENERIC: CMP ( dst src -- ) -M: integer CMP swap BIN: 111 t HEX: 81 immediate-1/4 ; +M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ; M: operand CMP OCT: 070 2-operand ; -: NOT ( dst -- ) BIN: 010 t HEX: f7 1-operand ; -: NEG ( dst -- ) BIN: 011 t HEX: f7 1-operand ; -: MUL ( dst -- ) BIN: 100 t HEX: f7 1-operand ; -: IMUL ( src -- ) BIN: 101 t HEX: f7 1-operand ; -: DIV ( dst -- ) BIN: 110 t HEX: f7 1-operand ; -: IDIV ( src -- ) BIN: 111 t HEX: f7 1-operand ; +: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ; +: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ; +: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ; +: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ; +: DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ; +: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ; : CDQ HEX: 99 , ; : CQO HEX: 48 , CDQ ; -: ROL ( dst n -- ) swap BIN: 000 t HEX: c1 immediate-1 ; -: ROR ( dst n -- ) swap BIN: 001 t HEX: c1 immediate-1 ; -: RCL ( dst n -- ) swap BIN: 010 t HEX: c1 immediate-1 ; -: RCR ( dst n -- ) swap BIN: 011 t HEX: c1 immediate-1 ; -: SHL ( dst n -- ) swap BIN: 100 t HEX: c1 immediate-1 ; -: SHR ( dst n -- ) swap BIN: 101 t HEX: c1 immediate-1 ; -: SAR ( dst n -- ) swap BIN: 111 t HEX: c1 immediate-1 ; +: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ; +: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ; +: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ; +: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ; +: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ; +: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ; +: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ; GENERIC: IMUL2 ( dst src -- ) -M: integer IMUL2 swap dup reg-code t HEX: 69 immediate-1/4 ; +M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ; M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ; : MOVSX ( dst src -- ) @@ -432,11 +446,11 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ; ! x87 Floating Point Unit -: FSTPS ( operand -- ) BIN: 011 f HEX: d9 1-operand ; -: FSTPL ( operand -- ) BIN: 011 f HEX: dd 1-operand ; +: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ; +: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ; -: FLDS ( operand -- ) BIN: 000 f HEX: d9 1-operand ; -: FLDL ( operand -- ) BIN: 000 f HEX: dd 1-operand ; +: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ; +: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ; ! SSE multimedia instructions diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index e0004f5f61..db303982ba 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -66,12 +66,12 @@ IN: cpu.x86.intrinsics ! Mark the card "obj" operand card-bits SHR "cards_offset" f temp-reg v>operand %alien-global - temp-reg v>operand "obj" operand [+] card-mark OR + temp-reg v>operand "obj" operand [+] card-mark OR ! Mark the card deck "obj" operand deck-bits card-bits - SHR "decks_offset" f temp-reg v>operand %alien-global - temp-reg v>operand "obj" operand [+] card-mark MOV + temp-reg v>operand "obj" operand [+] card-mark MOV ] unless ; \ set-slot { From 59f85c321e8eb87a61667ce5819773351f2b8e40 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 8 May 2008 20:35:37 -0500 Subject: [PATCH 21/22] Doc fixes from stesch --- core/io/io-docs.factor | 4 ++-- core/io/io.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index ddea4da556..2d74dfabd5 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -125,7 +125,7 @@ $nl ABOUT: "streams" HELP: stream-readln -{ $values { "stream" "an input stream" } { "str" string } } +{ $values { "stream" "an input stream" } { "str/f" "a string or " { $link f } } } { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." } { $notes "Most code only works on one stream at a time and should instead use " { $link readln } "; see " { $link "stdio" } "." } $io-error ; @@ -139,7 +139,7 @@ $io-error ; HELP: stream-read { $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } } { $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } -{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link read } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read-until diff --git a/core/io/io.factor b/core/io/io.factor index e28fd28fb3..6bad8331db 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -4,7 +4,7 @@ USING: hashtables generic kernel math namespaces sequences continuations assocs io.styles ; IN: io -GENERIC: stream-readln ( stream -- str ) +GENERIC: stream-readln ( stream -- str/f ) GENERIC: stream-read1 ( stream -- ch/f ) GENERIC: stream-read ( n stream -- str/f ) GENERIC: stream-read-until ( seps stream -- str/f sep/f ) From 32d5311821f84023342c5be51479b9eed66e9141 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 8 May 2008 20:36:25 -0500 Subject: [PATCH 22/22] Fix typo found by wrunt --- extra/tools/deploy/config/config-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor index 4af1219daf..2960cf452d 100755 --- a/extra/tools/deploy/config/config-docs.factor +++ b/extra/tools/deploy/config/config-docs.factor @@ -96,7 +96,7 @@ HELP: deploy-io { "2" "Basic ANSI C streams" } { "3" "Non-blocking streams and networking" } } -"The default value is 1, basic ANSI C streams. This enables basic console and file I/O, however more advanced features such are not available." } ; +"The default value is 2, basic ANSI C streams. This enables basic console and file I/O, however more advanced features such as networking are not available." } ; HELP: deploy-reflection { $description "The level of reflection support required by the deployed image."