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

basis/compiler/cfg/hats/hats.factor

@@ -39,6 +39,7 @@ IN: compiler.cfg.hats
 : ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
 : ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
 : ^^not ( src -- dst ) ^^i1 ##not ; inline
+: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
 : ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
 : ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
 : ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline

basis/compiler/cfg/instructions/instructions.factor

@@ -92,6 +92,7 @@ INSN: ##shl-imm < ##binary-imm ;
 INSN: ##shr-imm < ##binary-imm ;
 INSN: ##sar-imm < ##binary-imm ;
 INSN: ##not < ##unary ;
+INSN: ##log2 < ##unary ;
 
 ! Overflowing arithmetic
 TUPLE: ##fixnum-overflow < insn src1 src2 ;

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -53,6 +53,9 @@ IN: compiler.cfg.intrinsics.fixnum
 : emit-fixnum-bitnot ( -- )
     ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
 
+: emit-fixnum-log2 ( -- )
+    ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
+
 : (emit-fixnum*fast) ( -- dst )
     2inputs ^^untag-fixnum ^^mul ;
 

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -19,6 +19,7 @@ QUALIFIED: slots.private
 QUALIFIED: strings.private
 QUALIFIED: classes.tuple.private
 QUALIFIED: math.private
+QUALIFIED: math.integers.private
 QUALIFIED: alien.accessors
 IN: compiler.cfg.intrinsics
 
@@ -93,6 +94,9 @@ IN: compiler.cfg.intrinsics
         alien.accessors:set-alien-double
     } [ t "intrinsic" set-word-prop ] each ;
 
+: enable-fixnum-log2 ( -- )
+    \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
+
 : emit-intrinsic ( node word -- node/f )
     {
         { \ kernel.private:tag [ drop emit-tag iterate-next ] }
@@ -108,6 +112,7 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
         { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
         { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
+        { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
         { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
         { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
         { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }

basis/compiler/codegen/codegen.factor

@@ -163,6 +163,7 @@ M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
 M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
 M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
 M: ##not     generate-insn dst/src       %not     ;
+M: ##log2    generate-insn dst/src       %log2    ;
 
 : src1/src2 ( insn -- src1 src2 )
     [ src1>> register ] [ src2>> register ] bi ; inline

basis/concurrency/messaging/messaging-docs.factor

@@ -8,20 +8,20 @@ HELP: send
 { $values { "message" object } 
           { "thread" thread } 
 }
-{ $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } 
+{ $description "Send the message to the thread by placing it in the threads mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } 
 { $see-also receive receive-if } ;
 
 HELP: receive
 { $values { "message" object } 
 }
-{ $description "Return a message from the current threades mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } 
+{ $description "Return a message from the current threads mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } 
 { $see-also send receive-if } ;
 
 HELP: receive-if
 { $values { "pred" "a predicate with stack effect " { $snippet "( obj -- ? )" } }  
           { "message" object } 
 }
-{ $description "Return the first message from the current threades mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } 
+{ $description "Return the first message from the current threads mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } 
 { $see-also send receive } ;
 
 HELP: spawn-linked
@@ -29,7 +29,7 @@ HELP: spawn-linked
           { "name" string }
           { "thread" thread } 
 }
-{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } 
+{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threads that restart child threads that crash due to uncaught errors.\n" } 
 { $see-also spawn } ;
 
 ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
@@ -64,7 +64,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
 ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
 "A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:" 
 { $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" } 
-"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them."
+"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threads can be created that are notified when child threads terminate and possibly restart them."
 { $subsection spawn-linked }
 "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
 { $code "["
@@ -74,11 +74,11 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
 "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ;
 
 ARTICLE: "concurrency.messaging" "Message-passing concurrency"
-"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system."
+"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of " { $link "threads" } "."
 $nl
-"A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends."
+"A concurrency-oriented program is one in which multiple threads run simultaneously in a single Factor image or across multiple running Factor instances. The threads can communicate with each other by asynchronous message sends."
 $nl
-"Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code."
+"Although threads can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code."
 { $subsection { "concurrency" "messaging" } }
 { $subsection { "concurrency" "synchronous-sends" } } 
 { $subsection { "concurrency" "exceptions" } } ;

basis/cpu/architecture/architecture.factor

@@ -77,6 +77,7 @@ HOOK: %shl-imm cpu ( dst src1 src2 -- )
 HOOK: %shr-imm cpu ( dst src1 src2 -- )
 HOOK: %sar-imm cpu ( dst src1 src2 -- )
 HOOK: %not     cpu ( dst src -- )
+HOOK: %log2    cpu ( dst src -- )
 
 HOOK: %fixnum-add cpu ( src1 src2 -- )
 HOOK: %fixnum-add-tail cpu ( src1 src2 -- )

basis/cpu/ppc/ppc.factor

@@ -37,8 +37,8 @@ M: ppc %load-immediate ( reg n -- ) swap LOAD ;
 M: ppc %load-indirect ( reg obj -- )
     [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
 
-: %load-dlsym ( symbol dll register -- )
+M: ppc %alien-global ( register symbol dll -- )
-    0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
+    [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
 
 : ds-reg 29 ; inline
 : rs-reg 30 ; inline
@@ -145,8 +145,8 @@ M:: ppc %string-nth ( dst src index temp -- )
         temp temp index ADD
         temp temp index ADD
         temp temp byte-array-offset LHZ
-        temp temp 8 SLWI
+        temp temp 7 SLWI
-        dst dst temp OR
+        dst dst temp XOR
         "end" resolve-label
     ] with-scope ;
 
@@ -172,7 +172,7 @@ M: ppc %sar-imm SRAWI ;
 M: ppc %not     NOT ;
 
 : %alien-invoke-tail ( func dll -- )
-    scratch-reg %load-dlsym scratch-reg MTCTR BCTR ;
+    [ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ;
 
 :: exchange-regs ( r1 r2 -- )
     scratch-reg r1 MR
@@ -411,7 +411,7 @@ M: ppc %set-alien-float swap 0 STFS ;
 M: ppc %set-alien-double swap 0 STFD ;
 
 : load-zone-ptr ( reg -- )
-    [ "nursery" f ] dip %load-dlsym ;
+    "nursery" f %alien-global ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
     [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
@@ -433,14 +433,11 @@ M:: ppc %allot ( dst size class nursery-ptr -- )
     dst class store-header
     dst class store-tagged ;
 
-: %alien-global ( dst name -- )
-    [ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
-
 : load-cards-offset ( dst -- )
-    "cards_offset" %alien-global ;
+    [ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
 
 : load-decks-offset ( dst -- )
-    "decks_offset" %alien-global ;
+    [ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi  ;
 
 M:: ppc %write-barrier ( src card# table -- )
     card-mark scratch-reg LI
@@ -627,14 +624,14 @@ M: ppc %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    "stack_chain" f scratch-reg %load-dlsym
+    scratch-reg "stack_chain" f %alien-global
     scratch-reg scratch-reg 0 LWZ
     1 scratch-reg 0 STW
     ds-reg scratch-reg 8 STW
     rs-reg scratch-reg 12 STW ;
 
 M: ppc %alien-invoke ( symbol dll -- )
-    11 %load-dlsym 11 MTLR BLRL ;
+    [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
 
 M: ppc %alien-callback ( quot -- )
     3 swap %load-indirect "c_to_factor" f %alien-invoke ;

basis/cpu/x86/assembler/assembler.factor

@@ -384,6 +384,8 @@ M: operand CMP OCT: 070 2-operand ;
 
 : XCHG ( dst src -- ) OCT: 207 2-operand ;
 
+: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (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 ;

basis/cpu/x86/x86.factor

@@ -5,10 +5,12 @@ cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
 kernel kernel.private math memory namespaces make sequences
 words system layouts combinators math.order fry locals
 compiler.constants compiler.cfg.registers
-compiler.cfg.instructions compiler.codegen
+compiler.cfg.instructions compiler.cfg.intrinsics
-compiler.codegen.fixup ;
+compiler.codegen compiler.codegen.fixup ;
 IN: cpu.x86
 
+<< enable-fixnum-log2 >>
+
 M: x86 two-operand? t ;
 
 HOOK: temp-reg-1 cpu ( -- reg )
@@ -92,6 +94,7 @@ M: x86 %shl-imm nip SHL ;
 M: x86 %shr-imm nip SHR ;
 M: x86 %sar-imm nip SAR ;
 M: x86 %not     drop NOT ;
+M: x86 %log2    BSR ;
 
 : ?MOV ( dst src -- )
     2dup = [ 2drop ] [ MOV ] if ; inline

basis/stack-checker/known-words/known-words.factor

@@ -99,21 +99,18 @@ M: object infer-call*
     3 infer->r infer-call 3 infer-r> ;
 
 : infer-dip ( -- )
-    commit-literals
     literals get
     [ \ dip def>> infer-quot-here ]
     [ pop 1 infer->r infer-quot-here 1 infer-r>  ]
     if-empty ;
 
 : infer-2dip ( -- )
-    commit-literals
     literals get
     [ \ 2dip def>> infer-quot-here ]
     [ pop 2 infer->r infer-quot-here 2 infer-r>  ]
     if-empty ;
 
 : infer-3dip ( -- )
-    commit-literals
     literals get
     [ \ 3dip def>> infer-quot-here ]
     [ pop 3 infer->r infer-quot-here 3 infer-r>  ]

basis/ui/gadgets/sliders/sliders.factor

@@ -36,8 +36,9 @@ TUPLE: slider < frame elevator thumb saved line ;
     #! A scaling factor such that if x is a slider co-ordinate,
     #! x*n is the screen position of the thumb, and conversely
     #! for x/n. The '1 max' calls avoid division by zero.
-    dup elevator-length over thumb-dim - 1 max
+    [ [ elevator-length ] [ thumb-dim ] bi - 1 max ]
-    swap slider-max* 1 max / ;
+    [ slider-max* 1 max ]
+    bi / ;
 
 : slider>screen ( m scale -- n ) slider-scale * ;
 : screen>slider ( m scale -- n ) slider-scale / ;

core/hashtables/hashtables.factor

@@ -40,7 +40,7 @@ TUPLE: hashtable
     0 >>count 0 >>deleted drop ; inline
 
 : reset-hash ( n hash -- )
-    swap <hash-array> >>array init-hash ;
+    swap <hash-array> >>array init-hash ; inline
 
 : (new-key@) ( key keys i -- keys n empty? )
     3dup swap array-nth dup ((empty)) eq? [

core/math/integers/integers.factor

@@ -40,11 +40,13 @@ M: fixnum bitnot fixnum-bitnot ;
 
 M: fixnum bit? neg shift 1 bitand 0 > ;
 
-: (fixnum-log2) ( accum n -- accum )
+: fixnum-log2 ( x -- n )
-    dup 1 number= [ drop ] [ [ 1+ ] [ 2/ ] bi* (fixnum-log2) ] if ;
+    0 swap [ dup 1 number= not ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while drop ;
-    inline recursive
 
-M: fixnum (log2) 0 swap (fixnum-log2) ;
+M: fixnum (log2) fixnum-log2 ;
+
+M: integer next-power-of-2
+    dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ;
 
 M: bignum >fixnum bignum>fixnum ;
 M: bignum >bignum ;

core/math/math.factor

@@ -53,7 +53,7 @@ PRIVATE>
         "log2 expects positive inputs" throw
     ] [
         (log2)
-    ] if ; foldable
+    ] if ; inline
 
 : zero? ( x -- ? ) 0 number= ; inline
 : 1+ ( x -- y ) 1 + ; inline
@@ -103,14 +103,9 @@ M: float fp-infinity? ( float -- ? )
         drop f
     ] if ;
 
-: (next-power-of-2) ( i n -- n )
+GENERIC: next-power-of-2 ( m -- n ) foldable
-    2dup >= [
-        drop
-    ] [
-        [ 1 shift ] dip (next-power-of-2)
-    ] if ;
 
-: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
+M: real next-power-of-2 1+ >integer next-power-of-2 ;
 
 : power-of-2? ( n -- ? )
     dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable