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

basis/compiler/codegen/codegen.factor

@@ -88,7 +88,7 @@ M: ##call generate-insn
     word>> dup sub-primitive>>
     [ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
 
-M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
+M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
 
 M: ##return generate-insn drop %return ;
 

basis/compiler/codegen/fixup/fixup.factor

@@ -56,8 +56,8 @@ SYMBOL: literal-table
 : rel-word ( word class -- )
     [ add-literal ] dip rt-xt rel-fixup ;
 
-: rel-word-direct ( word class -- )
+: rel-word-pic ( word class -- )
-    [ add-literal ] dip rt-xt-direct rel-fixup ;
+    [ add-literal ] dip rt-xt-pic rel-fixup ;
 
 : rel-primitive ( word class -- )
     [ def>> first add-literal ] dip rt-primitive rel-fixup ;

basis/compiler/constants/constants.factor

@@ -42,7 +42,7 @@ CONSTANT: rt-primitive   0
 CONSTANT: rt-dlsym       1
 CONSTANT: rt-dispatch    2
 CONSTANT: rt-xt          3
-CONSTANT: rt-xt-direct   4
+CONSTANT: rt-xt-pic      4
 CONSTANT: rt-here        5
 CONSTANT: rt-this        6
 CONSTANT: rt-immediate   7

basis/cpu/architecture/architecture.factor

@@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- )
 
 HOOK: stack-frame-size cpu ( stack-frame -- n )
 HOOK: %call cpu ( word -- )
+HOOK: %jump cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 HOOK: %return cpu ( -- )
 

basis/cpu/ppc/assembler/assembler.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.codegen.fixup kernel namespaces words
+USING: kernel namespaces words io.binary math math.order
-io.binary math math.order cpu.ppc.assembler.backend ;
+cpu.ppc.assembler.backend ;
 IN: cpu.ppc.assembler
 
 ! See the Motorola or IBM documentation for details. The opcode

basis/cpu/ppc/assembler/backend/backend.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.codegen.fixup cpu.architecture
+USING:  kernel namespaces make sequences words math
-compiler.constants kernel namespaces make sequences words math
+math.bitwise io.binary parser lexer fry ;
-math.bitwise io.binary parser lexer ;
 IN: cpu.ppc.assembler.backend
 
 : insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
@@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
 
 GENERIC# (B) 2 ( dest aa lk -- )
 M: integer (B) 18 i-insn ;
-M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
-M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
 
 GENERIC: BC ( a b c -- )
 M: integer BC 0 0 16 b-insn ;
-M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
-M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
 
 : CREATE-B ( -- word ) scan "B" prepend create-in ;
 
 SYNTAX: BC:
     CREATE-B scan-word scan-word
-    [ rot BC ] 2curry (( c -- )) define-declared ;
+    '[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
 
 SYNTAX: B:
     CREATE-B scan-word scan-word scan-word scan-word scan-word
-    [ b-insn ] curry curry curry curry curry
+    '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
-    (( bo -- )) define-declared ;

basis/cpu/ppc/bootstrap.factor

@@ -9,8 +9,8 @@ IN: bootstrap.ppc
 4 \ cell set
 big-endian on
 
-CONSTANT: ds-reg 29
+CONSTANT: ds-reg 13
-CONSTANT: rs-reg 30
+CONSTANT: rs-reg 14
 
 : factor-area-size ( -- n ) 4 bootstrap-cells ;
 
@@ -58,7 +58,7 @@ CONSTANT: rs-reg 30
     BCTR
 ] jit-primitive jit-define
 
-[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call 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
 
@@ -138,6 +138,16 @@ CONSTANT: rs-reg 30
     jit-3r>
 ] jit-3dip jit-define
 
+: prepare-(execute) ( -- operand )
+    3 ds-reg 0 LWZ
+    ds-reg dup 4 SUBI
+    4 3 word-xt-offset LWZ
+    4 ;
+
+[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define
+
+[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define
+
 [
     0 1 lr-save stack-frame + LWZ
     1 1 stack-frame ADDI
@@ -146,7 +156,91 @@ CONSTANT: rs-reg 30
 
 [ BLR ] jit-return jit-define
 
-! Sub-primitives
+! ! ! Polymorphic inline caches
+
+! Load a value from a stack position
+[
+    4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
+] pic-load jit-define
+
+! Tag
+: load-tag ( -- )
+    4 4 tag-mask get ANDI
+    4 4 tag-bits get SLWI ;
+
+[ load-tag ] pic-tag jit-define
+
+! Hi-tag
+[
+    3 4 MR
+    load-tag
+    0 4 object tag-number tag-fixnum CMPI
+    2 BNE
+    4 3 object tag-number neg LWZ
+] pic-hi-tag jit-define
+
+! Tuple
+[
+    3 4 MR
+    load-tag
+    0 4 tuple tag-number tag-fixnum CMPI
+    2 BNE
+    4 3 tuple tag-number neg bootstrap-cell + LWZ
+] pic-tuple jit-define
+
+! Hi-tag and tuple
+[
+    3 4 MR
+    load-tag
+    ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
+    0 4 BIN: 110 tag-fixnum CMPI
+    5 BLT
+    ! Untag r3
+    3 3 0 0 31 tag-bits get - RLWINM
+    ! Set r4 to 0 for objects, and bootstrap-cell for tuples
+    4 4 1 tag-fixnum ANDI
+    4 4 1 SRAWI
+    ! Load header cell or tuple layout cell
+    4 4 3 LWZX
+] pic-hi-tag-tuple jit-define
+
+[
+    0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
+] pic-check-tag jit-define
+
+[
+    0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    4 0 5 CMP
+] pic-check jit-define
+
+[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
+
+! ! ! Megamorphic caches
+
+[
+    ! cache = ...
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    ! key = class
+    5 4 MR
+    ! key &= cache.length - 1
+    5 5 mega-cache-size get 1- bootstrap-cell * ANDI
+    ! cache += array-start-offset
+    3 3 array-start-offset ADDI
+    ! cache += key
+    3 3 5 ADD
+    ! if(get(cache) == class)
+    6 3 0 LWZ
+    6 0 4 CMP
+    5 BNE
+    ! ... goto get(cache + bootstrap-cell)
+    3 3 4 LWZ
+    3 3 word-xt-offset LWZ
+    3 MTCTR
+    BCTR
+    ! fall-through on miss
+] mega-lookup jit-define
+
+! ! ! Sub-primitives
 
 ! Quotations and words
 [
@@ -157,14 +251,6 @@ CONSTANT: rs-reg 30
     BCTR
 ] \ (call) define-sub-primitive
 
-[
-    3 ds-reg 0 LWZ
-    ds-reg dup 4 SUBI
-    4 3 word-xt-offset LWZ
-    4 MTCTR
-    BCTR
-] \ (execute) define-sub-primitive
-
 ! Objects
 [
     3 ds-reg 0 LWZ

basis/cpu/ppc/ppc.factor

@@ -1,33 +1,38 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
-alien alien.c-types cpu.architecture cpu.ppc.assembler
+alien alien.c-types literals cpu.architecture cpu.ppc.assembler
-compiler.cfg.registers compiler.cfg.instructions
+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:
-! r2-r27: integer vregs
+! r2-r12: integer vregs
-! r28: integer scratch
+! r15-r29
-! r29: data stack
+! r30: integer scratch
-! r30: retain stack
 ! f0-f29: float vregs
-! f30, f31: float scratch
+! f30: float scratch
+
+! Add some methods to the assembler that are useful to us
+M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
+M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
 
 enable-float-intrinsics
 
-<< \ ##integer>float t frame-required? set-word-prop
+<<
-\ ##float>integer t frame-required? set-word-prop >>
+\ ##integer>float t frame-required? set-word-prop
+\ ##float>integer t frame-required? set-word-prop
+>>
 
 M: ppc machine-registers
     {
-        { int-regs T{ range f 2 26 1 } }
+        { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
-        { double-float-regs T{ range f 0 29 1 } }
+        { double-float-regs $[ 0 29 [a,b] ] }
     } ;
 
-CONSTANT: scratch-reg 28
+CONSTANT: scratch-reg 30
 CONSTANT: fp-scratch-reg 30
 
 M: ppc two-operand? f ;
@@ -40,8 +45,8 @@ M: ppc %load-reference ( reg obj -- )
 M: ppc %alien-global ( register symbol dll -- )
     [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
 
-CONSTANT: ds-reg 29
+CONSTANT: ds-reg 13
-CONSTANT: rs-reg 30
+CONSTANT: rs-reg 14
 
 GENERIC: loc-reg ( loc -- reg )
 
@@ -108,7 +113,8 @@ M: ppc stack-frame-size ( stack-frame -- i )
     factor-area-size +
     4 cells align ;
 
-M: ppc %call ( label -- ) BL ;
+M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
+M: ppc %jump ( word -- ) 0 B rc-relative-ppc-3 rel-word ;
 M: ppc %jump-label ( label -- ) B ;
 M: ppc %return ( -- ) BLR ;
 

basis/cpu/x86/32/32.factor

@@ -44,9 +44,9 @@ M: x86.32 param-reg-2 EDX ;
 
 M: x86.32 reserved-area-size 0 ;
 
-M: x86.32 %alien-invoke (CALL) rel-dlsym ;
+M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
 
-M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
+M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
 
 M: x86.32 return-struct-in-registers? ( c-type -- ? )
     c-type

basis/cpu/x86/32/bootstrap.factor

@@ -29,7 +29,7 @@ IN: bootstrap.x86
 ] jit-save-stack jit-define
 
 [
-    (JMP) drop rc-relative rt-primitive jit-rel
+    0 JMP rc-relative rt-primitive jit-rel
 ] jit-primitive jit-define
 
 << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>

basis/cpu/x86/assembler/assembler.factor

@@ -1,12 +1,11 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays cpu.architecture compiler.constants
+USING: arrays io.binary kernel combinators
-compiler.codegen.fixup io.binary kernel combinators
+kernel.private math namespaces make sequences words system layouts
-kernel.private math namespaces make sequences words system
+math.order accessors cpu.x86.assembler.syntax ;
-layouts math.order accessors cpu.x86.assembler.syntax ;
 IN: cpu.x86.assembler
 
-! A postfix assembler for x86 and AMD64.
+! A postfix assembler for x86-32 and x86-64.
 
 ! In 32-bit mode, { 1234 } is absolute indirect addressing.
 ! In 64-bit mode, { 1234 } is RIP-relative.
@@ -296,36 +295,23 @@ 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: immediate MOV swap (MOV-I) ;
-M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
 M: operand MOV HEX: 88 2-operand ;
 
 : LEA ( dst src -- ) swap HEX: 8d 2-operand ;
 
 ! Control flow
 GENERIC: JMP ( op -- )
-: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
+M: integer JMP HEX: e9 , 4, ;
-M: f JMP (JMP) 2drop ;
-M: callable JMP (JMP) rel-word ;
-M: label JMP (JMP) label-fixup ;
 M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
 
 GENERIC: CALL ( op -- )
-: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
+M: integer CALL HEX: e8 , 4, ;
-M: f CALL (CALL) 2drop ;
-M: callable CALL (CALL) rel-word-direct ;
-M: label CALL (CALL) label-fixup ;
 M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
 
 GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
+M: integer JUMPcc extended-opcode, 4, ;
-M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
-M: integer JUMPcc (JUMPcc) drop ;
-M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
-M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
 
 : JO  ( dst -- ) HEX: 80 JUMPcc ;
 : JNO ( dst -- ) HEX: 81 JUMPcc ;

basis/cpu/x86/bootstrap.factor

@@ -42,11 +42,11 @@ big-endian off
 ] jit-push-immediate jit-define
 
 [
-    f JMP rc-relative rt-xt jit-rel
+    0 JMP rc-relative rt-xt jit-rel
 ] jit-word-jump jit-define
 
 [
-    f CALL rc-relative rt-xt-direct jit-rel
+    0 CALL rc-relative rt-xt-pic jit-rel
 ] jit-word-call jit-define
 
 [
@@ -57,12 +57,12 @@ big-endian off
     ! compare boolean with f
     temp0 \ f tag-number CMP
     ! jump to true branch if not equal
-    f JNE rc-relative rt-xt jit-rel
+    0 JNE rc-relative rt-xt jit-rel
 ] jit-if-1 jit-define
 
 [
     ! jump to false branch if equal
-    f JMP rc-relative rt-xt jit-rel
+    0 JMP rc-relative rt-xt jit-rel
 ] jit-if-2 jit-define
 
 : jit->r ( -- )
@@ -115,19 +115,19 @@ big-endian off
 
 [
     jit->r
-    f CALL rc-relative rt-xt jit-rel
+    0 CALL rc-relative rt-xt jit-rel
     jit-r>
 ] jit-dip jit-define
 
 [
     jit-2>r
-    f CALL rc-relative rt-xt jit-rel
+    0 CALL rc-relative rt-xt jit-rel
     jit-2r>
 ] jit-2dip jit-define
 
 [
     jit-3>r
-    f CALL rc-relative rt-xt jit-rel
+    0 CALL rc-relative rt-xt jit-rel
     jit-3r>
 ] jit-3dip jit-define
 
@@ -194,7 +194,7 @@ big-endian off
     [
         ! Untag temp0
         temp0 tag-mask get bitnot AND
-        ! Set temp1 to 0 for objects, and 8 for tuples
+        ! Set temp1 to 0 for objects, and bootstrap-cell for tuples
         temp1 1 tag-fixnum AND
         bootstrap-cell 4 = [ temp1 1 SHR ] when
         ! Load header cell or tuple layout cell
@@ -211,7 +211,7 @@ big-endian off
     temp1 temp2 CMP
 ] pic-check jit-define
 
-[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
+[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
 
 ! ! ! Megamorphic caches
 

basis/cpu/x86/x86.factor

@@ -11,6 +11,10 @@ IN: cpu.x86
 
 << enable-fixnum-log2 >>
 
+! Add some methods to the assembler to be more useful to the backend
+M: label JMP 0 JMP rc-relative label-fixup ;
+M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
+
 M: x86 two-operand? t ;
 
 HOOK: temp-reg-1 cpu ( -- reg )
@@ -53,8 +57,9 @@ M: x86 stack-frame-size ( stack-frame -- i )
     reserved-area-size +
     align-stack ;
 
-M: x86 %call ( label -- ) CALL ;
+M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
-M: x86 %jump-label ( label -- ) JMP ;
+M: x86 %jump ( word -- ) 0 JMP rc-relative rel-word ;
+M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
 M: x86 %return ( -- ) 0 RET ;
 
 : code-alignment ( align -- n )

basis/random/random.factor

@@ -3,7 +3,7 @@
 USING: alien.c-types kernel math namespaces sequences
 io.backend io.binary combinators system vocabs.loader
 summary math.bitwise byte-vectors fry byte-arrays
-math.ranges math.constants math.functions ;
+math.ranges math.constants math.functions accessors ;
 IN: random
 
 SYMBOL: system-random-generator
@@ -70,8 +70,11 @@ PRIVATE>
     secure-random-generator get swap with-random ; inline
 
 : uniform-random-float ( min max -- n )
-    64 random-bits >float [ over - 2.0 -64 ^ * ] dip
+    4 random-bytes underlying>> *uint >float
-    * + ;
+    4 random-bytes underlying>> *uint >float
+    2.0 32 ^ * +
+    [ over - 2.0 -64 ^ * ] dip
+    * + ; inline
 
 : normal-random-float ( mean sigma -- n )
     0.0 1.0 uniform-random-float

basis/tools/time/time.factor

@@ -1,6 +1,6 @@
 ! 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
+USING: kernel math memory io io.styles prettyprint
 namespaces system sequences splitting grouping assocs strings
 generic.single combinators ;
 IN: tools.time

core/hashtables/hashtables.factor

@@ -139,14 +139,14 @@ M: hashtable set-at ( value key hash -- )
 PRIVATE>
 
 M: hashtable >alist
-    [ array>> [ length 2/ iota ] keep ] [ assoc-size <vector> ] bi [
+    [ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
         [
             [
                 [ 1 fixnum-shift-fast ] dip
                 [ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi
             ] dip
             pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
-        ] 2curry each
+        ] 2curry each-integer
     ] keep { } like ;
 
 M: hashtable clone

extra/noise/noise.factor

@@ -1,11 +1,14 @@
-USING: byte-arrays combinators images kernel locals math math.affine-transforms
+USING: byte-arrays combinators fry images kernel locals math
-math.functions math.polynomials math.vectors random sequences
+math.affine-transforms math.functions math.order
-sequences.product ;
+math.polynomials math.vectors random random.mersenne-twister
-IN: perlin-noise
+sequences sequences.product ;
+IN: noise
 
-: <noise-table> ( -- table )
+: <perlin-noise-table> ( -- table )
     256 iota >byte-array randomize dup append ;
 
+<PRIVATE
+
 : fade ( point -- point' )
     { 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ;
 
@@ -51,7 +54,18 @@ IN: perlin-noise
     v w quot call
     ; inline
 
-:: noise ( table point -- value )
+: with-seed ( seed quot -- )
+    [ <mersenne-twister> ] dip with-random ; inline
+
+: >byte-map ( floats -- bytes )
+    [ 255.0 * >fixnum ] B{ } map-as ;
+
+: >image ( bytes dim -- image )
+    swap [ L f ] dip image boa ;
+
+PRIVATE>
+
+:: perlin-noise ( table point -- value )
     point unit-cube :> cube
     point dup vfloor v- :> gradients
     gradients fade :> faded
@@ -70,14 +84,38 @@ IN: perlin-noise
     [ faded second lerp ] 2bi@
     faded third lerp ;
 
-: noise-map ( table transform dim -- map ) 
-    [ iota ] map [ a.v 0.0 suffix noise ] with with product-map ;
-
 : normalize-0-1 ( sequence -- sequence' )
     [ supremum ] [ infimum [ - ] keep ] [ ] tri
     [ swap - ] with map [ swap / ] with map ;
 
-: noise-image ( table transform dim -- image )
+: clamp-0-1 ( sequence -- sequence' )
-    [ noise-map normalize-0-1 [ 255.0 * >fixnum ] B{ } map-as ]
+    [ 0.0 max 1.0 min ] map ;
-    [ swap [ L f ] dip image boa ] bi ;
 
+: perlin-noise-map ( table transform dim -- map ) 
+    [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ;
+
+: perlin-noise-byte-map ( table transform dim -- map )
+    perlin-noise-map normalize-0-1 >byte-map ;
+
+: perlin-noise-image ( table transform dim -- image )
+    [ perlin-noise-byte-map ] [ >image ] bi ;
+
+: uniform-noise-map ( seed dim -- map )
+    [ product [ 0.0 1.0 uniform-random-float ] replicate ]
+    curry with-seed ;
+
+: uniform-noise-byte-map ( seed dim -- map )
+    uniform-noise-map >byte-map ;
+
+: uniform-noise-image ( seed dim -- image )
+    [ uniform-noise-byte-map ] [ >image ] bi ;
+
+: normal-noise-map ( seed sigma dim -- map )
+    swap '[ _ product [ 0.5 _ normal-random-float ] replicate ]
+    with-seed ;
+
+: normal-noise-byte-map ( seed sigma dim -- map )
+    normal-noise-map clamp-0-1 >byte-map ;
+
+: normal-noise-image ( seed sigma dim -- image )
+    [ normal-noise-byte-map ] [ >image ] bi ;

vm/cpu-ppc.S

@@ -2,7 +2,7 @@
 in the public domain. */
 #include "asm.h"
 
-#define DS_REG r29
+#define DS_REG r13
 
 DEF(void,primitive_fixnum_add,(void)):
 	lwz r3,0(DS_REG)
@@ -45,7 +45,7 @@ multiply_overflow:
 	
 /* Note that the XT is passed to the quotation in r11 */
 #define CALL_OR_JUMP_QUOT \
-	lwz r11,14(r3)	   /* load quotation-xt slot */ XX \
+	lwz r11,16(r3)	   /* load quotation-xt slot */ XX \
 
 #define CALL_QUOT \
 	CALL_OR_JUMP_QUOT XX \
@@ -100,22 +100,22 @@ the Factor compiler treats the entire register file as volatile. */
 DEF(void,c_to_factor,(CELL quot)):
 	PROLOGUE
 
-	SAVE_INT(r13,0)	   /* save GPRs */
+	SAVE_INT(r15,0)	   /* save GPRs */
-	SAVE_INT(r14,1)
+	SAVE_INT(r16,1)
-	SAVE_INT(r15,2)
+	SAVE_INT(r17,2)
-	SAVE_INT(r16,3)
+	SAVE_INT(r18,3)
-	SAVE_INT(r17,4)
+	SAVE_INT(r19,4)
-	SAVE_INT(r18,5)
+	SAVE_INT(r20,5)
-	SAVE_INT(r19,6)
+	SAVE_INT(r21,6)
-	SAVE_INT(r20,7)
+	SAVE_INT(r22,7)
-	SAVE_INT(r21,8)
+	SAVE_INT(r23,8)
-	SAVE_INT(r22,9)
+	SAVE_INT(r24,9)
-	SAVE_INT(r23,10)
+	SAVE_INT(r25,10)
-	SAVE_INT(r24,11)
+	SAVE_INT(r26,11)
-	SAVE_INT(r25,12)
+	SAVE_INT(r27,12)
-	SAVE_INT(r26,13)
+	SAVE_INT(r28,13)
-	SAVE_INT(r27,14)
+	SAVE_INT(r29,14)
-	SAVE_INT(r28,15)
+	SAVE_INT(r30,15)
 	SAVE_INT(r31,16)
 
 	SAVE_FP(f14,20)	/* save FPRs */
@@ -165,22 +165,22 @@ DEF(void,c_to_factor,(CELL quot)):
 	RESTORE_FP(f14,20)	/* save FPRs */
 
 	RESTORE_INT(r31,16)   /* restore GPRs */
-	RESTORE_INT(r28,15)
+	RESTORE_INT(r30,15)
-	RESTORE_INT(r27,14)
+	RESTORE_INT(r29,14)
-	RESTORE_INT(r26,13)
+	RESTORE_INT(r28,13)
-	RESTORE_INT(r25,12)
+	RESTORE_INT(r27,12)
-	RESTORE_INT(r24,11)
+	RESTORE_INT(r26,11)
-	RESTORE_INT(r23,10)
+	RESTORE_INT(r25,10)
-	RESTORE_INT(r22,9)
+	RESTORE_INT(r24,9)
-	RESTORE_INT(r21,8)
+	RESTORE_INT(r23,8)
-	RESTORE_INT(r20,7)
+	RESTORE_INT(r22,7)
-	RESTORE_INT(r19,6)
+	RESTORE_INT(r21,6)
-	RESTORE_INT(r18,5)
+	RESTORE_INT(r20,5)
-	RESTORE_INT(r17,4)
+	RESTORE_INT(r19,4)
-	RESTORE_INT(r16,3)
+	RESTORE_INT(r18,3)
-	RESTORE_INT(r15,2)
+	RESTORE_INT(r17,2)
-	RESTORE_INT(r14,1)
+	RESTORE_INT(r16,1)
-	RESTORE_INT(r13,0)
+	RESTORE_INT(r15,0)
 
 	EPILOGUE
 	blr
@@ -234,3 +234,11 @@ DEF(void,flush_icache,(void *start, int len)):
 	sync		   /* finish up */
 	isync
 	blr
+
+DEF(void,primitive_inline_cache_miss,(void)):
+    mflr r3
+    PROLOGUE
+    bl MANGLE(inline_cache_miss)
+    EPILOGUE
+    mtctr r3
+    bctr

vm/cpu-ppc.hpp

@@ -2,16 +2,58 @@ namespace factor
 {
 
 #define FACTOR_CPU_STRING "ppc"
-#define VM_ASM_API
+#define VM_ASM_API VM_C_API
 
-register cell ds asm("r29");
+register cell ds asm("r13");
-register cell rs asm("r30");
+register cell rs asm("r14");
 
-void c_to_factor(cell quot);
+inline static void check_call_site(cell return_address)
-void undefined(cell word);
+{
-void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy);
+#ifdef FACTOR_DEBUG
-void throw_impl(cell quot, stack_frame *rewind);
+	cell insn = *(cell *)return_address;
-void lazy_jit_compile(cell quot);
+	assert((insn & 0x3) == 0x1);
-void flush_icache(cell start, cell len);
+	assert((insn >> 26) == 0x12);
+#endif
+}
+
+#define B_MASK 0x3fffffc
+
+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;
+	return (void *)(signed_addr + 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));
+	*(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):);
+}
+
+/* Defined in assembly */
+VM_ASM_API void c_to_factor(cell quot);
+VM_ASM_API void throw_impl(cell quot, stack_frame *rewind);
+VM_ASM_API void lazy_jit_compile(cell quot);
+VM_ASM_API void flush_icache(cell start, cell len);
+
+VM_ASM_API void set_callstack(stack_frame *to,
+			       stack_frame *from,
+			       cell length,
+			       void *(*memcpy)(void*,const void*, size_t));
 
 }

vm/cpu-x86.32.S

@@ -30,7 +30,6 @@ and the callstack top is passed in EDX */
 	pop %ebx
 
 #define QUOT_XT_OFFSET 16
-#define WORD_XT_OFFSET 30
 
 /* We pass a function pointer to memcpy to work around a Mac OS X
 ABI limitation which would otherwise require us to do a bizzaro PC-relative

vm/cpu-x86.64.S

@@ -62,7 +62,6 @@
 #endif
 
 #define QUOT_XT_OFFSET 36
-#define WORD_XT_OFFSET 66
 
 /* We pass a function pointer to memcpy to work around a Mac OS X
 ABI limitation which would otherwise require us to do a bizzaro PC-relative

vm/inline_cache.cpp

@@ -21,6 +21,8 @@ void deallocate_inline_cache(cell return_address)
 {
 	/* Find the call target. */
 	void *old_xt = get_call_target(return_address);
+	check_code_pointer((cell)old_xt);
+
 	code_block *old_block = (code_block *)old_xt - 1;
 	cell old_type = old_block->type;