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

Debugging new codegen

db4
Slava Pestov 2008-10-07 20:00:38 -05:00
parent e6e313eba9
commit 7b6d9c4c4f
21 changed files with 194 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
basis/compiler/cfg/builder/builder.factor
View File

@ -4,6 +4,7 @@ USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
locals layouts alien.c-types alien.structs
stack-checker.inlining
cpu.architecture
compiler.intrinsics
compiler.tree
compiler.tree.builder
@ -154,7 +155,7 @@ M: #if emit-node
#! correct register state
gensym [
[
copy-phantoms
init-phantoms
##prologue
[ emit-nodes ] with-node-iterator
##epilogue
@ -170,12 +171,12 @@ M: #if emit-node
: emit-dispatch ( node -- )
phantom-pop int-regs next-vreg
[ finalize-contents finalize-heights ##epilogue ] 2dip ##dispatch
[ finalize-phantoms ##epilogue ] 2dip ##dispatch
dispatch-branches init-phantoms ;
M: #dispatch emit-node
tail-call? [
emit-dispatch iterate-next
emit-dispatch stop-iterating
] [
current-word get gensym [
[
@ -295,12 +296,12 @@ M: #r> emit-node
! #return
M: #return emit-node
drop finalize-phantoms ##epilogue ##return f ;
drop finalize-phantoms ##epilogue ##return stop-iterating ;
M: #return-recursive emit-node
finalize-phantoms
label>> id>> loops get key?
[ ##epilogue ##return ] unless f ;
[ ##epilogue ##return ] unless stop-iterating ;
! #terminate
M: #terminate emit-node drop stop-iterating ;

6
basis/compiler/cfg/debugger/debugger.factor
View File

@ -3,7 +3,8 @@
USING: kernel words sequences quotations namespaces io
accessors prettyprint prettyprint.config
compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization ;
compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.stack-frame ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
@ -14,7 +15,8 @@ M: callable test-cfg
M: word test-cfg
[ build-tree-from-word nip optimize-tree ] keep build-cfg ;
: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;
: test-mr ( quot -- mrs )
test-cfg [ build-mr build-stack-frame ] map ;
: mr. ( mrs -- )
[

5
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math math.order kernel assocs
accessors vectors fry heaps
accessors vectors fry heaps cpu.architecture
compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals
compiler.backend ;
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation
! Mapping from register classes to sequences of machine registers

1
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
fry make combinators
cpu.architecture
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.live-intervals ;

4
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces
compiler.backend
cpu.architecture
compiler.cfg
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
@ -29,5 +29,5 @@ IN: compiler.cfg.linear-scan
machine-registers allocate-registers
assign-registers
] change-instructions
spill-counts get >>spill-counts
! spill-counts get >>spill-counts
] with-scope ;

7
basis/compiler/cfg/registers/registers.factor
View File

@ -17,13 +17,6 @@ M: value >vreg drop f ;
M: value set-value-class 2drop ;
M: value value-class* drop f ;
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
! Virtual registers
TUPLE: vreg reg-class n ;
SYMBOL: vreg-counter

6
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
make compiler.cfg.instructions compiler.cfg.instructions.syntax
compiler.cfg.registers ;
combinators make compiler.cfg.instructions
compiler.cfg.instructions.syntax compiler.cfg.registers ;
IN: compiler.cfg.stack-frame
SYMBOL: frame-required?
@ -21,7 +21,7 @@ GENERIC: compute-stack-frame* ( insn -- )
[ [ params>> ] bi@ max ]
[ [ return>> ] bi@ max ]
[ [ total-size>> ] bi@ max ]
} cleave
} 2cleave
stack-frame boa ;
M: ##stack-frame compute-stack-frame*

6
basis/compiler/cfg/stacks/stacks.factor
View File

@ -3,7 +3,7 @@
USING: arrays assocs classes classes.private classes.algebra
combinators hashtables kernel layouts math fry namespaces
quotations sequences system vectors words effects alien
byte-arrays accessors sets math.order compiler.backend
byte-arrays accessors sets math.order cpu.architecture
compiler.cfg.instructions compiler.cfg.registers ;
IN: compiler.cfg.stacks
@ -11,6 +11,10 @@ IN: compiler.cfg.stacks
! doing a bit of optimization along the way.
SYMBOL: known-tag
PREDICATE: small-slot < integer cells small-enough? ;
PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
! Value protocol
GENERIC: move-spec ( obj -- spec )
GENERIC: live-loc? ( actual current -- ? )

4
basis/compiler/cfg/templates/templates.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors sequences kernel fry namespaces
quotations combinators classes.algebra compiler.backend
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks ;
quotations combinators classes.algebra compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.stacks ;
IN: compiler.cfg.templates
TUPLE: template input output scratch clobber gc ;

13
basis/compiler/codegen/codegen.factor
View File

@ -3,10 +3,10 @@
USING: namespaces make math math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings sets threads libc continuations.private
alien.strings alien.arrays sets threads libc continuations.private
cpu.architecture
compiler.errors
compiler.alien
compiler.backend
compiler.codegen.fixup
compiler.cfg
compiler.cfg.instructions
@ -88,7 +88,7 @@ M: ##peek generate-insn
[ dst>> v>operand ] [ loc>> ] bi %peek ;
M: ##replace generate-insn
[ src>> ] [ loc>> ] bi %replace ;
[ src>> v>operand ] [ loc>> ] bi %replace ;
M: ##inc-d generate-insn n>> %inc-d ;
@ -111,6 +111,9 @@ M: ##intrinsic generate-insn
: (operand) ( name -- operand )
operands get at* [ "Bad operand name" throw ] unless ;
: literal ( name -- value )
(operand) value>> ;
: operand ( name -- operand )
(operand) v>operand ;
@ -134,10 +137,10 @@ M: _branch generate-insn
label>> lookup-label %jump-label ;
M: _branch-f generate-insn
[ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
[ label>> lookup-label ] [ src>> v>operand ] bi %jump-f ;
M: _branch-t generate-insn
[ src>> v>operand ] [ label>> lookup-label ] bi %jump-t ;
[ label>> lookup-label ] [ src>> v>operand ] bi %jump-t ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;

2
basis/compiler/codegen/fixup/fixup.factor
View File

@ -4,7 +4,7 @@ USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private math.order accessors
growable compiler.constants compiler.backend ;
growable cpu.architecture compiler.constants ;
IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )

2
basis/compiler/compiler-docs.factor
View File

@ -1,4 +1,4 @@
USING: compiler.generator help.markup help.syntax words io parser
USING: help.markup help.syntax words io parser
assocs words.private sequences compiler.units ;
IN: compiler

19
basis/cpu/architecture/architecture.factor
View File

@ -12,6 +12,13 @@ TUPLE: label offset ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
@ -38,8 +45,6 @@ HOOK: load-indirect cpu ( obj reg -- )
HOOK: stack-frame-size cpu ( frame-size -- n )
TUPLE: stack-frame total-size size params return ;
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
@ -53,10 +58,10 @@ HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-f cpu ( label -- )
HOOK: %jump-f cpu ( label vreg -- )
! Test if vreg is 't' or not
HOOK: %jump-t cpu ( label -- )
HOOK: %jump-t cpu ( label vreg -- )
HOOK: %dispatch cpu ( -- )
@ -149,11 +154,7 @@ M: stack-params param-reg drop ;
M: stack-params param-regs drop f ;
M: object load-literal v>operand load-indirect ;
PREDICATE: small-slot < integer cells small-enough? ;
PREDICATE: small-tagged < integer v>operand small-enough? ;
M: object load-literal load-indirect ;
: if-small-struct ( n size true false -- ? )
[ over not over struct-small-enough? and ] 2dip

25
basis/cpu/x86/32/32.factor
View File

@ -1,12 +1,13 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: locals alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
stack-checker.known-words compiler.generator.registers
compiler.generator.fixup compiler.generator system layouts
combinators command-line compiler compiler.units io
vocabs.loader accessors init ;
USING: locals alien.c-types arrays kernel kernel.private math
namespaces sequences stack-checker.known-words system layouts io
vocabs.loader accessors init combinators command-line
cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics
cpu.x86.allot cpu.architecture compiler compiler.units
compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.builder
compiler.cfg.instructions ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
@ -14,6 +15,12 @@ IN: cpu.x86.32
! this on all platforms, sacrificing some stack space for
! code simplicity.
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
{ double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
@ -254,7 +261,7 @@ M: x86.32 %cleanup ( alien-node -- )
[ drop ]
} cond ;
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
M: x86.32 %unwind ( n -- ) RET ;
os windows? [
cell "longlong" c-type (>>align)
@ -273,7 +280,7 @@ os windows? [
EDX 26 SHR
EDX 1 AND
{ EAX EBX ECX EDX } [ POP ] each
JE
JNE
] { } define-if-intrinsic
\ (sse2?) { } { object } define-primitive

23
basis/cpu/x86/64/64.factor
View File

@ -1,14 +1,23 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces make sequences compiler.generator
compiler.generator.registers compiler.generator.fixup system
USING: accessors alien.c-types arrays kernel kernel.private math
namespaces make sequences system
layouts alien alien.accessors alien.structs slots splitting
assocs combinators ;
assocs combinators cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup compiler.cfg.instructions ;
IN: cpu.x86.64
M: x86.64 machine-registers
{
{ int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
{ double-float-regs {
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
} }
} ;
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
@ -215,7 +224,7 @@ M: x86.64 %callback-value ( ctype -- )
M: x86.64 %cleanup ( alien-node -- ) drop ;
M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
M: x86.64 %unwind ( n -- ) drop 0 RET ;
USE: cpu.x86.intrinsics

45
basis/cpu/x86/allot/allot.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.architecture cpu.x86.assembler
cpu.x86.architecture kernel.private namespaces math sequences
generic arrays compiler.generator compiler.generator.fixup
compiler.generator.registers system layouts alien locals
compiler.constants ;
USING: kernel words kernel.private namespaces math math.private
sequences generic arrays system layouts alien locals
cpu.architecture cpu.x86.assembler cpu.x86.architecture
compiler.constants compiler.cfg.templates compiler.cfg.builder
compiler.codegen compiler.codegen.fixup ;
IN: cpu.x86.allot
M:: x86 %write-barrier ( src temp -- )
@ -102,3 +102,38 @@ M:: x86 %box-alien ( dst src temp -- )
\ f tag-number MOV
"end" resolve-label
] with-scope ;
: overflow-check ( word -- )
"end" define-label
"z" operand "x" operand MOV
"z" operand "y" operand pick execute
! If the previous arithmetic operation overflowed, then we
! turn the result into a bignum and leave it in EAX.
"end" get JNO
! There was an overflow. Recompute the original operand.
{ "y" "x" } [ %untag-fixnum ] unique-operands
"x" operand "y" operand rot execute
"z" operand "x" operand "y" operand %allot-bignum-signed-1
"end" resolve-label ; inline
: overflow-template ( word insn -- )
[ overflow-check ] curry T{ template
{ input { { f "x" } { f "y" } } }
{ scratch { { f "z" } } }
{ output { "z" } }
{ clobber { "x" "y" } }
{ gc t }
} define-intrinsic ;
\ fixnum+ \ ADD overflow-template
\ fixnum- \ SUB overflow-template
\ fixnum>bignum [
"x" operand %untag-fixnum
"x" operand dup "scratch" operand %allot-bignum-signed-1
] T{ template
{ input { { f "x" } } }
{ scratch { { f "scratch" } } }
{ output { "x" } }
{ gc t }
} define-intrinsic

50
basis/cpu/x86/architecture/architecture.factor
View File

@ -2,9 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays cpu.x86.assembler
cpu.x86.assembler.private cpu.architecture kernel kernel.private
math memory namespaces make sequences words compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts combinators compiler.constants math.order ;
math memory namespaces make sequences words system
layouts combinators math.order locals compiler.constants
compiler.cfg.registers compiler.cfg.instructions
compiler.codegen.fixup ;
IN: cpu.x86.architecture
HOOK: ds-reg cpu ( -- reg )
@ -63,8 +64,6 @@ M: fixnum load-literal
M: x86 stack-frame-size ( n -- i )
3 cells + align-stack ;
M: x86 %save-word-xt ( -- ) ;
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
@ -95,10 +94,10 @@ M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ;
M: x86 %jump-f ( label vreg -- )
M: x86 %jump-f ( label reg -- )
\ f tag-number CMP JE ;
M: x86 %jump-t ( label vreg -- )
M: x86 %jump-t ( label reg -- )
\ f tag-number CMP JNE ;
: code-alignment ( -- n )
@ -107,27 +106,20 @@ M: x86 %jump-t ( label vreg -- )
: align-code ( n -- )
0 <repetition> % ;
M: x86 %dispatch ( -- )
[
%epilogue-later
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
"n" operand HEX: 7f [+] JMP
! Fix up the displacement above
code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }
} with-template ;
M:: x86 %dispatch ( src temp -- )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Untag and multiply to get a jump table offset
src fixnum>slot@
! Add jump table base
temp HEX: ffffffff MOV rc-absolute-cell rel-here
src temp ADD
src HEX: 7f [+] JMP
! Fix up the displacement above
code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code ;
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
@ -142,6 +134,8 @@ M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
M: x86 %copy ( dst src -- ) MOV ;
M: x86 fp-shadows-int? ( -- ? ) f ;
M: x86 value-structs? t ;

8
basis/cpu/x86/assembler/assembler.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays compiler.generator.fixup io.binary kernel
combinators kernel.private math namespaces make sequences
words system layouts math.order accessors
cpu.x86.assembler.syntax ;
USING: arrays cpu.architecture compiler.constants
compiler.codegen.fixup io.binary kernel combinators
kernel.private math namespaces make sequences words system
layouts math.order accessors cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.

2
basis/cpu/x86/bootstrap.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.x86.assembler layouts compiler.units math
math.private compiler.generator.fixup compiler.constants vocabs
math.private compiler.constants vocabs
slots.private words words.private ;
IN: bootstrap.x86

74
basis/cpu/x86/intrinsics/intrinsics.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays alien.accessors
compiler.backend kernel kernel.private math memory namespaces
make sequences words system layouts combinators math.order
math.private alien alien.c-types slots.private cpu.x86.assembler
cpu.x86.assembler.private locals compiler.backend
USING: accessors arrays byte-arrays alien.accessors kernel
kernel.private math memory namespaces make sequences words
system layouts combinators math.order math.private alien
alien.c-types slots.private locals cpu.architecture
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.architecture
compiler.codegen.fixup compiler.constants compiler.intrinsics
compiler.cfg.builder compiler.cfg.registers compiler.cfg.stacks
compiler.cfg.templates compiler.codegen ;
@ -20,6 +20,20 @@ IN: cpu.x86.intrinsics
} define-intrinsic
! Slots
: %slot-literal-known-tag ( -- op )
"obj" operand
"n" literal cells
"obj" operand-tag - [+] ;
: %slot-literal-any-tag ( -- op )
"obj" operand %untag
"obj" operand "n" literal cells [+] ;
: %slot-any ( -- op )
"obj" operand %untag
"n" operand fixnum>slot@
"obj" operand "n" operand [+] ;
\ slot {
! Slot number is literal and the tag is known
{
@ -124,9 +138,9 @@ IN: cpu.x86.intrinsics
\ fixnum*fast {
{
[
"x" operand "y" get IMUL2
"x" operand "y" literal IMUL2
] T{ template
{ input { { f "x" } { [ small-tagged? ] "y" } } }
{ input { { f "x" } { small-tagged "y" } } }
{ output { "x" } }
}
} {
@ -142,55 +156,27 @@ IN: cpu.x86.intrinsics
}
} define-intrinsics
: %untag-fixnums ( seq -- )
[ %untag-fixnum ] unique-operands ;
\ fixnum-shift-fast [
"x" operand "y" get
"x" operand "y" literal
dup 0 < [ neg SAR ] [ SHL ] if
! Mask off low bits
"x" operand %untag
] T{ template
{ input { { f "x" } { [ ] "y" } } }
{ input { { f "x" } { small-tagged "y" } } }
{ output { "x" } }
} define-intrinsic
: overflow-check ( word -- )
"end" define-label
"z" operand "x" operand MOV
"z" operand "y" operand pick execute
! If the previous arithmetic operation overflowed, then we
! turn the result into a bignum and leave it in EAX.
"end" get JNO
! There was an overflow. Recompute the original operand.
{ "y" "x" } %untag-fixnums
"x" operand "y" operand rot execute
"z" operand "x" operand "y" operand %allot-bignum-signed-1
"end" resolve-label ; inline
: overflow-template ( word insn -- )
[ overflow-check ] curry T{ template
{ input { { f "x" } { f "y" } } }
{ scratch { { f "z" } } }
{ output { "z" } }
{ clobber { "x" "y" } }
{ gc t }
} define-intrinsic ;
\ fixnum+ \ ADD overflow-template
\ fixnum- \ SUB overflow-template
: fixnum-jump ( op inputs -- pair )
>r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
: fixnum-value-jump ( op -- pair )
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
{ { f "x" } { small-tagged "y" } } fixnum-jump ;
: fixnum-register-jump ( op -- pair )
{ { f "x" } { f "y" } } fixnum-jump ;
: define-fixnum-jump ( word op -- )
[ fixnum-value-jump ] keep fixnum-register-jump
[ fixnum-value-jump ] [ fixnum-register-jump ] bi
2array define-if-intrinsics ;
{
@ -203,16 +189,6 @@ IN: cpu.x86.intrinsics
first2 define-fixnum-jump
] each
\ fixnum>bignum [
"x" operand %untag-fixnum
"x" operand dup "scratch" operand %allot-bignum-signed-1
] T{ template
{ input { { f "x" } } }
{ scratch { { f "scratch" } } }
{ output { "x" } }
{ gc t }
} define-intrinsic
\ bignum>fixnum [
"nonzero" define-label
"positive" define-label

50
basis/cpu/x86/sse2/sse2.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics generic kernel
USING: alien alien.accessors arrays generic kernel
kernel.private math math.private memory namespaces sequences
words compiler.generator compiler.generator.registers
cpu.architecture math.floats.private layouts quotations
system ;
words math.floats.private layouts quotations locals
system compiler.constants compiler.codegen compiler.cfg.templates
compiler.cfg.registers compiler.cfg.builder cpu.architecture
cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics ;
IN: cpu.x86.sse2
M: x86 %copy-float MOVSD ;
@ -18,9 +18,9 @@ M: x86 %unbox-float ( dst src -- )
float-offset [+] MOVSD ;
: define-float-op ( word op -- )
[ "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +output+ { "x" } }
[ "x" operand "y" operand ] swap suffix T{ template
{ input { { float "x" } { float "y" } } }
{ output { "x" } }
} define-intrinsic ;
{
@ -49,41 +49,41 @@ M: x86 %unbox-float ( dst src -- )
\ float>fixnum [
"out" operand "in" operand CVTTSD2SI
"out" operand tag-bits get SHL
] H{
{ +input+ { { float "in" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
] T{ template
{ input { { float "in" } } }
{ scratch { { f "out" } } }
{ output { "out" } }
} define-intrinsic
\ fixnum>float [
"in" operand %untag-fixnum
"out" operand "in" operand CVTSI2SD
] H{
{ +input+ { { f "in" } } }
{ +scratch+ { { float "out" } } }
{ +output+ { "out" } }
{ +clobber+ { "in" } }
] T{ template
{ input { { f "in" } } }
{ scratch { { float "out" } } }
{ output { "out" } }
{ clobber { "in" } }
} define-intrinsic
: alien-float-get-template
H{
{ +input+ {
T{ template
{ input {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { float "value" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
{ scratch { { float "value" } } }
{ output { "value" } }
{ clobber { "offset" } }
} ;
: alien-float-set-template
H{
{ +input+ {
T{ template
{ input {
{ float "value" float }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "offset" } }
{ clobber { "offset" } }
} ;
: define-alien-float-intrinsics ( word get-quot word set-quot -- )