Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
d33fb83e26
|
|
@ -14,13 +14,12 @@ GENERIC: compute-stack-frame* ( insn -- )
|
|||
frame-required? on
|
||||
stack-frame [ max-stack-frame ] change ;
|
||||
|
||||
M: ##alien-invoke compute-stack-frame*
|
||||
stack-frame>> request-stack-frame ;
|
||||
UNION: stack-frame-insn
|
||||
##alien-invoke
|
||||
##alien-indirect
|
||||
##alien-callback ;
|
||||
|
||||
M: ##alien-indirect compute-stack-frame*
|
||||
stack-frame>> request-stack-frame ;
|
||||
|
||||
M: ##alien-callback compute-stack-frame*
|
||||
M: stack-frame-insn compute-stack-frame*
|
||||
stack-frame>> request-stack-frame ;
|
||||
|
||||
M: ##call compute-stack-frame*
|
||||
|
|
@ -40,6 +39,8 @@ M: insn compute-stack-frame*
|
|||
] when ;
|
||||
|
||||
\ _spill t frame-required? set-word-prop
|
||||
\ ##unary-float-function t frame-required? set-word-prop
|
||||
\ ##binary-float-function t frame-required? set-word-prop
|
||||
|
||||
: compute-stack-frame ( insns -- )
|
||||
frame-required? off
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ M: ##slot temp-vregs temp>> 1array ;
|
|||
M: ##set-slot temp-vregs temp>> 1array ;
|
||||
M: ##string-nth temp-vregs temp>> 1array ;
|
||||
M: ##set-string-nth-fast temp-vregs temp>> 1array ;
|
||||
M: ##box-displaced-alien temp-vregs temp>> 1array ;
|
||||
M: ##box-displaced-alien temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
|
||||
M: ##compare temp-vregs temp>> 1array ;
|
||||
M: ##compare-imm temp-vregs temp>> 1array ;
|
||||
M: ##compare-float temp-vregs temp>> 1array ;
|
||||
|
|
|
|||
|
|
@ -47,6 +47,8 @@ IN: compiler.cfg.hats
|
|||
: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
|
||||
: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline
|
||||
: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline
|
||||
: ^^unary-float-function ( src func -- dst ) ^^r2 ##unary-float-function ; inline
|
||||
: ^^binary-float-function ( src1 src2 func -- dst ) ^^r3 ##binary-float-function ; inline
|
||||
: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
|
||||
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
|
||||
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
|
||||
|
|
@ -56,7 +58,7 @@ IN: compiler.cfg.hats
|
|||
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
||||
: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
|
||||
: ^^box-displaced-alien ( base displacement base-class -- dst )
|
||||
^^r3 [ next-vreg ] dip ##box-displaced-alien ; inline
|
||||
^^r3 [ next-vreg next-vreg ] dip ##box-displaced-alien ; inline
|
||||
: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
|
||||
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
|
||||
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
|
||||
|
|
|
|||
|
|
@ -112,6 +112,10 @@ INSN: ##min-float < ##binary ;
|
|||
INSN: ##max-float < ##binary ;
|
||||
INSN: ##sqrt < ##unary ;
|
||||
|
||||
! libc intrinsics
|
||||
INSN: ##unary-float-function < ##unary func ;
|
||||
INSN: ##binary-float-function < ##binary func ;
|
||||
|
||||
! Float/integer conversion
|
||||
INSN: ##float>integer < ##unary ;
|
||||
INSN: ##integer>float < ##unary ;
|
||||
|
|
@ -122,7 +126,7 @@ INSN: ##unbox-float < ##unary ;
|
|||
INSN: ##unbox-any-c-ptr < ##unary/temp ;
|
||||
INSN: ##box-float < ##unary/temp ;
|
||||
INSN: ##box-alien < ##unary/temp ;
|
||||
INSN: ##box-displaced-alien < ##binary temp base-class ;
|
||||
INSN: ##box-displaced-alien < ##binary temp1 temp2 base-class ;
|
||||
|
||||
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
|
||||
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
|
||||
|
|
@ -252,6 +256,11 @@ UNION: vreg-insn
|
|||
_compare-imm-branch
|
||||
_dispatch ;
|
||||
|
||||
! Instructions that kill all live vregs but cannot trigger GC
|
||||
UNION: partial-sync-insn
|
||||
##unary-float-function
|
||||
##binary-float-function ;
|
||||
|
||||
! Instructions that kill all live vregs
|
||||
UNION: kill-vreg-insn
|
||||
##call
|
||||
|
|
@ -270,6 +279,8 @@ UNION: output-float-insn
|
|||
##min-float
|
||||
##max-float
|
||||
##sqrt
|
||||
##unary-float-function
|
||||
##binary-float-function
|
||||
##integer>float
|
||||
##unbox-float
|
||||
##alien-float
|
||||
|
|
@ -284,6 +295,8 @@ UNION: input-float-insn
|
|||
##min-float
|
||||
##max-float
|
||||
##sqrt
|
||||
##unary-float-function
|
||||
##binary-float-function
|
||||
##float>integer
|
||||
##box-float
|
||||
##set-alien-float
|
||||
|
|
|
|||
|
|
@ -18,3 +18,9 @@ IN: compiler.cfg.intrinsics.float
|
|||
|
||||
: emit-fsqrt ( -- )
|
||||
ds-pop ^^sqrt ds-push ;
|
||||
|
||||
: emit-unary-float-function ( func -- )
|
||||
[ ds-pop ] dip ^^unary-float-function ds-push ;
|
||||
|
||||
: emit-binary-float-function ( func -- )
|
||||
[ 2inputs ] dip ^^binary-float-function ds-push ;
|
||||
|
|
|
|||
|
|
@ -108,6 +108,27 @@ IN: compiler.cfg.intrinsics
|
|||
math.floats.private:float-max
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-float-functions ( -- )
|
||||
! Everything except for fsqrt
|
||||
{
|
||||
math.libm:facos
|
||||
math.libm:fasin
|
||||
math.libm:fatan
|
||||
math.libm:fatan2
|
||||
math.libm:fcos
|
||||
math.libm:fsin
|
||||
math.libm:ftan
|
||||
math.libm:fcosh
|
||||
math.libm:fsinh
|
||||
math.libm:ftanh
|
||||
math.libm:fexp
|
||||
math.libm:flog
|
||||
math.libm:fpow
|
||||
math.libm:facosh
|
||||
math.libm:fasinh
|
||||
math.libm:fatanh
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-min/max ( -- )
|
||||
{
|
||||
math.integers.private:fixnum-min
|
||||
|
|
@ -157,6 +178,22 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
|
||||
{ \ math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
|
||||
{ \ math.libm:fsqrt [ drop emit-fsqrt ] }
|
||||
{ \ math.libm:facos [ drop "acos" emit-unary-float-function ] }
|
||||
{ \ math.libm:fasin [ drop "asin" emit-unary-float-function ] }
|
||||
{ \ math.libm:fatan [ drop "atan" emit-unary-float-function ] }
|
||||
{ \ math.libm:fatan2 [ drop "atan2" emit-binary-float-function ] }
|
||||
{ \ math.libm:fcos [ drop "cos" emit-unary-float-function ] }
|
||||
{ \ math.libm:fsin [ drop "sin" emit-unary-float-function ] }
|
||||
{ \ math.libm:ftan [ drop "tan" emit-unary-float-function ] }
|
||||
{ \ math.libm:fcosh [ drop "cosh" emit-unary-float-function ] }
|
||||
{ \ math.libm:fsinh [ drop "sinh" emit-unary-float-function ] }
|
||||
{ \ math.libm:ftanh [ drop "tanh" emit-unary-float-function ] }
|
||||
{ \ math.libm:fexp [ drop "exp" emit-unary-float-function ] }
|
||||
{ \ math.libm:flog [ drop "log" emit-unary-float-function ] }
|
||||
{ \ math.libm:fpow [ drop "pow" emit-binary-float-function ] }
|
||||
{ \ math.libm:facosh [ drop "acosh" emit-unary-float-function ] }
|
||||
{ \ math.libm:fasinh [ drop "asinh" emit-unary-float-function ] }
|
||||
{ \ math.libm:fatanh [ drop "atanh" emit-unary-float-function ] }
|
||||
{ \ slots.private:slot [ emit-slot ] }
|
||||
{ \ slots.private:set-slot [ emit-set-slot ] }
|
||||
{ \ strings.private:string-nth [ drop emit-string-nth ] }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs heaps kernel namespaces sequences fry math
|
||||
math.order combinators arrays sorting compiler.utilities
|
||||
math.order combinators arrays sorting compiler.utilities locals
|
||||
compiler.cfg.linear-scan.live-intervals
|
||||
compiler.cfg.linear-scan.allocation.spilling
|
||||
compiler.cfg.linear-scan.allocation.splitting
|
||||
|
|
@ -34,22 +34,48 @@ IN: compiler.cfg.linear-scan.allocation
|
|||
[ drop assign-blocked-register ]
|
||||
} cond ;
|
||||
|
||||
: handle-interval ( live-interval -- )
|
||||
[
|
||||
start>>
|
||||
: handle-sync-point ( n -- )
|
||||
[ active-intervals get values ] dip
|
||||
[ '[ [ _ spill ] each ] each ]
|
||||
[ drop [ delete-all ] each ]
|
||||
2bi ;
|
||||
|
||||
:: handle-progress ( n sync? -- )
|
||||
n {
|
||||
[ progress set ]
|
||||
[ deactivate-intervals ]
|
||||
[ activate-intervals ] tri
|
||||
] [ assign-register ] bi ;
|
||||
[ sync? [ handle-sync-point ] [ drop ] if ]
|
||||
[ activate-intervals ]
|
||||
} cleave ;
|
||||
|
||||
GENERIC: handle ( obj -- )
|
||||
|
||||
M: live-interval handle ( live-interval -- )
|
||||
[ start>> f handle-progress ] [ assign-register ] bi ;
|
||||
|
||||
M: sync-point handle ( sync-point -- )
|
||||
n>> t handle-progress ;
|
||||
|
||||
: smallest-heap ( heap1 heap2 -- heap )
|
||||
! If heap1 and heap2 have the same key, favors heap1.
|
||||
[ [ heap-peek nip ] bi@ <= ] most ;
|
||||
|
||||
: (allocate-registers) ( -- )
|
||||
unhandled-intervals get [ handle-interval ] slurp-heap ;
|
||||
{
|
||||
{ [ unhandled-intervals get heap-empty? ] [ unhandled-sync-points get ] }
|
||||
{ [ unhandled-sync-points get heap-empty? ] [ unhandled-intervals get ] }
|
||||
! If a live interval begins at the same location as a sync point,
|
||||
! process the sync point before the live interval. This ensures that the
|
||||
! return value of C function calls doesn't get spilled and reloaded
|
||||
! unnecessarily.
|
||||
[ unhandled-sync-points get unhandled-intervals get smallest-heap ]
|
||||
} cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
|
||||
|
||||
: finish-allocation ( -- )
|
||||
active-intervals inactive-intervals
|
||||
[ get values [ handled-intervals get push-all ] each ] bi@ ;
|
||||
|
||||
: allocate-registers ( live-intervals machine-registers -- live-intervals )
|
||||
: allocate-registers ( live-intervals sync-point machine-registers -- live-intervals )
|
||||
init-allocator
|
||||
init-unhandled
|
||||
(allocate-registers)
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ ERROR: bad-live-ranges interval ;
|
|||
2bi ;
|
||||
|
||||
: assign-spill ( live-interval -- )
|
||||
dup vreg>> assign-spill-slot >>spill-to drop ;
|
||||
dup vreg>> vreg-spill-slot >>spill-to drop ;
|
||||
|
||||
: spill-before ( before -- before/f )
|
||||
! If the interval does not have any usages before the spill location,
|
||||
|
|
@ -46,7 +46,7 @@ ERROR: bad-live-ranges interval ;
|
|||
] if ;
|
||||
|
||||
: assign-reload ( live-interval -- )
|
||||
dup vreg>> assign-spill-slot >>reload-from drop ;
|
||||
dup vreg>> vreg-spill-slot >>reload-from drop ;
|
||||
|
||||
: spill-after ( after -- after/f )
|
||||
! If the interval has no more usages after the spill location,
|
||||
|
|
|
|||
|
|
@ -120,15 +120,19 @@ SYMBOL: unhandled-intervals
|
|||
rep-size cfg get
|
||||
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ;
|
||||
|
||||
! Minheap of sync points which still need to be processed
|
||||
SYMBOL: unhandled-sync-points
|
||||
|
||||
! Mapping from vregs to spill slots
|
||||
SYMBOL: spill-slots
|
||||
|
||||
: assign-spill-slot ( vreg -- n )
|
||||
: vreg-spill-slot ( vreg -- n )
|
||||
spill-slots get [ rep-of next-spill-slot ] cache ;
|
||||
|
||||
: init-allocator ( registers -- )
|
||||
registers set
|
||||
<min-heap> unhandled-intervals set
|
||||
<min-heap> unhandled-sync-points set
|
||||
[ V{ } clone ] reg-class-assoc active-intervals set
|
||||
[ V{ } clone ] reg-class-assoc inactive-intervals set
|
||||
V{ } clone handled-intervals set
|
||||
|
|
@ -136,9 +140,10 @@ SYMBOL: spill-slots
|
|||
H{ } clone spill-slots set
|
||||
-1 progress set ;
|
||||
|
||||
: init-unhandled ( live-intervals -- )
|
||||
[ [ start>> ] keep ] { } map>assoc
|
||||
unhandled-intervals get heap-push-all ;
|
||||
: init-unhandled ( live-intervals sync-points -- )
|
||||
[ [ [ start>> ] keep ] { } map>assoc unhandled-intervals get heap-push-all ]
|
||||
[ [ [ n>> ] keep ] { } map>assoc unhandled-sync-points get heap-push-all ]
|
||||
bi* ;
|
||||
|
||||
! A utility used by register-status and spill-status words
|
||||
: free-positions ( new -- assoc )
|
||||
|
|
|
|||
|
|
@ -28,6 +28,20 @@ SYMBOL: pending-interval-assoc
|
|||
: remove-pending ( live-interval -- )
|
||||
vreg>> pending-interval-assoc get delete-at ;
|
||||
|
||||
: (vreg>reg) ( vreg pending -- reg )
|
||||
! If a live vreg is not in the pending set, then it must
|
||||
! have been spilled.
|
||||
?at [ spill-slots get at <spill-slot> ] unless ;
|
||||
|
||||
: vreg>reg ( vreg -- reg )
|
||||
pending-interval-assoc get (vreg>reg) ;
|
||||
|
||||
: vregs>regs ( vregs -- assoc )
|
||||
dup assoc-empty? [
|
||||
pending-interval-assoc get
|
||||
'[ _ (vreg>reg) ] assoc-map
|
||||
] unless ;
|
||||
|
||||
! Minheap of live intervals which still need a register allocation
|
||||
SYMBOL: unhandled-intervals
|
||||
|
||||
|
|
@ -96,8 +110,6 @@ SYMBOL: register-live-outs
|
|||
|
||||
GENERIC: assign-registers-in-insn ( insn -- )
|
||||
|
||||
: vreg>reg ( vreg -- reg ) pending-interval-assoc get at ;
|
||||
|
||||
RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
|
||||
|
||||
M: vreg-insn assign-registers-in-insn
|
||||
|
|
@ -123,7 +135,7 @@ M: vreg-insn assign-registers-in-insn
|
|||
[
|
||||
[
|
||||
2dup spill-on-gc?
|
||||
[ swap [ assign-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
|
||||
[ swap [ vreg-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
|
||||
] assoc-each
|
||||
] { } make ;
|
||||
|
||||
|
|
@ -137,23 +149,13 @@ M: ##gc assign-registers-in-insn
|
|||
|
||||
M: insn assign-registers-in-insn drop ;
|
||||
|
||||
: compute-live-values ( vregs -- assoc )
|
||||
! If a live vreg is not in active or inactive, then it must have been
|
||||
! spilled.
|
||||
dup assoc-empty? [
|
||||
pending-interval-assoc get
|
||||
'[ _ ?at [ ] [ spill-slots get at <spill-slot> ] if ] assoc-map
|
||||
] unless ;
|
||||
|
||||
: begin-block ( bb -- )
|
||||
dup basic-block set
|
||||
dup block-from activate-new-intervals
|
||||
[ live-in compute-live-values ] keep
|
||||
register-live-ins get set-at ;
|
||||
[ live-in vregs>regs ] keep register-live-ins get set-at ;
|
||||
|
||||
: end-block ( bb -- )
|
||||
[ live-out compute-live-values ] keep
|
||||
register-live-outs get set-at ;
|
||||
[ live-out vregs>regs ] keep register-live-outs get set-at ;
|
||||
|
||||
ERROR: bad-vreg vreg ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@ IN: compiler.cfg.linear-scan.debugger
|
|||
[
|
||||
[ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
|
||||
live-intervals set
|
||||
f
|
||||
] dip
|
||||
allocate-registers drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,11 +30,12 @@ M: live-interval covers? ( insn# live-interval -- ? )
|
|||
covers?
|
||||
] if ;
|
||||
|
||||
ERROR: dead-value-error vreg ;
|
||||
: add-new-range ( from to live-interval -- )
|
||||
[ <live-range> ] dip ranges>> push ;
|
||||
|
||||
: shorten-range ( n live-interval -- )
|
||||
dup ranges>> empty?
|
||||
[ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ;
|
||||
[ dupd add-new-range ] [ ranges>> last (>>from) ] if ;
|
||||
|
||||
: extend-range ( from to live-range -- )
|
||||
ranges>> last
|
||||
|
|
@ -42,9 +43,6 @@ ERROR: dead-value-error vreg ;
|
|||
[ min ] change-from
|
||||
drop ;
|
||||
|
||||
: add-new-range ( from to live-interval -- )
|
||||
[ <live-range> ] dip ranges>> push ;
|
||||
|
||||
: extend-range? ( to live-interval -- ? )
|
||||
ranges>> [ drop f ] [ last from>> >= ] if-empty ;
|
||||
|
||||
|
|
@ -52,8 +50,18 @@ ERROR: dead-value-error vreg ;
|
|||
2dup extend-range?
|
||||
[ extend-range ] [ add-new-range ] if ;
|
||||
|
||||
: add-use ( n live-interval -- )
|
||||
uses>> push ;
|
||||
GENERIC: operands-in-registers? ( insn -- ? )
|
||||
|
||||
M: vreg-insn operands-in-registers? drop t ;
|
||||
|
||||
M: partial-sync-insn operands-in-registers? drop f ;
|
||||
|
||||
: add-def ( insn live-interval -- )
|
||||
[ insn#>> ] [ uses>> ] bi* push ;
|
||||
|
||||
: add-use ( insn live-interval -- )
|
||||
! Every use is a potential def, no SSA here baby!
|
||||
over operands-in-registers? [ add-def ] [ 2drop ] if ;
|
||||
|
||||
: <live-interval> ( vreg -- live-interval )
|
||||
\ live-interval new
|
||||
|
|
@ -68,51 +76,68 @@ ERROR: dead-value-error vreg ;
|
|||
M: live-interval hashcode*
|
||||
nip [ start>> ] [ end>> 1000 * ] bi + ;
|
||||
|
||||
M: live-interval clone
|
||||
call-next-method [ clone ] change-uses ;
|
||||
|
||||
! Mapping from vreg to live-interval
|
||||
SYMBOL: live-intervals
|
||||
|
||||
: live-interval ( vreg live-intervals -- live-interval )
|
||||
[ <live-interval> ] cache ;
|
||||
: live-interval ( vreg -- live-interval )
|
||||
live-intervals get [ <live-interval> ] cache ;
|
||||
|
||||
GENERIC: compute-live-intervals* ( insn -- )
|
||||
|
||||
M: insn compute-live-intervals* drop ;
|
||||
|
||||
: handle-output ( n vreg live-intervals -- )
|
||||
: handle-output ( insn vreg -- )
|
||||
live-interval
|
||||
[ add-use ] [ shorten-range ] 2bi ;
|
||||
[ [ insn#>> ] dip shorten-range ] [ add-def ] 2bi ;
|
||||
|
||||
: handle-input ( n vreg live-intervals -- )
|
||||
: handle-input ( insn vreg -- )
|
||||
live-interval
|
||||
[ [ basic-block get block-from ] 2dip add-range ] [ add-use ] 2bi ;
|
||||
[ [ [ basic-block get block-from ] dip insn#>> ] dip add-range ] [ add-use ] 2bi ;
|
||||
|
||||
: handle-temp ( n vreg live-intervals -- )
|
||||
: handle-temp ( insn vreg -- )
|
||||
live-interval
|
||||
[ dupd add-range ] [ add-use ] 2bi ;
|
||||
[ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ;
|
||||
|
||||
M: vreg-insn compute-live-intervals*
|
||||
dup insn#>>
|
||||
live-intervals get
|
||||
[ [ defs-vreg ] 2dip '[ [ _ ] dip _ handle-output ] when* ]
|
||||
[ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
|
||||
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
|
||||
3tri ;
|
||||
[ dup defs-vreg [ handle-output ] with when* ]
|
||||
[ dup uses-vregs [ handle-input ] with each ]
|
||||
[ dup temp-vregs [ handle-temp ] with each ]
|
||||
tri ;
|
||||
|
||||
: handle-live-out ( bb -- )
|
||||
live-out keys
|
||||
basic-block get [ block-from ] [ block-to ] bi
|
||||
live-intervals get '[
|
||||
[ _ _ ] dip _ live-interval add-range
|
||||
] each ;
|
||||
[ block-from ] [ block-to ] [ live-out keys ] tri
|
||||
[ live-interval add-range ] with with each ;
|
||||
|
||||
! A location where all registers have to be spilled
|
||||
TUPLE: sync-point n ;
|
||||
|
||||
C: <sync-point> sync-point
|
||||
|
||||
! Sequence of sync points
|
||||
SYMBOL: sync-points
|
||||
|
||||
GENERIC: compute-sync-points* ( insn -- )
|
||||
|
||||
M: partial-sync-insn compute-sync-points*
|
||||
insn#>> <sync-point> sync-points get push ;
|
||||
|
||||
M: insn compute-sync-points* drop ;
|
||||
|
||||
: compute-live-intervals-step ( bb -- )
|
||||
[ basic-block set ]
|
||||
[ handle-live-out ]
|
||||
[ instructions>> <reversed> [ compute-live-intervals* ] each ] tri ;
|
||||
[
|
||||
instructions>> <reversed> [
|
||||
[ compute-live-intervals* ]
|
||||
[ compute-sync-points* ]
|
||||
bi
|
||||
] each
|
||||
] tri ;
|
||||
|
||||
: init-live-intervals ( -- )
|
||||
H{ } clone live-intervals set
|
||||
V{ } clone sync-points set ;
|
||||
|
||||
: compute-start/end ( live-interval -- )
|
||||
dup ranges>> [ first from>> ] [ last to>> ] bi
|
||||
[ >>start ] [ >>end ] bi* drop ;
|
||||
|
|
@ -122,10 +147,10 @@ ERROR: bad-live-interval live-interval ;
|
|||
: check-start ( live-interval -- )
|
||||
dup start>> -1 = [ bad-live-interval ] [ drop ] if ;
|
||||
|
||||
: finish-live-intervals ( live-intervals -- )
|
||||
: finish-live-intervals ( live-intervals -- seq )
|
||||
! Since live intervals are computed in a backward order, we have
|
||||
! to reverse some sequences, and compute the start and end.
|
||||
[
|
||||
values dup [
|
||||
{
|
||||
[ ranges>> reverse-here ]
|
||||
[ uses>> reverse-here ]
|
||||
|
|
@ -134,12 +159,11 @@ ERROR: bad-live-interval live-interval ;
|
|||
} cleave
|
||||
] each ;
|
||||
|
||||
: compute-live-intervals ( cfg -- live-intervals )
|
||||
H{ } clone [
|
||||
live-intervals set
|
||||
linearization-order <reversed>
|
||||
[ compute-live-intervals-step ] each
|
||||
] keep values dup finish-live-intervals ;
|
||||
: compute-live-intervals ( cfg -- live-intervals sync-points )
|
||||
init-live-intervals
|
||||
linearization-order <reversed> [ compute-live-intervals-step ] each
|
||||
live-intervals get finish-live-intervals
|
||||
sync-points get ;
|
||||
|
||||
: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
|
||||
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
|
||||
|
|
|
|||
|
|
@ -141,7 +141,9 @@ M: ##set-string-nth-fast rename-insn-temps
|
|||
TEMP-QUOT change-temp drop ;
|
||||
|
||||
M: ##box-displaced-alien rename-insn-temps
|
||||
TEMP-QUOT change-temp drop ;
|
||||
TEMP-QUOT change-temp1
|
||||
TEMP-QUOT change-temp2
|
||||
drop ;
|
||||
|
||||
M: ##compare rename-insn-temps
|
||||
TEMP-QUOT change-temp drop ;
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ M: ##slot temp-vreg-reps drop { int-rep } ;
|
|||
M: ##set-slot temp-vreg-reps drop { int-rep } ;
|
||||
M: ##string-nth temp-vreg-reps drop { int-rep } ;
|
||||
M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
|
||||
M: ##box-displaced-alien temp-vreg-reps drop { int-rep } ;
|
||||
M: ##box-displaced-alien temp-vreg-reps drop { int-rep int-rep } ;
|
||||
M: ##compare temp-vreg-reps drop { int-rep } ;
|
||||
M: ##compare-imm temp-vreg-reps drop { int-rep } ;
|
||||
M: ##compare-float temp-vreg-reps drop { int-rep } ;
|
||||
|
|
|
|||
|
|
@ -12,6 +12,8 @@ TUPLE: commutative-expr < binary-expr ;
|
|||
TUPLE: compare-expr < binary-expr cc ;
|
||||
TUPLE: constant-expr < expr value ;
|
||||
TUPLE: reference-expr < expr value ;
|
||||
TUPLE: unary-float-function-expr < expr in func ;
|
||||
TUPLE: binary-float-function-expr < expr in1 in2 func ;
|
||||
TUPLE: box-displaced-alien-expr < expr displacement base base-class ;
|
||||
|
||||
: <constant> ( constant -- expr )
|
||||
|
|
@ -94,6 +96,19 @@ M: ##box-displaced-alien >expr
|
|||
[ base-class>> ]
|
||||
} cleave box-displaced-alien-expr boa ;
|
||||
|
||||
M: ##unary-float-function >expr
|
||||
[ class ] [ src>> vreg>vn ] [ func>> ] tri
|
||||
unary-float-function-expr boa ;
|
||||
|
||||
M: ##binary-float-function >expr
|
||||
{
|
||||
[ class ]
|
||||
[ src1>> vreg>vn ]
|
||||
[ src2>> vreg>vn ]
|
||||
[ func>> ]
|
||||
} cleave
|
||||
binary-float-function-expr boa ;
|
||||
|
||||
M: ##flushable >expr drop next-input-expr ;
|
||||
|
||||
: init-expressions ( -- )
|
||||
|
|
|
|||
|
|
@ -176,6 +176,12 @@ M: ##max-float generate-insn dst/src1/src2 %max-float ;
|
|||
|
||||
M: ##sqrt generate-insn dst/src %sqrt ;
|
||||
|
||||
M: ##unary-float-function generate-insn
|
||||
[ dst/src ] [ func>> ] bi %unary-float-function ;
|
||||
|
||||
M: ##binary-float-function generate-insn
|
||||
[ dst/src1/src2 ] [ func>> ] bi %binary-float-function ;
|
||||
|
||||
M: ##integer>float generate-insn dst/src %integer>float ;
|
||||
M: ##float>integer generate-insn dst/src %float>integer ;
|
||||
|
||||
|
|
@ -187,7 +193,7 @@ M: ##box-float generate-insn dst/src/temp %box-float ;
|
|||
M: ##box-alien generate-insn dst/src/temp %box-alien ;
|
||||
|
||||
M: ##box-displaced-alien generate-insn
|
||||
[ dst/src1/src2 ] [ temp>> ] bi %box-displaced-alien ;
|
||||
[ dst/src1/src2 ] [ temp1>> ] [ temp2>> ] tri %box-displaced-alien ;
|
||||
|
||||
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
|
||||
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ math hashtables.private math.private namespaces sequences tools.test
|
|||
namespaces.private slots.private sequences.private byte-arrays alien
|
||||
alien.accessors layouts words definitions compiler.units io
|
||||
combinators vectors grouping make alien.c-types combinators.short-circuit
|
||||
math.order ;
|
||||
math.order math.libm ;
|
||||
QUALIFIED: namespaces.private
|
||||
IN: compiler.tests.codegen
|
||||
|
||||
|
|
@ -407,4 +407,9 @@ cell 4 = [
|
|||
: missing-gc-check-1 ( a -- b ) { fixnum } declare <alien> ;
|
||||
: missing-gc-check-2 ( -- ) 10000000 [ missing-gc-check-1 drop ] each-integer ;
|
||||
|
||||
[ ] [ missing-gc-check-2 ] unit-test
|
||||
[ ] [ missing-gc-check-2 ] unit-test
|
||||
|
||||
[ 1 0.169967142900241 ] [ 1.4 [ 1 swap fcos ] compile-call ] unit-test
|
||||
[ 1 0.169967142900241 ] [ 1.4 1 [ swap fcos ] compile-call ] unit-test
|
||||
[ 0.169967142900241 0.9854497299884601 ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call ] unit-test
|
||||
[ 1 0.169967142900241 0.9854497299884601 ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call ] unit-test
|
||||
|
|
@ -519,6 +519,14 @@ cell 8 = [
|
|||
underlying>>
|
||||
] unit-test
|
||||
|
||||
[ ALIEN: 1234 ALIEN: 2234 ] [
|
||||
ALIEN: 234 [
|
||||
{ c-ptr } declare
|
||||
[ 1000 swap <displaced-alien> ]
|
||||
[ 2000 swap <displaced-alien> ] bi
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
[
|
||||
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
|
||||
] must-fail
|
||||
|
|
|
|||
|
|
@ -115,6 +115,8 @@ HOOK: %div-float cpu ( dst src1 src2 -- )
|
|||
HOOK: %min-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %max-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %sqrt cpu ( dst src -- )
|
||||
HOOK: %unary-float-function cpu ( dst src func -- )
|
||||
HOOK: %binary-float-function cpu ( dst src1 src2 func -- )
|
||||
|
||||
HOOK: %integer>float cpu ( dst src -- )
|
||||
HOOK: %float>integer cpu ( dst src -- )
|
||||
|
|
@ -124,7 +126,7 @@ HOOK: %unbox-float cpu ( dst src -- )
|
|||
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
|
||||
HOOK: %box-float cpu ( dst src temp -- )
|
||||
HOOK: %box-alien cpu ( dst src temp -- )
|
||||
HOOK: %box-displaced-alien cpu ( dst displacement base temp -- )
|
||||
HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 -- )
|
||||
|
||||
HOOK: %alien-unsigned-1 cpu ( dst src -- )
|
||||
HOOK: %alien-unsigned-2 cpu ( dst src -- )
|
||||
|
|
|
|||
|
|
@ -335,7 +335,7 @@ M:: ppc %box-alien ( dst src temp -- )
|
|||
"f" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: ppc %box-displaced-alien ( dst displacement base temp -- )
|
||||
M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- )
|
||||
[
|
||||
"end" define-label
|
||||
"ok" define-label
|
||||
|
|
@ -343,7 +343,12 @@ M:: ppc %box-displaced-alien ( dst displacement base temp -- )
|
|||
dst base MR
|
||||
0 displacement 0 CMPI
|
||||
"end" get BEQ
|
||||
! Quickly use displacement' before its needed for real, as allot temporary
|
||||
displacement' :> temp
|
||||
dst 4 cells alien temp %allot
|
||||
! If base is already a displaced alien, unpack it
|
||||
base' base MR
|
||||
displacement' displacement MR
|
||||
0 base \ f tag-number CMPI
|
||||
"ok" get BEQ
|
||||
temp base header-offset LWZ
|
||||
|
|
@ -351,11 +356,17 @@ M:: ppc %box-displaced-alien ( dst displacement base temp -- )
|
|||
"ok" get BNE
|
||||
! displacement += base.displacement
|
||||
temp base 3 alien@ LWZ
|
||||
displacement displacement temp ADD
|
||||
displacement' displacement temp ADD
|
||||
! base = base.base
|
||||
base base 1 alien@ LWZ
|
||||
base' base 1 alien@ LWZ
|
||||
"ok" resolve-label
|
||||
dst displacement base temp %allot-alien
|
||||
! Store underlying-alien slot
|
||||
base' dst 1 alien@ STW
|
||||
! Store offset
|
||||
displacement' dst 3 alien@ STW
|
||||
! Store expired slot (its ok to clobber displacement')
|
||||
temp \ f tag-number %load-immediate
|
||||
temp dst 2 alien@ STW
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
|
|||
|
|
@ -197,6 +197,23 @@ M: x86.64 %callback-value ( ctype -- )
|
|||
! Unbox former top of data stack to return registers
|
||||
unbox-return ;
|
||||
|
||||
: float-function-param ( i spill-slot -- )
|
||||
[ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
|
||||
|
||||
: float-function-return ( reg -- )
|
||||
float-regs return-reg double-float-rep copy-register ;
|
||||
|
||||
M:: x86.64 %unary-float-function ( dst src func -- )
|
||||
0 src float-function-param
|
||||
func f %alien-invoke
|
||||
dst float-function-return ;
|
||||
|
||||
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
|
||||
0 src1 float-function-param
|
||||
1 src2 float-function-param
|
||||
func f %alien-invoke
|
||||
dst float-function-return ;
|
||||
|
||||
! The result of reading 4 bytes from memory is a fixnum on
|
||||
! x86-64.
|
||||
enable-alien-4-intrinsics
|
||||
|
|
@ -204,6 +221,9 @@ enable-alien-4-intrinsics
|
|||
! SSE2 is always available on x86-64.
|
||||
enable-sse2
|
||||
|
||||
! Enable fast calling of libc math functions
|
||||
enable-float-functions
|
||||
|
||||
USE: vocabs.loader
|
||||
|
||||
{
|
||||
|
|
|
|||
|
|
@ -278,7 +278,7 @@ M:: x86 %box-alien ( dst src temp -- )
|
|||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: x86 %box-displaced-alien ( dst displacement base temp -- )
|
||||
M:: x86 %box-displaced-alien ( dst displacement base displacement' base' -- )
|
||||
[
|
||||
"end" define-label
|
||||
"ok" define-label
|
||||
|
|
@ -286,17 +286,23 @@ M:: x86 %box-displaced-alien ( dst displacement base temp -- )
|
|||
dst base MOV
|
||||
displacement 0 CMP
|
||||
"end" get JE
|
||||
! Quickly use displacement' before its needed for real, as allot temporary
|
||||
dst 4 cells alien displacement' %allot
|
||||
! If base is already a displaced alien, unpack it
|
||||
base' base MOV
|
||||
displacement' displacement MOV
|
||||
base \ f tag-number CMP
|
||||
"ok" get JE
|
||||
base header-offset [+] alien type-number tag-fixnum CMP
|
||||
"ok" get JNE
|
||||
! displacement += base.displacement
|
||||
displacement base 3 alien@ ADD
|
||||
displacement' base 3 alien@ ADD
|
||||
! base = base.base
|
||||
base base 1 alien@ MOV
|
||||
base' base 1 alien@ MOV
|
||||
"ok" resolve-label
|
||||
dst displacement base temp %allot-alien
|
||||
dst 1 alien@ base' MOV ! alien
|
||||
dst 2 alien@ \ f tag-number MOV ! expired
|
||||
dst 3 alien@ displacement' MOV ! displacement
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
|
|||
|
|
@ -106,10 +106,7 @@ ARTICLE: "numbers" "Numbers"
|
|||
{ $subsection "complex-numbers" }
|
||||
"Advanced features:"
|
||||
{ $subsection "math-vectors" }
|
||||
{ $subsection "math-intervals" }
|
||||
{ $subsection "math-bitfields" }
|
||||
"Implementation:"
|
||||
{ $subsection "math.libm" } ;
|
||||
{ $subsection "math-intervals" } ;
|
||||
|
||||
USE: io.buffers
|
||||
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ IN: math.bits
|
|||
ABOUT: "math.bits"
|
||||
|
||||
ARTICLE: "math.bits" "Number bits virtual sequence"
|
||||
"The " { $vocab-link "math.bits" } " vocabulary implements a virtual sequence which presents an integer as a sequence of bits, with the first element of the sequence being the least significant bit of the integer."
|
||||
{ $subsection bits }
|
||||
{ $subsection <bits> }
|
||||
{ $subsection make-bits } ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel kernel.private math math.private
|
||||
math.libm math.functions arrays math.functions.private sequences
|
||||
parser ;
|
||||
math.functions arrays math.functions.private sequences parser ;
|
||||
IN: math.complex.private
|
||||
|
||||
M: real real-part ; inline
|
||||
|
|
@ -26,8 +25,8 @@ M: complex * [ *re - ] [ *im + ] 2bi rect> ; inline
|
|||
M: complex / [ / ] complex/ ; inline
|
||||
M: complex /f [ /f ] complex/ ; inline
|
||||
M: complex /i [ /i ] complex/ ; inline
|
||||
M: complex abs absq >float fsqrt ; inline
|
||||
M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline
|
||||
M: complex abs absq sqrt ; inline
|
||||
M: complex sqrt >polar [ sqrt ] [ 2.0 / ] bi* polar> ; inline
|
||||
|
||||
IN: syntax
|
||||
|
||||
|
|
|
|||
|
|
@ -30,21 +30,40 @@ IN: math.functions.tests
|
|||
[ 0 ] [ 0 3 ^ ] unit-test
|
||||
|
||||
[ 0.0 ] [ 1 log ] unit-test
|
||||
[ 0.0 ] [ 1.0 log ] unit-test
|
||||
[ 1.0 ] [ e log ] unit-test
|
||||
|
||||
[ t ] [ 1 exp e = ] unit-test
|
||||
[ t ] [ 1.0 exp e = ] unit-test
|
||||
[ 1.0 ] [ -1 exp e * ] unit-test
|
||||
|
||||
[ 1.0 ] [ 0 cosh ] unit-test
|
||||
[ 1.0 ] [ 0.0 cosh ] unit-test
|
||||
[ 0.0 ] [ 1 acosh ] unit-test
|
||||
[ 0.0 ] [ 1.0 acosh ] unit-test
|
||||
|
||||
[ 1.0 ] [ 0 cos ] unit-test
|
||||
[ 1.0 ] [ 0.0 cos ] unit-test
|
||||
[ 0.0 ] [ 1 acos ] unit-test
|
||||
[ 0.0 ] [ 1.0 acos ] unit-test
|
||||
|
||||
[ 0.0 ] [ 0 sinh ] unit-test
|
||||
[ 0.0 ] [ 0.0 sinh ] unit-test
|
||||
[ 0.0 ] [ 0 asinh ] unit-test
|
||||
[ 0.0 ] [ 0.0 asinh ] unit-test
|
||||
|
||||
[ 0.0 ] [ 0 sin ] unit-test
|
||||
[ 0.0 ] [ 0.0 sin ] unit-test
|
||||
[ 0.0 ] [ 0 asin ] unit-test
|
||||
[ 0.0 ] [ 0.0 asin ] unit-test
|
||||
|
||||
[ 0.0 ] [ 0 tan ] unit-test
|
||||
[ t ] [ pi 2 / tan 1.e10 > ] unit-test
|
||||
|
||||
[ t ] [ 10 atan real? ] unit-test
|
||||
[ t ] [ 10.0 atan real? ] unit-test
|
||||
[ f ] [ 10 atanh real? ] unit-test
|
||||
[ f ] [ 10.0 atanh real? ] unit-test
|
||||
|
||||
[ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
|
||||
[ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test
|
||||
|
|
|
|||
|
|
@ -52,14 +52,25 @@ PRIVATE>
|
|||
: >polar ( z -- abs arg )
|
||||
>float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; inline
|
||||
|
||||
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
|
||||
: cis ( arg -- z ) >float [ fcos ] [ fsin ] bi rect> ; inline
|
||||
|
||||
: polar> ( abs arg -- z ) cis * ; inline
|
||||
|
||||
GENERIC: exp ( x -- y )
|
||||
|
||||
M: float exp fexp ; inline
|
||||
|
||||
M: real exp >float exp ; inline
|
||||
|
||||
M: complex exp >rect swap fexp swap polar> ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ^mag ( w abs arg -- magnitude )
|
||||
[ >float-rect swap ] [ swap fpow ] [ rot * fexp /f ] tri* ; inline
|
||||
[ >float-rect swap ]
|
||||
[ >float swap >float fpow ]
|
||||
[ rot * exp /f ]
|
||||
tri* ; inline
|
||||
|
||||
: ^theta ( w abs arg -- theta )
|
||||
[ >float-rect ] [ flog * swap ] [ * + ] tri* ; inline
|
||||
|
|
@ -91,7 +102,7 @@ PRIVATE>
|
|||
{
|
||||
{ [ over 0 = ] [ nip 0^ ] }
|
||||
{ [ dup integer? ] [ integer^ ] }
|
||||
{ [ 2dup real^? ] [ fpow ] }
|
||||
{ [ 2dup real^? ] [ [ >float ] bi@ fpow ] }
|
||||
[ ^complex ]
|
||||
} cond ; inline
|
||||
|
||||
|
|
@ -146,17 +157,13 @@ M: real absq sq ; inline
|
|||
: >=1? ( x -- ? )
|
||||
dup complex? [ drop f ] [ 1 >= ] if ; inline
|
||||
|
||||
GENERIC: exp ( x -- y )
|
||||
|
||||
M: real exp fexp ; inline
|
||||
|
||||
M: complex exp >rect swap fexp swap polar> ;
|
||||
|
||||
GENERIC: log ( x -- y )
|
||||
|
||||
M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
|
||||
M: float log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
|
||||
|
||||
M: complex log >polar swap flog swap rect> ;
|
||||
M: real log >float log ; inline
|
||||
|
||||
M: complex log >polar swap flog swap rect> ; inline
|
||||
|
||||
: 10^ ( x -- y ) 10 swap ^ ; inline
|
||||
|
||||
|
|
@ -169,7 +176,9 @@ M: complex cos
|
|||
[ [ fcos ] [ fcosh ] bi* * ]
|
||||
[ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
|
||||
|
||||
M: real cos fcos ; inline
|
||||
M: float cos fcos ; inline
|
||||
|
||||
M: real cos >float cos ; inline
|
||||
|
||||
: sec ( x -- y ) cos recip ; inline
|
||||
|
||||
|
|
@ -180,7 +189,9 @@ M: complex cosh
|
|||
[ [ fcosh ] [ fcos ] bi* * ]
|
||||
[ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
|
||||
|
||||
M: real cosh fcosh ; inline
|
||||
M: float cosh fcosh ; inline
|
||||
|
||||
M: real cosh >float cosh ; inline
|
||||
|
||||
: sech ( x -- y ) cosh recip ; inline
|
||||
|
||||
|
|
@ -191,7 +202,9 @@ M: complex sin
|
|||
[ [ fsin ] [ fcosh ] bi* * ]
|
||||
[ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
|
||||
|
||||
M: real sin fsin ; inline
|
||||
M: float sin fsin ; inline
|
||||
|
||||
M: real sin >float sin ; inline
|
||||
|
||||
: cosec ( x -- y ) sin recip ; inline
|
||||
|
||||
|
|
@ -202,7 +215,9 @@ M: complex sinh
|
|||
[ [ fsinh ] [ fcos ] bi* * ]
|
||||
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
|
||||
|
||||
M: real sinh fsinh ; inline
|
||||
M: float sinh fsinh ; inline
|
||||
|
||||
M: real sinh >float sinh ; inline
|
||||
|
||||
: cosech ( x -- y ) sinh recip ; inline
|
||||
|
||||
|
|
@ -210,13 +225,17 @@ GENERIC: tan ( x -- y ) foldable
|
|||
|
||||
M: complex tan [ sin ] [ cos ] bi / ;
|
||||
|
||||
M: real tan ftan ; inline
|
||||
M: float tan ftan ; inline
|
||||
|
||||
M: real tan >float tan ; inline
|
||||
|
||||
GENERIC: tanh ( x -- y ) foldable
|
||||
|
||||
M: complex tanh [ sinh ] [ cosh ] bi / ;
|
||||
|
||||
M: real tanh ftanh ; inline
|
||||
M: float tanh ftanh ; inline
|
||||
|
||||
M: real tanh >float tanh ; inline
|
||||
|
||||
: cot ( x -- y ) tan recip ; inline
|
||||
|
||||
|
|
@ -242,17 +261,19 @@ M: real tanh ftanh ; inline
|
|||
: -i* ( x -- y ) >rect swap neg rect> ;
|
||||
|
||||
: asin ( x -- y )
|
||||
dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline
|
||||
dup [-1,1]? [ >float fasin ] [ i* asinh -i* ] if ; inline
|
||||
|
||||
: acos ( x -- y )
|
||||
dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
|
||||
dup [-1,1]? [ >float facos ] [ asin pi 2 / swap - ] if ;
|
||||
inline
|
||||
|
||||
GENERIC: atan ( x -- y ) foldable
|
||||
|
||||
M: complex atan i* atanh i* ;
|
||||
M: complex atan i* atanh i* ; inline
|
||||
|
||||
M: real atan fatan ; inline
|
||||
M: float atan fatan ; inline
|
||||
|
||||
M: real atan >float atan ; inline
|
||||
|
||||
: asec ( x -- y ) recip acos ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -3,10 +3,10 @@ IN: math.libm
|
|||
|
||||
ARTICLE: "math.libm" "C standard library math functions"
|
||||
"The words in the " { $vocab-link "math.libm" } " vocabulary call C standard library math functions. They are used to implement words in the " { $vocab-link "math.functions" } " vocabulary."
|
||||
$nl
|
||||
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
|
||||
{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
|
||||
{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." }
|
||||
{ $warning
|
||||
"These functions are unsafe. The compiler special-cases them to operate on floats only. They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
|
||||
{ $example "USE: math.functions" "2.0 acos ." "C{ 0.0 1.316957896924817 }" }
|
||||
{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." } }
|
||||
"Trigonometric functions:"
|
||||
{ $subsection fcos }
|
||||
{ $subsection fsin }
|
||||
|
|
|
|||
|
|
@ -4,54 +4,53 @@ USING: alien ;
|
|||
IN: math.libm
|
||||
|
||||
: facos ( x -- y )
|
||||
"double" "libm" "acos" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "acos" { "double" } alien-invoke ;
|
||||
|
||||
: fasin ( x -- y )
|
||||
"double" "libm" "asin" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "asin" { "double" } alien-invoke ;
|
||||
|
||||
: fatan ( x -- y )
|
||||
"double" "libm" "atan" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "atan" { "double" } alien-invoke ;
|
||||
|
||||
: fatan2 ( x y -- z )
|
||||
"double" "libm" "atan2" { "double" "double" } alien-invoke ; inline
|
||||
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
|
||||
|
||||
: fcos ( x -- y )
|
||||
"double" "libm" "cos" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "cos" { "double" } alien-invoke ;
|
||||
|
||||
: fsin ( x -- y )
|
||||
"double" "libm" "sin" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "sin" { "double" } alien-invoke ;
|
||||
|
||||
: ftan ( x -- y )
|
||||
"double" "libm" "tan" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "tan" { "double" } alien-invoke ;
|
||||
|
||||
: fcosh ( x -- y )
|
||||
"double" "libm" "cosh" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "cosh" { "double" } alien-invoke ;
|
||||
|
||||
: fsinh ( x -- y )
|
||||
"double" "libm" "sinh" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "sinh" { "double" } alien-invoke ;
|
||||
|
||||
: ftanh ( x -- y )
|
||||
"double" "libm" "tanh" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "tanh" { "double" } alien-invoke ;
|
||||
|
||||
: fexp ( x -- y )
|
||||
"double" "libm" "exp" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "exp" { "double" } alien-invoke ;
|
||||
|
||||
: flog ( x -- y )
|
||||
"double" "libm" "log" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "log" { "double" } alien-invoke ;
|
||||
|
||||
: fpow ( x y -- z )
|
||||
"double" "libm" "pow" { "double" "double" } alien-invoke ; inline
|
||||
"double" "libm" "pow" { "double" "double" } alien-invoke ;
|
||||
|
||||
! Don't inline fsqrt -- its an intrinsic!
|
||||
: fsqrt ( x -- y )
|
||||
"double" "libm" "sqrt" { "double" } alien-invoke ;
|
||||
|
||||
! Windows doesn't have these...
|
||||
: facosh ( x -- y )
|
||||
"double" "libm" "acosh" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "acosh" { "double" } alien-invoke ;
|
||||
|
||||
: fasinh ( x -- y )
|
||||
"double" "libm" "asinh" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "asinh" { "double" } alien-invoke ;
|
||||
|
||||
: fatanh ( x -- y )
|
||||
"double" "libm" "atanh" { "double" } alien-invoke ; inline
|
||||
"double" "libm" "atanh" { "double" } alien-invoke ;
|
||||
|
|
|
|||
|
|
@ -44,3 +44,10 @@ STRUCT: test-struct-array
|
|||
S{ test-struct-array f 20 20 }
|
||||
} second
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
STRUCT: fixed-string { text char[100] } ;
|
||||
|
||||
[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [
|
||||
ALIEN: 123 4 fixed-string <direct-struct-array> [ (underlying)>> ] { } map-as
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -289,6 +289,8 @@ IN: tools.deploy.shaker
|
|||
|
||||
"disposables" "destructors" lookup ,
|
||||
|
||||
"functor-words" "functors.backend" lookup ,
|
||||
|
||||
deploy-threads? [
|
||||
"initial-thread" "threads" lookup ,
|
||||
] unless
|
||||
|
|
|
|||
|
|
@ -420,6 +420,7 @@ ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
|
|||
{ $subsection 2/ }
|
||||
{ $subsection 2^ }
|
||||
{ $subsection bit? }
|
||||
"Advanced topics:"
|
||||
{ $subsection "math.bitwise" }
|
||||
{ $subsection "math.bits" }
|
||||
{ $see-also "booleans" } ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue