steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Code cleanups, fix #if intrinsic linearization, faster repeat combinator

slava 2006-04-26 07:05:38 +00:00
parent b458d58b91
commit 973ed2c7ea
4 changed files with 42 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
library/compiler/intrinsics.factor
View File

@ -123,6 +123,7 @@ namespaces sequences words ;
"y" get "x" get "out" get %fixnum-mod ,
] H{
{ +input { { 0 "x" } { 1 "y" } } }
! { +scratch { { 2 "out" } } }
{ +output { "out" } }
} with-template
] "intrinsic" set-word-prop
@ -131,13 +132,13 @@ namespaces sequences words ;
! See the remark on fixnum-mod for vreg usage
[
finalize-contents
T{ vreg f 0 } "quo" set
T{ vreg f 2 } "rem" set
"y" get "x" get 2array
"rem" get "quo" get 2array %fixnum/mod ,
"rem" get "x" get 2array %fixnum/mod ,
] H{
{ +input { { 0 "x" } { 1 "y" } } }
{ +output { "quo" "rem" } }
! { +scratch { { 2 "rem" } } }
{ +output { "x" "rem" } }
} with-template
] "intrinsic" set-word-prop

23
library/compiler/linearizer.factor
View File

@ -15,10 +15,23 @@ DEFER: #terminal?
PREDICATE: #merge #terminal-merge node-successor #terminal? ;
UNION: #terminal POSTPONE: f #return #values #terminal-merge ;
: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
: if-intrinsic ( #call -- quot )
dup node-successor #if?
[ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
PREDICATE: #call #terminal-call
dup node-successor node-successor #terminal?
swap if-intrinsic and ;
UNION: #terminal
POSTPONE: f #return #values #terminal-merge ;
: tail-call? ( -- ? )
node-stack get [ node-successor ] map [ #terminal? ] all? ;
node-stack get [
dup #terminal-call? swap node-successor #terminal? or
] all? ;
GENERIC: linearize* ( node -- next )
@ -74,12 +87,6 @@ M: #label linearize* ( node -- next )
dup node-param dup linearize-call-label >r
renamed-label swap node-child linearize-1 r> ;
: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
: if-intrinsic ( #call -- quot )
dup node-successor #if?
[ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
: linearize-if ( node label -- next )
<label> [
>r >r node-children first2 linearize-child

11
library/compiler/templates.factor
View File

@ -12,6 +12,8 @@ TUPLE: ds-loc n ;
! A call stack location.
TUPLE: cs-loc n ;
UNION: loc ds-loc cs-loc ;
TUPLE: phantom-stack height ;
C: phantom-stack ( -- stack )
@ -75,18 +77,17 @@ M: phantom-stack cut-phantom ( n phantom -- seq )
SYMBOL: phantom-d
SYMBOL: phantom-r
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
: init-templates ( -- )
<phantom-datastack> phantom-d set
<phantom-callstack> phantom-r set ;
: finalize-heights ( -- )
phantom-d get finalize-height
phantom-r get finalize-height ;
phantoms [ finalize-height ] 2apply ;
: alloc-reg ( -- n ) free-vregs get pop ;
: loc? ( obj -- ? ) dup ds-loc? swap cs-loc? or ;
: stack>vreg ( vreg# loc -- operand )
>r <vreg> dup r> %peek , ;
@ -125,8 +126,6 @@ SYMBOL: phantom-r
2drop
] if ;
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
: flush-locs ( phantom phantom -- )
2dup live-locs \ live-locs set
[ dup phantom-locs* [ lazy-store ] 2each ] 2apply ;

23
library/math/math.factor
View File

@ -53,12 +53,25 @@ M: object zero? drop f ;
: ceiling ( x -- y ) neg floor neg ; foldable
: (repeat) ( i n quot -- )
pick pick >=
[ 3drop ] [ [ swap >r call 1+ r> ] keep (repeat) ] if ;
inline
G: repeat 1 standard-combination ; inline
: repeat ( n quot -- | quot: n -- n ) 0 -rot (repeat) ; inline
: (repeat-fixnum) ( i n quot -- )
pick pick fixnum>= [
3drop
] [
[ swap >r call 1 fixnum+fast r> ] keep (repeat-fixnum)
] if ; inline
M: fixnum repeat 0 -rot (repeat-fixnum) ;
: (repeat-bignum) ( i n quot -- )
pick pick bignum>= [
3drop
] [
[ swap >r call 1 bignum+ r> ] keep (repeat-bignum)
] if ; inline
M: bignum repeat 0 -rot (repeat-bignum) ;
: times ( n quot -- | quot: -- )
swap [ >r dup slip r> ] repeat drop ; inline