diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index 6a00dec12f..b09938f4b9 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -21,43 +21,48 @@ CONSTANT: rs-reg 14
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
[
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
- 11 6 profile-count-offset LWZ
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+ 11 3 profile-count-offset LWZ
11 11 1 tag-fixnum ADDI
- 11 6 profile-count-offset STW
- 11 6 word-code-offset LWZ
+ 11 3 profile-count-offset STW
+ 11 3 word-code-offset LWZ
11 11 compiled-header-size ADDI
11 MTCTR
BCTR
] jit-profiling jit-define
[
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
0 MFLR
1 1 stack-frame SUBI
- 6 1 xt-save STW
- stack-frame 6 LI
- 6 1 next-save STW
+ 3 1 xt-save STW
+ stack-frame 3 LI
+ 3 1 next-save STW
0 1 lr-save stack-frame + STW
] jit-prolog jit-define
[
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
- 6 ds-reg 4 STWU
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+ 3 ds-reg 4 STWU
] jit-push-immediate jit-define
[
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
- 7 6 0 LWZ
- 1 7 0 STW
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
- 6 MTCTR
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
+ 4 3 0 LWZ
+ 1 4 0 STW
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
+ 3 MTCTR
BCTR
] jit-primitive jit-define
[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define
-[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
+[
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel
+ 0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel
+] jit-word-jump jit-define
+
+[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define
[
3 ds-reg 0 LWZ
@@ -152,6 +157,9 @@ CONSTANT: rs-reg 14
! ! ! Polymorphic inline caches
+! Don't touch r6 here; it's used to pass the tail call site
+! address for tail PICs
+
! Load a value from a stack position
[
4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
@@ -225,7 +233,7 @@ CONSTANT: rs-reg 14
! if(get(cache) == class)
6 3 0 LWZ
6 0 4 CMP
- 5 BNE
+ 10 BNE
! megamorphic_cache_hits++
0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel
5 4 0 LWZ
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index a11b0daa86..beee48e5ea 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -3,9 +3,10 @@
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
alien alien.c-types literals cpu.architecture cpu.ppc.assembler
-literals compiler.cfg.registers compiler.cfg.instructions
-compiler.constants compiler.codegen compiler.codegen.fixup
-compiler.cfg.intrinsics compiler.cfg.stack-frame ;
+cpu.ppc.assembler.backend literals compiler.cfg.registers
+compiler.cfg.instructions compiler.constants compiler.codegen
+compiler.codegen.fixup compiler.cfg.intrinsics
+compiler.cfg.stack-frame ;
IN: cpu.ppc
! PowerPC register assignments:
@@ -116,7 +117,7 @@ M: ppc stack-frame-size ( stack-frame -- i )
M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
M: ppc %jump ( word -- )
- 0 3 LOAD32 rc-absolute-ppc-2/2 rel-here
+ 0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here
0 B rc-relative-ppc-3 rel-word-pic-tail ;
M: ppc %jump-label ( label -- ) B ;
@@ -130,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- )
BCTR ;
M: ppc %dispatch-label ( word -- )
- 0 , rc-absolute-cell rel-word ;
+ B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
:: (%slot) ( obj slot tag temp -- reg offset )
temp slot obj ADD
diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor
index cb1d3723b4..991924dfe4 100755
--- a/basis/math/miller-rabin/miller-rabin.factor
+++ b/basis/math/miller-rabin/miller-rabin.factor
@@ -5,15 +5,15 @@ random sequences sets combinators.short-circuit math.bitwise
math math.order ;
IN: math.miller-rabin
-<PRIVATE
-
: >odd ( n -- int ) 0 set-bit ; foldable
: >even ( n -- int ) 0 clear-bit ; foldable
: next-even ( m -- n ) >even 2 + ;
-TUPLE: positive-even-expected n ;
+: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
+
+<PRIVATE
:: (miller-rabin) ( n trials -- ? )
n 1 - :> n-1
@@ -33,8 +33,6 @@ TUPLE: positive-even-expected n ;
PRIVATE>
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
-
: miller-rabin* ( n numtrials -- ? )
over {
{ [ dup 1 <= ] [ 3drop f ] }
diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
index d103e90bee..49725d2242 100755
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -39,6 +39,8 @@ SLOT: display-list
GENERIC: draw-scaled-texture ( dim texture -- )
+DEFER: make-texture
+
<PRIVATE
TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
@@ -61,18 +63,6 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
[ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
glTexSubImage2D ;
-: make-texture ( image -- id )
- #! We use glTexSubImage2D to work around the power of 2 texture size
- #! limitation
- gen-texture [
- GL_TEXTURE_BIT [
- GL_TEXTURE_2D swap glBindTexture
- non-power-of-2-textures? get
- [ dup bitmap>> (tex-image) ]
- [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
- ] do-attribs
- ] keep ;
-
: init-texture ( -- )
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
@@ -176,6 +166,18 @@ CONSTANT: max-texture-size { 512 512 }
PRIVATE>
+: make-texture ( image -- id )
+ #! We use glTexSubImage2D to work around the power of 2 texture size
+ #! limitation
+ gen-texture [
+ GL_TEXTURE_BIT [
+ GL_TEXTURE_2D swap glBindTexture
+ non-power-of-2-textures? get
+ [ dup bitmap>> (tex-image) ]
+ [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
+ ] do-attribs
+ ] keep ;
+
: <texture> ( image loc -- texture )
over dim>> max-texture-size [ <= ] 2all?
[ <single-texture> ]
diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor
index 5b1b4b0c2a..ef5c80dcdb 100755
--- a/basis/ui/backend/cocoa/cocoa.factor
+++ b/basis/ui/backend/cocoa/cocoa.factor
@@ -29,7 +29,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{
{ fullscreen { $ NSOpenGLPFAFullScreen } }
{ windowed { $ NSOpenGLPFAWindow } }
{ accelerated { $ NSOpenGLPFAAccelerated } }
- { software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } }
+ { software-rendered { $ NSOpenGLPFARendererID $ kCGLRendererGenericFloatID } }
{ backing-store { $ NSOpenGLPFABackingStore } }
{ multisampled { $ NSOpenGLPFAMultisample } }
{ supersampled { $ NSOpenGLPFASupersample } }
diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
index 0009e39fa7..3871936902 100755
--- a/extra/bunny/model/model.factor
+++ b/extra/bunny/model/model.factor
@@ -89,7 +89,7 @@ M: bunny-buffers bunny-geom
GL_FLOAT 0 0 buffer-offset glNormalPointer
[
nv>> "float" heap-size * buffer-offset
- 3 GL_FLOAT 0 roll glVertexPointer
+ [ 3 GL_FLOAT 0 ] dip glVertexPointer
] [
ni>>
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index 0ad2a72100..7d614ff947 100755
--- a/extra/bunny/outlined/outlined.factor
+++ b/extra/bunny/outlined/outlined.factor
@@ -120,7 +120,7 @@ TUPLE: bunny-outlined
: outlining-supported? ( -- ? )
"2.0" {
- "GL_ARB_shading_objects"
+ "GL_ARB_shader_objects"
"GL_ARB_draw_buffers"
"GL_ARB_multitexture"
} has-gl-version-or-extensions? {
diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor
index 8e7c7017d4..8abbe6ba25 100644
--- a/extra/game-loop/game-loop.factor
+++ b/extra/game-loop/game-loop.factor
@@ -1,4 +1,4 @@
-USING: accessors destructors kernel math math.order namespaces
+USING: accessors calendar destructors kernel math math.order namespaces
system threads ;
IN: game-loop
@@ -50,7 +50,7 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
: (run-loop) ( loop -- )
dup running?>>
- [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
+ [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ]
[ drop ] if ;
: run-loop ( loop -- )
diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor
index b891142d5b..b41dae9b38 100644
--- a/extra/images/viewer/viewer.factor
+++ b/extra/images/viewer/viewer.factor
@@ -25,7 +25,7 @@ M: image <image-gadget>
M: string <image-gadget> load-image <image-gadget> ;
-M: pathname <image-gadget> load-image <image-gadget> ;
+M: pathname <image-gadget> string>> load-image <image-gadget> ;
: image-window ( object -- ) <image-gadget> "Image" open-window ;
diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor
index f2ca8ad59b..c28768283c 100644
--- a/extra/noise/noise.factor
+++ b/extra/noise/noise.factor
@@ -7,6 +7,9 @@ IN: noise
: <perlin-noise-table> ( -- table )
256 iota >byte-array randomize dup append ;
+: with-seed ( seed quot -- )
+ [ <mersenne-twister> ] dip with-random ; inline
+
<PRIVATE
: fade ( point -- point' )
@@ -54,9 +57,6 @@ IN: noise
v w quot call
; inline
-: with-seed ( seed quot -- )
- [ <mersenne-twister> ] dip with-random ; inline
-
: >byte-map ( floats -- bytes )
[ 255.0 * >fixnum ] B{ } map-as ;
diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor
index 35c64d4ad1..8afbd52647 100755
--- a/extra/opengl/demo-support/demo-support.factor
+++ b/extra/opengl/demo-support/demo-support.factor
@@ -1,9 +1,9 @@
USING: arrays kernel math math.functions math.order math.vectors
namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
-ui.gadgets.worlds ui.render accessors combinators ;
+ui.gadgets.worlds ui.render accessors combinators literals ;
IN: opengl.demo-support
-: FOV ( -- x ) 2.0 sqrt 1+ ; inline
+CONSTANT: FOV $[ 2.0 sqrt 1+ ]
CONSTANT: MOUSE-MOTION-SCALE 0.5
CONSTANT: KEY-ROTATE-STEP 10.0
diff --git a/extra/terrain/generation/generation.factor b/extra/terrain/generation/generation.factor
new file mode 100644
index 0000000000..18f73e8e8b
--- /dev/null
+++ b/extra/terrain/generation/generation.factor
@@ -0,0 +1,60 @@
+USING: accessors arrays byte-arrays combinators fry grouping
+images kernel math math.affine-transforms math.order
+math.vectors noise random sequences ;
+IN: terrain.generation
+
+CONSTANT: terrain-segment-size { 512 512 }
+CONSTANT: terrain-big-noise-scale { 0.002 0.002 }
+CONSTANT: terrain-small-noise-scale { 0.05 0.05 }
+
+TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ;
+
+: <terrain> ( -- terrain )
+ <perlin-noise-table> <perlin-noise-table>
+ 32 random-bits terrain boa ;
+
+: seed-at ( seed at -- seed' )
+ first2 [ + ] dip [ 32 random-bits + ] curry with-seed ;
+
+: big-noise-segment ( terrain at -- map )
+ [ big-noise-table>> terrain-big-noise-scale first2 <scale> ] dip
+ terrain-segment-size [ v* <translation> a. ] keep perlin-noise-byte-map ;
+: small-noise-segment ( terrain at -- map )
+ [ small-noise-table>> terrain-small-noise-scale first2 <scale> ] dip
+ terrain-segment-size [ v* <translation> a. ] keep perlin-noise-byte-map ;
+: tiny-noise-segment ( terrain at -- map )
+ [ tiny-noise-seed>> ] dip seed-at 0.1
+ terrain-segment-size normal-noise-byte-map ;
+
+: padding ( terrain at -- padding )
+ 2drop terrain-segment-size product 255 <repetition> ;
+
+TUPLE: segment image ;
+
+: terrain-segment ( terrain at -- image )
+ {
+ [ big-noise-segment ]
+ [ small-noise-segment ]
+ [ tiny-noise-segment ]
+ [ padding ]
+ } 2cleave
+ 4array flip concat >byte-array
+ [ terrain-segment-size RGBA f ] dip image boa ;
+
+: 4max ( a b c d -- max )
+ max max max ; inline
+
+: mipmap ( {{pixels}} quot: ( aa ab ba bb -- c ) -- pixels' )
+ [ [ 2 <groups> ] map 2 <groups> ] dip
+ '[ first2 [ [ first2 ] bi@ @ ] 2map ] map ; inline
+
+: group-pixels ( bitmap dim -- scanlines )
+ [ 4 <groups> ] [ first <groups> ] bi* ;
+
+: concat-pixels ( scanlines -- bitmap )
+ [ concat ] map concat ;
+
+: segment-mipmap ( image -- image' )
+ [ clone ] [ bitmap>> ] [ dim>> ] tri
+ group-pixels [ 4max ] mipmap concat-pixels >>bitmap
+ [ 2 v/n ] change-dim ;
diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor
new file mode 100644
index 0000000000..2dc793f078
--- /dev/null
+++ b/extra/terrain/shaders/shaders.factor
@@ -0,0 +1,46 @@
+USING: multiline ;
+IN: terrain.shaders
+
+STRING: terrain-vertex-shader
+
+uniform sampler2D heightmap;
+
+varying vec2 heightcoords;
+
+const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
+
+float height(sampler2D map, vec2 coords)
+{
+ vec4 v = texture2D(map, coords);
+ return dot(v, COMPONENT_SCALE);
+}
+
+void main()
+{
+ gl_Position = gl_ModelViewProjectionMatrix
+ * (gl_Vertex + vec4(0, height(heightmap, gl_Vertex.xz), 0, 0));
+ heightcoords = gl_Vertex.xz;
+}
+
+;
+
+STRING: terrain-pixel-shader
+
+uniform sampler2D heightmap;
+
+varying vec2 heightcoords;
+
+const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
+
+float height(sampler2D map, vec2 coords)
+{
+ vec4 v = texture2D(map, coords);
+ return dot(v, COMPONENT_SCALE);
+}
+
+void main()
+{
+ gl_FragColor = texture2D(heightmap, heightcoords);
+}
+
+;
diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor
new file mode 100644
index 0000000000..725848abb7
--- /dev/null
+++ b/extra/terrain/terrain.factor
@@ -0,0 +1,190 @@
+USING: accessors arrays combinators game-input
+game-input.scancodes game-loop kernel literals locals math
+math.constants math.functions math.matrices math.order
+math.vectors opengl opengl.capabilities opengl.gl
+opengl.shaders opengl.textures opengl.textures.private
+sequences sequences.product specialized-arrays.float
+terrain.generation terrain.shaders ui ui.gadgets
+ui.gadgets.worlds ui.pixel-formats ;
+IN: terrain
+
+CONSTANT: FOV $[ 2.0 sqrt 1+ ]
+CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
+CONSTANT: FAR-PLANE 1.0
+CONSTANT: EYE-START { 0.5 0.5 1.2 }
+CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
+CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
+CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ]
+
+CONSTANT: terrain-vertex-size { 512 512 }
+CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] }
+CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
+
+TUPLE: terrain-world < world
+ eye yaw pitch
+ terrain terrain-segment terrain-texture terrain-program
+ terrain-vertex-buffer
+ game-loop ;
+
+: frustum ( dim -- -x x -y y near far )
+ dup first2 min v/n
+ NEAR-PLANE FOV / v*n first2 [ [ neg ] keep ] bi@
+ NEAR-PLANE FAR-PLANE ;
+
+: set-modelview-matrix ( gadget -- )
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ [ pitch>> 1.0 0.0 0.0 glRotatef ]
+ [ yaw>> 0.0 1.0 0.0 glRotatef ]
+ [ eye>> vneg first3 glTranslatef ] tri ;
+
+: vertex-array-vertex ( x z -- vertex )
+ [ terrain-vertex-distance first * ]
+ [ terrain-vertex-distance second * ] bi*
+ [ 0 ] dip float-array{ } 3sequence ;
+
+: vertex-array-row ( z -- vertices )
+ dup 1 + 2array
+ terrain-vertex-size first 1 + iota
+ 2array [ first2 swap vertex-array-vertex ] product-map
+ concat ;
+
+: vertex-array ( -- vertices )
+ terrain-vertex-size second iota
+ [ vertex-array-row ] map concat ;
+
+: >vertex-buffer ( bytes -- buffer )
+ [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ;
+
+: draw-vertex-buffer-row ( i -- )
+ [ GL_TRIANGLE_STRIP ] dip
+ terrain-vertex-row-length * terrain-vertex-row-length
+ glDrawArrays ;
+
+: draw-vertex-buffer ( buffer -- )
+ [ GL_ARRAY_BUFFER ] dip [
+ 3 GL_FLOAT 0 f glVertexPointer
+ terrain-vertex-size second iota [ draw-vertex-buffer-row ] each
+ ] with-gl-buffer ;
+
+: degrees ( deg -- rad )
+ pi 180.0 / * ;
+
+:: eye-rotate ( yaw pitch v -- v' )
+ yaw degrees neg :> y
+ pitch degrees neg :> p
+ y cos :> cosy
+ y sin :> siny
+ p cos :> cosp
+ p sin :> sinp
+
+ cosy 0.0 siny neg 3array
+ siny sinp * cosp cosy sinp * 3array
+ siny cosp * sinp neg cosy cosp * 3array 3array
+ v swap v.m ;
+
+: forward-vector ( world -- v )
+ [ yaw>> ] [ pitch>> ] bi
+ { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ;
+: rightward-vector ( world -- v )
+ [ yaw>> ] [ pitch>> ] bi
+ { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
+
+: move-forward ( world -- )
+ dup forward-vector [ v+ ] curry change-eye drop ;
+: move-backward ( world -- )
+ dup forward-vector [ v- ] curry change-eye drop ;
+: move-leftward ( world -- )
+ dup rightward-vector [ v- ] curry change-eye drop ;
+: move-rightward ( world -- )
+ dup rightward-vector [ v+ ] curry change-eye drop ;
+
+: rotate-with-mouse ( world mouse -- )
+ [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ]
+ [ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi
+ drop ;
+
+:: handle-input ( world -- )
+ read-keyboard keys>> :> keys
+ key-w keys nth [ world move-forward ] when
+ key-s keys nth [ world move-backward ] when
+ key-a keys nth [ world move-leftward ] when
+ key-d keys nth [ world move-rightward ] when
+ world read-mouse rotate-with-mouse
+ reset-mouse ;
+
+M: terrain-world tick*
+ [ handle-input ] keep
+ ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug
+ drop ;
+
+M: terrain-world draw*
+ nip draw-world ;
+
+: set-heightmap-texture-parameters ( texture -- )
+ GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
+ GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ;
+
+M: terrain-world begin-world
+ "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
+ require-gl-version-or-extensions
+ GL_DEPTH_TEST glEnable
+ GL_TEXTURE_2D glEnable
+ GL_VERTEX_ARRAY glEnableClientState
+ 0.5 0.5 0.5 1.0 glClearColor
+ EYE-START >>eye
+ 0.0 >>yaw
+ 0.0 >>pitch
+ <terrain> [ >>terrain ] keep
+ { 0 0 } terrain-segment [ >>terrain-segment ] keep
+ make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture
+ terrain-vertex-shader terrain-pixel-shader <simple-gl-program>
+ >>terrain-program
+ vertex-array >vertex-buffer >>terrain-vertex-buffer
+ TICK-LENGTH over <game-loop> [ >>game-loop ] keep start-loop
+ reset-mouse
+ drop ;
+
+M: terrain-world end-world
+ {
+ [ game-loop>> stop-loop ]
+ [ terrain-vertex-buffer>> delete-gl-buffer ]
+ [ terrain-program>> delete-gl-program ]
+ [ terrain-texture>> delete-texture ]
+ } cleave ;
+
+M: terrain-world resize-world
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ dim>> [ [ 0 0 ] dip first2 glViewport ]
+ [ frustum glFrustum ] bi ;
+
+M: terrain-world draw-world*
+ [ set-modelview-matrix ]
+ [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
+ [ dup terrain-program>> [
+ "heightmap" glGetUniformLocation 0 glUniform1i
+ terrain-vertex-buffer>> draw-vertex-buffer
+ ] with-gl-program ]
+ tri gl-error ;
+
+M: terrain-world focusable-child* drop t ;
+M: terrain-world pref-dim* drop { 640 480 } ;
+
+: terrain-window ( -- )
+ [
+ open-game-input
+ f T{ world-attributes
+ { world-class terrain-world }
+ { title "Terrain" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits { value 24 } }
+ } }
+ } open-window
+ ] with-ui ;
diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S
index f8dad4b2b2..a372b2b1f5 100755
--- a/vm/cpu-ppc.S
+++ b/vm/cpu-ppc.S
@@ -236,8 +236,10 @@ DEF(void,flush_icache,(void *start, int len)):
blr
DEF(void,primitive_inline_cache_miss,(void)):
- mflr r3
+ mflr r6
+DEF(void,primitive_inline_cache_miss_tail,(void)):
PROLOGUE
+ mr r3,r6
bl MANGLE(inline_cache_miss)
EPILOGUE
mtctr r3
diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp
index d393223d8d..ae7f93ebf7 100755
--- a/vm/cpu-ppc.hpp
+++ b/vm/cpu-ppc.hpp
@@ -7,11 +7,22 @@ namespace factor
register cell ds asm("r13");
register cell rs asm("r14");
+/* In the instruction sequence:
+
+ LOAD32 r3,...
+ B blah
+
+ the offset from the immediate operand to LOAD32 to the instruction after
+ the branch is two instructions. */
+static const fixnum xt_tail_pic_offset = 4 * 2;
+
inline static void check_call_site(cell return_address)
{
#ifdef FACTOR_DEBUG
cell insn = *(cell *)return_address;
- assert((insn & 0x3) == 0x1);
+ /* Check that absolute bit is 0 */
+ assert((insn & 0x2) == 0x0);
+ /* Check that instruction is branch */
assert((insn >> 26) == 0x12);
#endif
}
@@ -21,8 +32,8 @@ inline static void check_call_site(cell return_address)
inline static void *get_call_target(cell return_address)
{
return_address -= sizeof(cell);
-
check_call_site(return_address);
+
cell insn = *(cell *)return_address;
cell unsigned_addr = (insn & B_MASK);
fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6;
@@ -32,19 +43,25 @@ inline static void *get_call_target(cell return_address)
inline static void set_call_target(cell return_address, void *target)
{
return_address -= sizeof(cell);
-
-#ifdef FACTOR_DEBUG
- assert((return_address & ~B_MASK) == 0);
check_call_site(return_address);
-#endif
+
cell insn = *(cell *)return_address;
- insn = ((insn & ~B_MASK) | (((cell)target - return_address) & B_MASK));
+
+ fixnum relative_address = ((cell)target - return_address);
+ insn = ((insn & ~B_MASK) | (relative_address & B_MASK));
*(cell *)return_address = insn;
/* Flush the cache line containing the call we just patched */
__asm__ __volatile__ ("icbi 0, %0\n" "sync\n"::"r" (return_address):);
}
+inline static bool tail_call_site_p(cell return_address)
+{
+ return_address -= sizeof(cell);
+ cell insn = *(cell *)return_address;
+ return (insn & 0x1) == 0;
+}
+
/* Defined in assembly */
VM_ASM_API void c_to_factor(cell quot);
VM_ASM_API void throw_impl(cell quot, stack_frame *rewind);