- get factor running on mac intel
- when generating a 32-bit image on a 64-bit system, large numbers which should
be bignums become fixnums
-- httpd fep
-- SBUF" " i/o bug
- clicks sent twice
- speed up ideas:
- only do clipping for certain gadgets
] "infer" set-word-prop
: box-parameters ( parameters -- )
- [ box-parameter ] map-parameters % ;
+ [ box-parameter ] each-parameter ;
: registers>objects ( parameters -- )
- dup \ %freg>stack move-parameters %
- "nest_stacks" f %alien-invoke , box-parameters ;
+ dup \ %freg>stack move-parameters
+ "nest_stacks" f %alien-invoke box-parameters ;
: unbox-return ( node -- )
alien-callback-return [
- "unnest_stacks" f %alien-invoke ,
+ "unnest_stacks" f %alien-invoke
] [
c-type [
"reg-class" get
"unboxer-function" get
- %callback-value ,
+ %callback-value
] bind
] if-void ;
-: linearize-callback ( node -- )
- dup alien-callback-xt [
- dup stack-reserve* %prologue ,
+: generate-callback ( node -- )
+ [ alien-callback-xt ] keep [
dup alien-callback-parameters registers>objects
dup alien-callback-quot \ init-error-handler swons
- %alien-callback ,
+ %alien-callback
unbox-return
- %return ,
- ] make-linear ;
+ %return
+ ] generate-block ;
-M: alien-callback linearize* ( node -- )
- end-basic-block compile-gc linearize-callback iterate-next ;
+M: alien-callback generate-node ( node -- )
+ end-basic-block compile-gc generate-callback iterate-next ;
M: alien-callback stack-reserve*
alien-callback-parameters stack-space ;
node,
] "infer" set-word-prop
-: unbox-parameter ( stack# type -- node )
+: unbox-parameter ( stack# type -- )
c-type [ "reg-class" get "unboxer" get call ] bind ;
: unbox-parameters ( parameters -- )
- [ unbox-parameter , ] reverse-each-parameter ;
+ [ unbox-parameter ] reverse-each-parameter ;
: objects>registers ( parameters -- )
#! Generate code for boxing a list of C types, then generate
#! code for moving these parameters to register on
#! architectures where parameters are passed in registers
#! (PowerPC, AMD64).
- dup unbox-parameters "save_stacks" f %alien-invoke ,
- \ %stack>freg move-parameters % ;
+ dup unbox-parameters "save_stacks" f %alien-invoke
+ \ %stack>freg move-parameters ;
: box-return ( node -- )
- alien-invoke-return [ ] [ f swap box-parameter , ] if-void ;
+ alien-invoke-return [ ] [ f swap box-parameter ] if-void ;
-: linearize-cleanup ( node -- )
+: generate-cleanup ( node -- )
dup alien-invoke-library library-abi "stdcall" = [
drop
] [
- alien-invoke-parameters stack-space %cleanup ,
+ alien-invoke-parameters stack-space %cleanup
] if ;
-M: alien-invoke linearize* ( node -- )
+M: alien-invoke generate-node ( node -- )
end-basic-block compile-gc
dup alien-invoke-parameters objects>registers
- dup alien-invoke-dlsym %alien-invoke ,
- dup linearize-cleanup box-return
+ dup alien-invoke-dlsym %alien-invoke
+ dup generate-cleanup box-return
iterate-next ;
M: alien-invoke stack-reserve*
[ c-size cell / "void*" <array> ] [ 1array ] if
] map concat ;
+: each-parameter ( parameters quot -- )
+ >r [ parameter-sizes ] keep r> 2each ; inline
+
: reverse-each-parameter ( parameters quot -- )
>r [ parameter-sizes ] keep
[ reverse-slice ] 2apply r> 2each ; inline
-: map-parameters ( parameters quot -- seq )
- >r [ parameter-sizes ] keep r> 2map ; inline
-
-: move-parameters ( params vop -- seq )
+: move-parameters ( params vop -- )
#! Moves values from C stack to registers (if vop is
#! %stack>freg) and registers to C stack (if vop is
#! %freg>stack).
swap [
flatten-value-types
0 { int-regs float-regs stack-params } [ set ] each-with
- [ pick >r alloc-parameter r> execute ] map-parameters
- nip
+ [ pick >r alloc-parameter r> execute ] each-parameter
+ drop
] with-scope ; inline
: box-parameter ( stack# type -- node )
"/library/inference/print-dataflow.factor"
"/library/compiler/assembler.factor"
- "/library/compiler/vops.factor"
"/library/compiler/templates.factor"
- "/library/compiler/linearizer.factor"
- "/library/compiler/stack.factor"
"/library/compiler/xt.factor"
- "/library/compiler/intrinsics.factor"
"/library/compiler/generator.factor"
"/library/compiler/compiler.factor"
{
"/library/compiler/ppc/assembler.factor"
"/library/compiler/ppc/architecture.factor"
- "/library/compiler/ppc/generator.factor"
- "/library/compiler/ppc/slots.factor"
- "/library/compiler/ppc/stack.factor"
- "/library/compiler/ppc/fixnum.factor"
- "/library/compiler/ppc/alien.factor"
+ ! "/library/compiler/ppc/generator.factor"
+ ! "/library/compiler/ppc/slots.factor"
+ ! "/library/compiler/ppc/stack.factor"
+ ! "/library/compiler/ppc/fixnum.factor"
+ ! "/library/compiler/ppc/alien.factor"
}
]
} {
"Compiling base..." print flush
- {
- uncons 1+ 1- + <= > >= mod length
- nth-unsafe set-nth-unsafe
- = string>number number>string scan
- kill-values (generate)
- } [ compile ] each
+ { "kernel" "sequences" "assembler" } compile-vocabs
"Compiling system..." print flush
compile-all
! R14 datastack
! R15 callstack
-: fixnum-imm? ( -- ? )
- #! Can fixnum operations take immediate operands?
- f ; inline
-
: ds-reg R14 ; inline
: cs-reg R15 ; inline
: remainder-reg RDX ; inline
IN: compiler
+USING: generic kernel kernel-internals math memory namespaces
+sequences ;
-! A few things the front-end needs to know about the back-end.
+! A scratch register for computations
+TUPLE: vreg n ;
-DEFER: fixnum-imm? ( -- ? )
-#! Can fixnum operations take immediate operands?
+! Register classes
+TUPLE: int-regs ;
+TUPLE: float-regs size ;
+! A pseudo-register class for parameters spilled on the stack
+TUPLE: stack-params ;
+
+! Return values of this class go here
+GENERIC: return-reg ( register-class -- reg )
+
+! Sequence of registers used for parameter passing in class
+GENERIC: fastcall-regs ( register-class -- regs )
+
+! Sequence mapping vreg-n to native assembler registers
DEFER: vregs ( -- regs )
-DEFER: compile-c-call ( library function -- )
+! Load a literal (immediate or indirect)
+G: load-literal ( obj vreg -- ) 1 standard-combination ;
+
+! Set up caller stack frame (PowerPC and AMD64)
+DEFER: %prologue ( n -- )
+
+! Tail call another word
+DEFER: %jump ( label -- )
+
+! Call another word
+DEFER: %call ( label -- )
+
+! Local jump for branches or tail calls in nested #label
+DEFER: %jump-label ( label -- )
+
+! Test if vreg is 'f' or not
+DEFER: %jump-t ( label vreg -- )
+
+! Jump table of addresses (one cell each) is right after this
+DEFER: %dispatch ( vreg -- )
+
+! Return to caller
+DEFER: %return ( -- )
+
+! Change datastack height
+DEFER: %inc-d ( n -- )
+
+! Change callstack height
+DEFER: %inc-r ( n -- )
+
+! Load stack into vreg
+DEFER: %peek ( vreg loc -- )
+
+! Store vreg to stack
+DEFER: %replace ( vreg loc -- )
+
+! FFI stuff
+DEFER: %unbox ( n reg-class func -- )
+
+DEFER: %unbox-struct ( n reg-class size -- )
+
+DEFER: %box ( n reg-class func -- )
+
+DEFER: %box-struct ( n reg-class size -- )
+
+DEFER: %alien-invoke ( library function -- )
+
+DEFER: %alien-callback ( quot -- )
+
+DEFER: %callback-value ( reg-class func -- )
+
+! A few FFI operations have default implementations
+: %cleanup ( n -- ) drop ;
+
+: %stack>freg ( n reg reg-class -- ) 3drop ;
+
+: %freg>stack ( n reg reg-class -- ) 3drop ;
+
+! Some stuff probably not worth redefining in other backends
+M: stack-params fastcall-regs drop 0 ;
+
+GENERIC: reg-size ( register-class -- n )
+
+GENERIC: inc-reg-class ( register-class -- )
+
+M: int-regs reg-size drop cell ;
+
+: (inc-reg-class)
+ dup class inc
+ macosx? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: int-regs inc-reg-class
+ (inc-reg-class) ;
+
+M: float-regs reg-size float-regs-size ;
+
+M: float-regs inc-reg-class
+ dup (inc-reg-class)
+ macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
+
+GENERIC: v>operand
+
+M: integer v>operand tag-bits shift ;
+
+M: vreg v>operand vreg-n vregs nth ;
+
+M: f v>operand address ;
namespaces optimizer prettyprint sequences test words ;
: (compile) ( word -- )
- #! Should be called inside the with-compiler scope.
- dup word-def dataflow optimize linearize
- [ generate ] hash-each ;
-
-: benchmark-compile
- [ [ (compile) ] keep ] benchmark nip
+ [
+ [
+ dup word-def dataflow optimize generate
+ ] keep
+ ] benchmark nip
"compile-time" set-word-prop ;
: inform-compile ( word -- ) "Compiling " write . flush ;
: compile-postponed ( -- )
compile-words get dup empty? [
- dup pop
- dup inform-compile
- benchmark-compile
- compile-postponed
- ] unless drop ;
+ drop
+ ] [
+ pop dup inform-compile (compile) compile-postponed
+ ] if ;
: compile ( word -- )
[ postpone-word compile-postponed ] with-compiler ;
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
IN: compiler
-USING: alien assembler errors inference kernel
-kernel-internals lists math memory namespaces sequences strings
-vectors words ;
+USING: arrays assembler errors generic hashtables inference
+kernel kernel-internals lists math namespaces queues sequences
+words ;
-! Compile a VOP.
-GENERIC: generate-node ( vop -- )
+GENERIC: stack-reserve*
-: generate-code ( word linear -- length )
+M: object stack-reserve* drop 0 ;
+
+: stack-reserve ( node -- n )
+ 0 swap [ stack-reserve* max ] each-node ;
+
+DEFER: #terminal?
+
+PREDICATE: #merge #terminal-merge node-successor #terminal? ;
+
+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 [
+ dup #terminal-call? swap node-successor #terminal? or
+ ] all? ;
+
+: generate-code ( word node quot -- length | quot: node -- )
compiled-offset >r
compile-aligned
- swap save-xt
- [ dup [ generate-node ] with-vop ] each
+ rot save-xt
+ over stack-reserve %prologue
+ call
compile-aligned
compiled-offset r> - ;
dup [ assemble-cell ] each
length cells ;
-: (generate) ( word linear -- )
- #! Compile a word definition from linear IR.
- V{ } clone relocation-table set
- begin-assembly swap >r >r
- generate-code
- generate-reloc
- r> set-compiled-cell
- r> set-compiled-cell ;
-
SYMBOL: previous-offset
-: generate ( word linear -- )
+: begin-generating ( -- code-len-fixup reloc-len-fixup )
+ compiled-offset previous-offset set
+ V{ } clone relocation-table set
+ init-templates begin-assembly swap ;
+
+: generate-1 ( word node quot -- | quot: node -- )
#! If generation fails, reset compiled offset.
[
- compiled-offset previous-offset set
- (generate)
+ begin-generating >r >r
+ generate-code
+ generate-reloc
+ r> set-compiled-cell
+ r> set-compiled-cell
] [
- previous-offset get set-compiled-offset
- rethrow
+ previous-offset get set-compiled-offset rethrow
] recover ;
-! A few VOPs have trivial generators.
+SYMBOL: generate-queue
+
+: generate-loop ( -- )
+ generate-queue get dup queue-empty? [
+ drop
+ ] [
+ deque first3 generate-1 generate-loop
+ ] if ;
+
+: generate-block ( word node quot -- | quot: node -- )
+ 3array generate-queue get enque ;
-M: %label generate-node ( vop -- )
- vop-label save-xt ;
+GENERIC: generate-node ( node -- )
+
+: generate-nodes ( node -- )
+ [ node@ generate-node ] iterate-nodes end-basic-block ;
+
+: generate-word ( node -- )
+ [ [ generate-nodes ] with-node-iterator ]
+ generate-block ;
+
+: generate ( word node -- )
+ [
+ <queue> generate-queue set
+ generate-word generate-loop
+ ] with-scope ;
+
+! node
+M: node generate-node ( node -- next ) drop iterate-next ;
+
+! #label
+: generate-call ( label -- next )
+ end-basic-block
+ tail-call? [ %jump f ] [ %call iterate-next ] if ;
+
+M: #label generate-node ( node -- next )
+ #! We remap the IR node's label to a new label object here,
+ #! to avoid problems with two IR #label nodes having the
+ #! same label in different lexical scopes.
+ dup node-param dup generate-call >r
+ swap node-child generate-word r> ;
+
+! #if
+: generate-if ( node label -- next )
+ <label> [
+ >r >r node-children first2 generate-nodes
+ r> r> %jump-label save-xt generate-nodes
+ ] keep save-xt iterate-next ;
+
+M: #if generate-node ( node -- next )
+ [
+ end-basic-block
+ <label> dup "flag" get %jump-t
+ ] H{
+ { +input { { 0 "flag" } } }
+ } with-template generate-if ;
+
+! #call
+: [with-template] ( quot template -- quot )
+ 2array >list [ with-template ] append ;
+
+: define-intrinsic ( word quot template -- | quot: -- )
+ [with-template] "intrinsic" set-word-prop ;
+
+: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
+
+: define-if-intrinsic ( word quot template -- | quot: label -- )
+ [with-template] "if-intrinsic" set-word-prop ;
+
+: if-intrinsic ( #call -- quot )
+ dup node-successor #if?
+ [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
+
+M: #call generate-node ( node -- next )
+ dup if-intrinsic [
+ >r <label> dup r> call
+ >r node-successor r> generate-if node-successor
+ ] [
+ dup intrinsic
+ [ call iterate-next ] [ node-param generate-call ] ?if
+ ] if* ;
+
+! #call-label
+M: #call-label generate-node ( node -- next )
+ node-param generate-call ;
+
+! #dispatch
+: target-label ( label -- ) 0 assemble-cell absolute-cell ;
+
+: dispatch-head ( node -- label/node )
+ #! Output the jump table insn and return a list of
+ #! label/branch pairs.
+ [ end-basic-block "n" get %dispatch ]
+ H{ { +input { { 0 "n" } } } } with-template
+ node-children [ <label> dup target-label 2array ] map ;
+
+: dispatch-body ( label/node -- )
+ <label> swap [
+ first2 save-xt generate-nodes end-basic-block
+ dup %jump-label
+ ] each save-xt ;
+
+M: #dispatch generate-node ( node -- next )
+ #! The parameter is a list of nodes, each one is a branch to
+ #! take in case the top of stack has that type.
+ dispatch-head dispatch-body iterate-next ;
+
+! #push
+UNION: immediate fixnum POSTPONE: f ;
+
+: generate-push ( node -- )
+ >#push< dup length dup ensure-vregs
+ alloc-reg# [ <vreg> ] map
+ [ [ load-literal ] 2each ] keep
+ phantom-d get phantom-append ;
+
+M: #push generate-node ( #push -- )
+ generate-push iterate-next ;
+
+! #shuffle
+: phantom-shuffle-input ( n phantom -- seq )
+ 2dup length <= [
+ cut-phantom
+ ] [
+ [ phantom-locs ] keep [ length swap head-slice* ] keep
+ [ append 0 ] keep set-length
+ ] if ;
-M: %target-label generate-node ( vop -- )
- drop label 0 assemble-cell absolute-cell ;
+: phantom-shuffle-inputs ( shuffle -- locs locs )
+ dup shuffle-in-d length phantom-d get phantom-shuffle-input
+ swap shuffle-in-r length phantom-r get phantom-shuffle-input ;
-M: %cleanup generate-node ( vop -- ) drop ;
+: adjust-shuffle ( shuffle -- )
+ dup shuffle-in-d length neg phantom-d get adjust-phantom
+ shuffle-in-r length neg phantom-r get adjust-phantom ;
-M: %freg>stack generate-node ( vop -- ) drop ;
+: shuffle-vregs# ( shuffle -- n )
+ dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
-M: %stack>freg generate-node ( vop -- ) drop ;
+: phantom-shuffle ( shuffle -- )
+ dup shuffle-vregs# ensure-vregs
+ [ phantom-shuffle-inputs ] keep
+ [ shuffle* ] keep adjust-shuffle
+ (template-outputs) ;
-M: %alien-invoke generate-node
- #! call a C function.
- drop 0 input 1 input compile-c-call ;
+M: #shuffle generate-node ( #shuffle -- )
+ node-shuffle phantom-shuffle iterate-next ;
-: dest/src ( -- dest src ) 0 output-operand 0 input-operand ;
+! #return
+M: #return generate-node drop end-basic-block %return f ;
! These constants must match native/card.h
: card-bits 7 ;
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic hashtables inference
-kernel math namespaces sequences words ;
-IN: compiler
-
-GENERIC: stack-reserve*
-
-M: object stack-reserve* drop 0 ;
-
-: stack-reserve ( node -- )
- 0 swap [ stack-reserve* max ] each-node ;
-
-DEFER: #terminal?
-
-PREDICATE: #merge #terminal-merge node-successor #terminal? ;
-
-: 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 [
- dup #terminal-call? swap node-successor #terminal? or
- ] all? ;
-
-GENERIC: linearize* ( node -- next )
-
-: linearize-child ( node -- )
- [ node@ linearize* ] iterate-nodes end-basic-block ;
-
-! A map from words to linear IR.
-SYMBOL: linearized
-
-! Renamed labels. To avoid problems with labels with the same
-! name in different scopes.
-SYMBOL: renamed-labels
-
-: make-linear ( word quot -- )
- [
- init-templates
- swap >r { } make r> linearized get set-hash
- ] with-node-iterator ; inline
-
-: linearize-1 ( word node -- )
- swap [
- dup stack-reserve %prologue , linearize-child
- ] make-linear ;
-
-: init-linearizer ( -- )
- H{ } clone linearized set
- H{ } clone renamed-labels set ;
-
-: linearize ( word dataflow -- linearized )
- #! Outputs a hashtable mapping from labels to their
- #! respective linear IR.
- init-linearizer linearize-1 linearized get ;
-
-M: node linearize* ( node -- next ) drop iterate-next ;
-
-: linearize-call ( label -- next )
- end-basic-block
- tail-call? [ %jump , f ] [ %call , iterate-next ] if ;
-
-: rename-label ( label -- label )
- <label> dup rot renamed-labels get set-hash ;
-
-: renamed-label ( label -- label )
- renamed-labels get hash ;
-
-: linearize-call-label ( label -- next )
- rename-label linearize-call ;
-
-M: #label linearize* ( node -- next )
- #! We remap the IR node's label to a new label object here,
- #! to avoid problems with two IR #label nodes having the
- #! same label in different lexical scopes.
- dup node-param dup linearize-call-label >r
- renamed-label swap node-child linearize-1 r> ;
-
-: linearize-if ( node label -- next )
- <label> [
- >r >r node-children first2 linearize-child
- r> r> %jump-label , %label , linearize-child
- ] keep %label , iterate-next ;
-
-M: #call linearize* ( node -- next )
- dup if-intrinsic [
- >r <label> dup r> call
- >r node-successor r> linearize-if node-successor
- ] [
- dup intrinsic
- [ call iterate-next ] [ node-param linearize-call ] ?if
- ] if* ;
-
-M: #call-label linearize* ( node -- next )
- node-param renamed-label linearize-call ;
-
-M: #if linearize* ( node -- next )
- [
- end-basic-block
- <label> dup "flag" get %jump-t ,
- ] H{
- { +input { { 0 "flag" } } }
- } with-template linearize-if ;
-
-: dispatch-head ( node -- label/node )
- #! Output the jump table insn and return a list of
- #! label/branch pairs.
- [ end-basic-block "n" get %dispatch , ]
- H{ { +input { { 0 "n" } } } } with-template
- node-children [ <label> dup %target-label , 2array ] map ;
-
-: dispatch-body ( label/node -- )
- <label> swap [
- first2 %label , linearize-child end-basic-block
- dup %jump-label ,
- ] each %label , ;
-
-M: #dispatch linearize* ( node -- next )
- #! The parameter is a list of nodes, each one is a branch to
- #! take in case the top of stack has that type.
- dispatch-head dispatch-body iterate-next ;
-
-M: #return linearize* drop end-basic-block %return , f ;
+++ /dev/null
-! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: alien assembler kernel kernel-internals math sequences ;
-
-GENERIC: freg>stack ( stack reg reg-class -- )
-
-GENERIC: stack>freg ( stack reg reg-class -- )
-
-M: int-regs freg>stack drop 1 rot stack@ STW ;
-
-M: int-regs stack>freg drop 1 rot stack@ LWZ ;
-
-: STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
-
-M: float-regs freg>stack >r 1 rot stack@ r> STF ;
-
-: LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
-
-M: float-regs stack>freg >r 1 rot stack@ r> LF ;
-
-M: stack-params stack>freg
- drop 2dup = [
- 2drop
- ] [
- >r 0 1 rot stack@ LWZ 0 1 r> stack@ STW
- ] if ;
-
-M: stack-params freg>stack
- >r stack-increment + swap r> stack>freg ;
-
-M: %unbox generate-node ( vop -- )
- drop
- ! Call the unboxer
- 2 input f compile-c-call
- ! Store the return value on the C stack
- 0 input 1 input [ return-reg ] keep freg>stack ;
-
-: struct-ptr/size ( func -- )
- ! Load destination address
- 3 1 0 input stack@ ADDI
- ! Load struct size
- 2 input 4 LI
- f compile-c-call ;
-
-M: %unbox-struct generate-node ( vop -- )
- drop "unbox_value_struct" struct-ptr/size ;
-
-M: %box-struct generate-node ( vop -- )
- drop "box_value_struct" struct-ptr/size ;
-
-: (%move) 0 input 1 input 2 input [ fastcall-regs nth ] keep ;
-
-M: %stack>freg generate-node ( vop -- )
- ! Move a value from the C stack into the fastcall register
- drop (%move) stack>freg ;
-
-M: %freg>stack generate-node ( vop -- )
- ! Move a value from a fastcall register to the C stack
- drop (%move) freg>stack ;
-
-M: %box generate-node ( vop -- )
- drop
- ! If the source is a stack location, load it into freg #0.
- ! If the source is f, then we assume the value is already in
- ! freg #0.
- 0 input [
- 1 input [ fastcall-regs first ] keep stack>freg
- ] when*
- 2 input f compile-c-call ;
-
-M: %alien-callback generate-node ( vop -- )
- drop
- 3 0 input load-indirect
- "run_callback" f compile-c-call ;
-
-: save-return 0 swap [ return-reg ] keep freg>stack ;
-: load-return 0 swap [ return-reg ] keep stack>freg ;
-
-M: %callback-value generate-node ( vop -- )
- drop
- ! Call the unboxer
- 1 input f compile-c-call
- ! Save return register
- 0 input save-return
- ! Restore data/callstacks
- "unnest_stacks" f compile-c-call
- ! Restore return register
- 0 input load-return ;
IN: compiler
-USING: assembler kernel kernel-internals math ;
+USING: alien assembler generic kernel kernel-internals math
+memory namespaces sequences words ;
! PowerPC register assignments
! r3-r10 vregs
+! r11 linkage
! r14 data stack
! r15 call stack
-: fixnum-imm? ( -- ? )
- #! Can fixnum operations take immediate operands?
- f ; inline
-
: vregs { 3 4 5 6 7 8 9 10 } ; inline
M: int-regs return-reg drop 3 ;
! Mach-O -vs- Linux/PPC
: stack@ macosx? 24 8 ? + ;
: lr@ macosx? 8 4 ? + ;
+
+GENERIC: loc>operand
+
+M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
+M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;
+
+M: immediate load-literal ( literal vreg -- )
+ >r address r> v>operand LOAD ;
+
+M: object load-literal ( literal vreg -- )
+ v>operand swap
+ add-literal over
+ LOAD32 rel-2/2 rel-address
+ dup 0 LWZ ;
+
+: stack-increment \ stack-reserve get 32 max stack@ 16 align ;
+
+: %prologue ( n -- )
+ \ stack-reserve set
+ 1 1 stack-increment neg STWU
+ 0 MFLR
+ 0 1 stack-increment lr@ STW ;
+
+: compile-epilogue ( -- )
+ #! At the end of each word that calls a subroutine, we store
+ #! the previous link register value in r0 by popping it off
+ #! the stack, set the link register to the contents of r0,
+ #! and jump to the link register.
+ 0 1 stack-increment lr@ LWZ
+ 1 1 stack-increment ADDI
+ 0 MTLR ;
+
+: word-addr ( word -- )
+ #! Load a word address into r3.
+ dup word-xt 3 LOAD32 rel-2/2 rel-word ;
+
+: %call ( label -- )
+ #! Far C call for primitives, near C call for compiled defs.
+ dup postpone-word
+ dup primitive? [ word-addr 3 MTLR BLRL ] [ BL ] if ;
+
+: %jump-label ( label -- )
+ #! For tail calls. IP not saved on C stack.
+ dup primitive? [ word-addr 3 MTCTR BCTR ] [ B ] if ;
+
+: %jump ( label -- )
+ compile-epilogue dup postpone-word %jump-label ;
+
+: %jump-t ( label vreg -- )
+ 0 swap v>operand f address CMPI BNE ;
+
+: %dispatch ( vreg -- )
+ v>operand dup dup 1 SRAWI
+ ! The value 24 is a magic number. It is the length of the
+ ! instruction sequence that follows to be generated.
+ compiled-offset 24 + 11 LOAD32 rel-2/2 rel-address
+ dup dup 11 ADD
+ dup dup 0 LWZ
+ MTLR
+ BLR ;
+
+: %return ( -- ) compile-epilogue BLR ;
+
+: %peek ( vreg loc -- ) >r v>operand r> loc>operand LWZ ;
+
+: %replace ( vreg loc -- ) >r v>operand r> loc>operand STW ;
+
+: %inc-d ( n -- ) 14 14 rot cells ADDI ;
+
+: %inc-r ( n -- ) 15 15 rot cells ADDI ;
+
+GENERIC: freg>stack ( stack reg reg-class -- )
+
+GENERIC: stack>freg ( stack reg reg-class -- )
+
+M: int-regs freg>stack drop 1 rot stack@ STW ;
+
+M: int-regs stack>freg drop 1 rot stack@ LWZ ;
+
+: STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
+
+M: float-regs freg>stack >r 1 rot stack@ r> STF ;
+
+: LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
+
+M: float-regs stack>freg >r 1 rot stack@ r> LF ;
+
+M: stack-params stack>freg
+ drop 2dup = [
+ 2drop
+ ] [
+ >r 0 1 rot stack@ LWZ 0 1 r> stack@ STW
+ ] if ;
+
+M: stack-params freg>stack
+ >r stack-increment + swap r> stack>freg ;
+
+: (%move) [ fastcall-regs nth ] keep ;
+
+: %stack>freg ( n reg reg-class -- ) (%move) stack>freg ;
+
+: %freg>stack ( n reg reg-class -- ) (%move) freg>stack ;
+
+: %unbox ( n reg-class func -- )
+ ! Call the unboxer
+ f %alien-invoke
+ ! Store the return value on the C stack
+ [ return-reg ] keep freg>stack ;
+
+: %box ( n reg-class func -- )
+ ! If the source is a stack location, load it into freg #0.
+ ! If the source is f, then we assume the value is already in
+ ! freg #0.
+ pick [
+ >r [ fastcall-regs first ] keep stack>freg r>
+ ] [
+ 2nip
+ ] if
+ f %alien-invoke ;
+
+: struct-ptr/size ( n reg-class size func -- )
+ rot drop
+ ! Load destination address
+ >r >r 3 1 rot stack@ ADDI r>
+ ! Load struct size
+ 4 LI
+ r> f %alien-invoke ;
+
+: %unbox-struct ( n reg-class size -- )
+ "unbox_value_struct" struct-ptr/size ;
+
+: %box-struct ( n reg-class size -- )
+ "box_value_struct" struct-ptr/size ;
+
+: compile-dlsym ( symbol dll register -- )
+ >r 2dup dlsym r> LOAD32 rel-2/2 rel-dlsym ;
+
+: %alien-invoke ( symbol dll -- )
+ 11 [ compile-dlsym ] keep MTLR BLRL ;
+
+: %alien-callback ( quot -- )
+ T{ vreg f 0 } load-literal "run_callback" f %alien-invoke ;
+
+: save-return 0 swap [ return-reg ] keep freg>stack ;
+: load-return 0 swap [ return-reg ] keep stack>freg ;
+
+: %callback-value ( reg-class func -- )
+ ! Call the unboxer
+ f %alien-invoke
+ ! Save return register
+ dup save-return
+ ! Restore data/callstacks
+ "unnest_stacks" f %alien-invoke
+ ! Restore return register
+ load-return ;
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: assembler kernel kernel-internals math
-math-internals memory namespaces words ;
-
-: >3-vop< ( -- out1 in1 in2 )
- 0 output-operand 0 input-operand 1 input-operand ;
-
-: simple-overflow ( inv word -- )
- >r >r
- <label> "end" set
- "end" get BNO
- >3-vop< r> execute
- 0 input-operand dup untag-fixnum
- 1 input-operand dup untag-fixnum
- >3-vop< r> execute
- "s48_long_to_bignum" f compile-c-call
- ! An untagged pointer to the bignum is now in r3; tag it
- 0 output-operand dup bignum-tag ORI
- "end" get save-xt ; inline
-
-M: %fixnum+ generate-node ( vop -- )
- drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
-
-M: %fixnum+fast generate-node ( vop -- ) drop >3-vop< ADD ;
-
-M: %fixnum-fast generate-node ( vop -- ) drop >3-vop< SUBF ;
-
-M: %fixnum- generate-node ( vop -- )
- drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ;
-
-M: %fixnum* generate-node ( vop -- )
- #! Note that this assumes the output will be in r3.
- drop
- <label> "end" set
- 1 input-operand dup untag-fixnum
- 0 MTXER
- 0 scratch 0 input-operand 1 input-operand MULLWO.
- "end" get BNO
- 1 scratch 0 input-operand 1 input-operand MULHW
- 4 1 scratch MR
- 3 0 scratch MR
- "s48_fixnum_pair_to_bignum" f compile-c-call
- ! now we have to shift it by three bits to remove the second
- ! tag
- tag-bits neg 4 LI
- "s48_bignum_arithmetic_shift" f compile-c-call
- ! An untagged pointer to the bignum is now in r3; tag it
- 0 output-operand 0 scratch bignum-tag ORI
- "end" get save-xt
- 0 output-operand 0 scratch MR ;
-
-: generate-fixnum/i
- #! This VOP is funny. If there is an overflow, it falls
- #! through to the end, and the result is in 0 output-operand.
- #! Otherwise it jumps to the "no-overflow" label and the
- #! result is in 0 scratch.
- 0 scratch 1 input-operand 0 input-operand DIVW
- ! if the result is greater than the most positive fixnum,
- ! which can only ever happen if we do
- ! most-negative-fixnum -1 /i, then the result is a bignum.
- <label> "end" set
- <label> "no-overflow" set
- most-positive-fixnum 1 scratch LOAD
- 0 scratch 0 1 scratch CMP
- "no-overflow" get BLE
- most-negative-fixnum neg 3 LOAD
- "s48_long_to_bignum" f compile-c-call
- 3 dup bignum-tag ORI ;
-
-M: %fixnum/i generate-node ( vop -- )
- #! This has specific vreg requirements.
- drop
- generate-fixnum/i
- "end" get B
- "no-overflow" get save-xt
- 0 scratch 0 output-operand tag-fixnum
- "end" get save-xt ;
-
-: generate-fixnum-mod
- #! PowerPC doesn't have a MOD instruction; so we compute
- #! x-(x/y)*y. Puts the result in 1 scratch.
- 1 scratch 0 scratch 0 input-operand MULLW
- 1 scratch 1 scratch 1 input-operand SUBF ;
-
-M: %fixnum-mod generate-node ( vop -- )
- drop
- ! divide in2 by in1, store result in out1
- 0 scratch 1 input-operand 0 input-operand DIVW
- generate-fixnum-mod
- 0 output-operand 1 scratch MR ;
-
-M: %fixnum/mod generate-node ( vop -- )
- #! This has specific vreg requirements. Note: if there's an
- #! overflow, (most-negative-fixnum 1 /mod) the modulus is
- #! always zero.
- drop
- generate-fixnum/i
- 0 0 output-operand LI
- "end" get B
- "no-overflow" get save-xt
- generate-fixnum-mod
- 0 scratch 1 output-operand tag-fixnum
- 0 output-operand 1 scratch MR
- "end" get save-xt ;
-
-M: %fixnum-bitand generate-node ( vop -- ) drop >3-vop< AND ;
-
-M: %fixnum-bitor generate-node ( vop -- ) drop >3-vop< OR ;
-
-M: %fixnum-bitxor generate-node ( vop -- ) drop >3-vop< XOR ;
-
-M: %fixnum-bitnot generate-node ( vop -- )
- drop dest/src NOT
- 0 output-operand dup untag ;
-
-M: %fixnum>> generate-node ( vop -- )
- drop
- 1 input-operand 0 output-operand 0 input SRAWI
- 0 output-operand dup untag ;
-
-M: %fixnum-sgn generate-node ( vop -- )
- drop dest/src cell-bits 1- SRAWI 0 output-operand dup untag ;
-
-: fixnum-jump ( -- label )
- 1 input-operand 0 0 input-operand CMP label ;
-
-M: %jump-fixnum< generate-node ( vop -- ) drop fixnum-jump BLT ;
-M: %jump-fixnum<= generate-node ( vop -- ) drop fixnum-jump BLE ;
-M: %jump-fixnum> generate-node ( vop -- ) drop fixnum-jump BGT ;
-M: %jump-fixnum>= generate-node ( vop -- ) drop fixnum-jump BGE ;
-M: %jump-eq? generate-node ( vop -- ) drop fixnum-jump BEQ ;
+++ /dev/null
-! Copyright (C) 2005, 200 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: alien assembler inference kernel kernel-internals lists
-math memory namespaces words ;
-
-: compile-dlsym ( symbol dll register -- )
- >r 2dup dlsym r> LOAD32 rel-2/2 rel-dlsym ;
-
-: compile-c-call ( symbol dll -- )
- 11 [ compile-dlsym ] keep MTLR BLRL ;
-
-: stack-increment \ stack-reserve get 32 max stack@ 16 align ;
-
-M: %prologue generate-node ( vop -- )
- drop
- 0 input \ stack-reserve set
- 1 1 stack-increment neg STWU
- 0 MFLR
- 0 1 stack-increment lr@ STW ;
-
-: compile-epilogue
- #! At the end of each word that calls a subroutine, we store
- #! the previous link register value in r0 by popping it off
- #! the stack, set the link register to the contents of r0,
- #! and jump to the link register.
- 0 1 stack-increment lr@ LWZ
- 1 1 stack-increment ADDI
- 0 MTLR ;
-
-: word-addr ( word -- )
- #! Load a word address into r3.
- dup word-xt 3 LOAD32 rel-2/2 rel-word ;
-
-: compile-call ( label -- )
- #! Far C call for primitives, near C call for compiled defs.
- dup postpone-word
- dup primitive? [ word-addr 3 MTLR BLRL ] [ BL ] if ;
-
-M: %call generate-node ( vop -- )
- vop-label compile-call ;
-
-: compile-jump ( label -- )
- #! For tail calls. IP not saved on C stack.
- dup postpone-word
- dup primitive? [ word-addr 3 MTCTR BCTR ] [ B ] if ;
-
-M: %jump generate-node ( vop -- )
- drop compile-epilogue label compile-jump ;
-
-M: %jump-label generate-node ( vop -- )
- drop label compile-jump ;
-
-M: %jump-t generate-node ( vop -- )
- drop 0 input-operand 0 swap f address CMPI label BNE ;
-
-M: %return generate-node ( vop -- )
- drop compile-epilogue BLR ;
-
-: untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ;
-
-M: %untag generate-node ( vop -- )
- drop dest/src untag ;
-
-: tag-fixnum ( src dest -- ) tag-bits SLWI ;
-
-: untag-fixnum ( src dest -- ) tag-bits SRAWI ;
-
-M: %dispatch generate-node ( vop -- )
- drop
- 0 input-operand dup 1 SRAWI
- ! The value 24 is a magic number. It is the length of the
- ! instruction sequence that follows to be generated.
- compiled-offset 24 + 0 scratch LOAD32 rel-2/2 rel-address
- 0 input-operand dup 0 scratch ADD
- 0 input-operand dup 0 LWZ
- 0 input-operand MTLR
- BLR ;
-
-M: %type generate-node ( vop -- )
- drop
- <label> "f" set
- <label> "end" set
- ! Get the tag
- 0 input-operand 1 scratch tag-mask ANDI
- ! Tag the tag
- 1 scratch 0 scratch tag-fixnum
- ! Compare with object tag number (3).
- 0 1 scratch object-tag CMPI
- ! Jump if the object doesn't store type info in its header
- "end" get BNE
- ! It does store type info in its header
- ! Is the pointer itself equal to 3? Then its F_TYPE (9).
- 0 0 input-operand object-tag CMPI
- "f" get BEQ
- ! The pointer is not equal to 3. Load the object header.
- 0 scratch 0 input-operand object-tag neg LWZ
- 0 scratch dup untag
- "end" get B
- "f" get save-xt
- ! The pointer is equal to 3. Load F_TYPE (9).
- f type tag-bits shift 0 scratch LI
- "end" get save-xt
- 0 output-operand 0 scratch MR ;
-
-M: %tag generate-node ( vop -- )
- drop dest/src swap tag-mask ANDI
- 0 output-operand dup tag-fixnum ;
--- /dev/null
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler
+USING: assembler kernel kernel-internals math math-internals
+namespaces sequences ;
+
+: untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ;
+
+: tag-fixnum ( src dest -- ) tag-bits SLWI ;
+
+: untag-fixnum ( src dest -- ) tag-bits SRAWI ;
+
+\ tag [
+ "in" operand dup tag-mask ANDI
+ "in" operand dup tag-fixnum
+] H{
+ { +input { { f "in" } } }
+ { +output { "in" } }
+} define-intrinsic
+
+: generate-slot ( size quot -- )
+ >r >r
+ ! turn tagged fixnum slot # into an offset, multiple of 4
+ "n" operand dup tag-bits r> - SRAWI
+ ! compute slot address
+ "obj" operand dup "n" operand ADD
+ ! load slot value
+ "obj" operand dup r> call ; inline
+
+\ slot [
+ "obj" operand dup untag
+ cell log2 [ 0 LWZ ] generate-slot
+] H{
+ { +input { { f "obj" } { f "n" } } }
+ { +output { "obj" } }
+} define-intrinsic
+
+\ char-slot [
+ 1 [ string-offset LHZ ] generate-slot
+ "obj" operand dup tag-fixnum
+] H{
+ { +input { { f "n" } { f "obj" } } }
+ { +output { "obj" } }
+} define-intrinsic
+
+: define-binary-op ( word op -- )
+ [ [ "x" operand "y" operand "x" operand ] % , ] [ ] make H{
+ { +input { { f "x" } { f "y" } } }
+ { +output { "x" } }
+ } define-intrinsic ;
+
+{
+ { fixnum+fast ADD }
+ { fixnum-fast SUBF }
+ { fixnum-bitand AND }
+ { fixnum-bitor OR }
+ { fixnum-bitxor XOR }
+} [
+ first2 define-binary-op
+] each
+
+\ fixnum-bitnot [
+ "x" operand dup NOT
+ "x" operand dup untag
+] H{
+ { +input { { f "x" } } }
+ { +output { "x" } }
+} define-intrinsic
+
+: define-binary-jump ( word op -- )
+ [
+ [ end-basic-block "x" operand 0 "y" operand CMP ] % ,
+ ] [ ] make H{ { +input { { f "x" } { f "y" } } } }
+ define-if-intrinsic ;
+
+{
+ { fixnum< BLT }
+ { fixnum<= BLE }
+ { fixnum> BGT }
+ { fixnum>= BGE }
+ { eq? BEQ }
+} [
+ first2 define-binary-jump
+] each
+
+! M: %type generate-node ( vop -- )
+! drop
+! <label> "f" set
+! <label> "end" set
+! ! Get the tag
+! 0 input-operand 1 scratch tag-mask ANDI
+! ! Tag the tag
+! 1 scratch 0 scratch tag-fixnum
+! ! Compare with object tag number (3).
+! 0 1 scratch object-tag CMPI
+! ! Jump if the object doesn't store type info in its header
+! "end" get BNE
+! ! It does store type info in its header
+! ! Is the pointer itself equal to 3? Then its F_TYPE (9).
+! 0 0 input-operand object-tag CMPI
+! "f" get BEQ
+! ! The pointer is not equal to 3. Load the object header.
+! 0 scratch 0 input-operand object-tag neg LWZ
+! 0 scratch dup untag
+! "end" get B
+! "f" get save-xt
+! ! The pointer is equal to 3. Load F_TYPE (9).
+! f type tag-bits shift 0 scratch LI
+! "end" get save-xt
+! 0 output-operand 0 scratch MR ;
+!
+! : generate-set-slot ( size quot -- )
+! >r >r
+! ! turn tagged fixnum slot # into an offset, multiple of 4
+! 2 input-operand dup tag-bits r> - SRAWI
+! ! compute slot address in 1st input
+! 2 input-operand dup 1 input-operand ADD
+! ! store new slot value
+! 0 input-operand 2 input-operand r> call ; inline
+!
+! M: %set-slot generate-node ( vop -- )
+! drop cell log2 [ 0 STW ] generate-set-slot ;
+!
+! M: %write-barrier generate-node ( vop -- )
+! #! Mark the card pointed to by vreg.
+! drop
+! 0 input-operand dup card-bits SRAWI
+! 0 input-operand dup 16 ADD
+! 0 scratch 0 input-operand 0 LBZ
+! 0 scratch dup card-mark ORI
+! 0 scratch 0 input-operand 0 STB ;
+!
+! : simple-overflow ( inv word -- )
+! >r >r
+! <label> "end" set
+! "end" get BNO
+! >3-vop< r> execute
+! 0 input-operand dup untag-fixnum
+! 1 input-operand dup untag-fixnum
+! >3-vop< r> execute
+! "s48_long_to_bignum" f compile-c-call
+! ! An untagged pointer to the bignum is now in r3; tag it
+! 0 output-operand dup bignum-tag ORI
+! "end" get save-xt ; inline
+!
+! M: %fixnum+ generate-node ( vop -- )
+! drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
+!
+! M: %fixnum- generate-node ( vop -- )
+! drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ;
+!
+! M: %fixnum* generate-node ( vop -- )
+! #! Note that this assumes the output will be in r3.
+! drop
+! <label> "end" set
+! 1 input-operand dup untag-fixnum
+! 0 MTXER
+! 0 scratch 0 input-operand 1 input-operand MULLWO.
+! "end" get BNO
+! 1 scratch 0 input-operand 1 input-operand MULHW
+! 4 1 scratch MR
+! 3 0 scratch MR
+! "s48_fixnum_pair_to_bignum" f compile-c-call
+! ! now we have to shift it by three bits to remove the second
+! ! tag
+! tag-bits neg 4 LI
+! "s48_bignum_arithmetic_shift" f compile-c-call
+! ! An untagged pointer to the bignum is now in r3; tag it
+! 0 output-operand 0 scratch bignum-tag ORI
+! "end" get save-xt
+! 0 output-operand 0 scratch MR ;
+!
+! : generate-fixnum/i
+! #! This VOP is funny. If there is an overflow, it falls
+! #! through to the end, and the result is in 0 output-operand.
+! #! Otherwise it jumps to the "no-overflow" label and the
+! #! result is in 0 scratch.
+! 0 scratch 1 input-operand 0 input-operand DIVW
+! ! if the result is greater than the most positive fixnum,
+! ! which can only ever happen if we do
+! ! most-negative-fixnum -1 /i, then the result is a bignum.
+! <label> "end" set
+! <label> "no-overflow" set
+! most-positive-fixnum 1 scratch LOAD
+! 0 scratch 0 1 scratch CMP
+! "no-overflow" get BLE
+! most-negative-fixnum neg 3 LOAD
+! "s48_long_to_bignum" f compile-c-call
+! 3 dup bignum-tag ORI ;
+!
+! M: %fixnum/i generate-node ( vop -- )
+! #! This has specific vreg requirements.
+! drop
+! generate-fixnum/i
+! "end" get B
+! "no-overflow" get save-xt
+! 0 scratch 0 output-operand tag-fixnum
+! "end" get save-xt ;
+!
+! : generate-fixnum-mod
+! #! PowerPC doesn't have a MOD instruction; so we compute
+! #! x-(x/y)*y. Puts the result in 1 scratch.
+! 1 scratch 0 scratch 0 input-operand MULLW
+! 1 scratch 1 scratch 1 input-operand SUBF ;
+!
+! M: %fixnum-mod generate-node ( vop -- )
+! drop
+! ! divide in2 by in1, store result in out1
+! 0 scratch 1 input-operand 0 input-operand DIVW
+! generate-fixnum-mod
+! 0 output-operand 1 scratch MR ;
+!
+! M: %fixnum/mod generate-node ( vop -- )
+! #! This has specific vreg requirements. Note: if there's an
+! #! overflow, (most-negative-fixnum 1 /mod) the modulus is
+! #! always zero.
+! drop
+! generate-fixnum/i
+! 0 0 output-operand LI
+! "end" get B
+! "no-overflow" get save-xt
+! generate-fixnum-mod
+! 0 scratch 1 output-operand tag-fixnum
+! 0 output-operand 1 scratch MR
+! "end" get save-xt ;
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: alien assembler inference kernel
-kernel-internals lists math memory namespaces sequences words ;
-
-: generate-slot ( size quot -- )
- >r >r
- ! turn tagged fixnum slot # into an offset, multiple of 4
- 0 input-operand dup tag-bits r> - SRAWI
- ! compute slot address
- 0 output-operand dup 0 input-operand ADD
- ! load slot value
- 0 output-operand dup r> call ; inline
-
-M: %slot generate-node ( vop -- )
- drop cell log2 [ 0 LWZ ] generate-slot ;
-
-M: %fast-slot generate-node ( vop -- )
- drop 0 output-operand dup 0 input LWZ ;
-
-: generate-set-slot ( size quot -- )
- >r >r
- ! turn tagged fixnum slot # into an offset, multiple of 4
- 2 input-operand dup tag-bits r> - SRAWI
- ! compute slot address in 1st input
- 2 input-operand dup 1 input-operand ADD
- ! store new slot value
- 0 input-operand 2 input-operand r> call ; inline
-
-M: %set-slot generate-node ( vop -- )
- drop cell log2 [ 0 STW ] generate-set-slot ;
-
-M: %fast-set-slot generate-node ( vop -- )
- drop 0 input-operand 1 input-operand 2 input STW ;
-
-M: %write-barrier generate-node ( vop -- )
- #! Mark the card pointed to by vreg.
- drop
- 0 input-operand dup card-bits SRAWI
- 0 input-operand dup 16 ADD
- 0 scratch 0 input-operand 0 LBZ
- 0 scratch dup card-mark ORI
- 0 scratch 0 input-operand 0 STB ;
-
-M: %char-slot generate-node ( vop -- )
- drop 1 [ string-offset LHZ ] generate-slot
- 0 output-operand dup tag-fixnum ;
-
-M: %set-char-slot generate-node ( vop -- )
- ! untag the new value in 0th input
- drop 0 input-operand dup untag-fixnum
- 1 [ string-offset STH ] generate-set-slot ;
-
-: userenv ( reg -- )
- #! Load the userenv pointer in a virtual register.
- "userenv" f dlsym swap LOAD32 0 rel-2/2 rel-userenv ;
-
-M: %getenv generate-node ( vop -- )
- drop 0 output-operand dup dup userenv 0 input cells LWZ ;
-
-M: %setenv generate-node ( vop -- )
- drop 0 scratch userenv
- 0 input-operand 0 scratch 1 input cells STW ;
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: assembler errors kernel kernel-internals math
-memory namespaces words ;
-
-GENERIC: loc>operand
-
-M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
-M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;
-
-: %literal ( quot -- )
- 0 output vreg? [
- 0 input 0 output-operand rot call
- ] [
- 0 input 11 rot call
- 11 0 output loc>operand STW
- ] if ; inline
-
-M: %immediate generate-node ( vop -- )
- drop [ >r address r> LOAD ] %literal ;
-
-: load-indirect ( dest literal -- )
- add-literal over LOAD32 rel-2/2 rel-address dup 0 LWZ ;
-
-M: %indirect generate-node ( vop -- )
- drop [ swap load-indirect ] %literal ;
-
-M: %peek generate-node ( vop -- )
- drop 0 output-operand 0 input loc>operand LWZ ;
-
-M: %replace generate-node ( vop -- )
- drop 0 input-operand 0 output loc>operand STW ;
-
-M: %inc-d generate-node ( vop -- )
- drop 14 14 0 input cells ADDI ;
-
-M: %inc-r generate-node ( vop -- )
- drop 15 15 0 input cells ADDI ;
+++ /dev/null
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: arrays generic inference io kernel math
-namespaces prettyprint sequences vectors words ;
-
-: immediate? ( obj -- ? ) dup fixnum? swap not or ;
-
-: load-literal ( obj dest -- )
- over immediate? [ %immediate ] [ %indirect ] if , ;
-
-: phantom-shuffle-input ( n phantom -- seq )
- 2dup length <= [
- cut-phantom
- ] [
- [ phantom-locs ] keep [ length swap head-slice* ] keep
- [ append 0 ] keep set-length
- ] if ;
-
-: phantom-shuffle-inputs ( shuffle -- locs locs )
- dup shuffle-in-d length phantom-d get phantom-shuffle-input
- swap shuffle-in-r length phantom-r get phantom-shuffle-input ;
-
-: adjust-shuffle ( shuffle -- )
- dup shuffle-in-d length neg phantom-d get adjust-phantom
- shuffle-in-r length neg phantom-r get adjust-phantom ;
-
-: shuffle-vregs# ( shuffle -- n )
- dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
-
-: phantom-shuffle ( shuffle -- )
- dup shuffle-vregs# ensure-vregs
- [ phantom-shuffle-inputs ] keep
- [ shuffle* ] keep adjust-shuffle
- (template-outputs) ;
-
-M: #shuffle linearize* ( #shuffle -- )
- node-shuffle phantom-shuffle iterate-next ;
-
-: linearize-push ( node -- )
- >#push< dup length dup ensure-vregs
- alloc-reg# [ <vreg> ] map
- [ [ load-literal ] 2each ] keep
- phantom-d get phantom-append ;
-
-M: #push linearize* ( #push -- )
- linearize-push iterate-next ;
#! instruction here.
swap [
phantom-stack-height
- dup zero? [ 2drop ] [ swap execute , ] if
+ dup zero? [ 2drop ] [ swap execute ] if
0
] keep set-phantom-stack-height ; inline
: alloc-reg ( -- n ) free-vregs get pop ;
: stack>vreg ( vreg# loc -- operand )
- >r <vreg> dup r> %peek , ;
+ >r <vreg> dup r> %peek ;
: stack>new-vreg ( loc -- vreg )
alloc-reg swap stack>vreg ;
over loc? [
2drop
] [
- over [ %replace , ] [ 2drop ] if
+ over [ %replace ] [ 2drop ] if
] if ;
: vregs>stack ( phantom -- )
: with-template ( quot spec -- )
fix-spec [ template-inputs call template-outputs ] bind
compute-free-vregs ; inline
+
+: operand ( var -- op ) get v>operand ; inline
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: arrays errors generic hashtables kernel kernel-internals
-lists math memory namespaces parser sequences words ;
-
-! The linear IR is the second of the two intermediate
-! representations used by Factor. It is basically a high-level
-! assembly language. Linear IR operations are called VOPs.
-
-! This file defines all the types of VOPs. A linear IR program
-! is then just a list of VOPs.
-
-: <label> ( -- label )
- #! Make a label.
- gensym dup t "label" set-word-prop ;
-
-: label? ( obj -- ? )
- dup word? [ "label" word-prop ] [ drop f ] if ;
-
-! A virtual register
-TUPLE: vreg n ;
-
-! Register classes
-TUPLE: int-regs ;
-TUPLE: float-regs size ;
-
-! A pseudo-register class for parameters spilled on the stack
-TUPLE: stack-params ;
-
-GENERIC: return-reg ( register-class -- reg )
-
-GENERIC: fastcall-regs ( register-class -- regs )
-
-M: stack-params fastcall-regs drop 0 ;
-
-GENERIC: reg-size ( register-class -- n )
-
-GENERIC: inc-reg-class ( register-class -- )
-
-M: int-regs reg-size drop cell ;
-
-: (inc-reg-class)
- dup class inc
- macosx? [ reg-size stack-params +@ ] [ drop ] if ;
-
-M: int-regs inc-reg-class
- (inc-reg-class) ;
-
-M: float-regs reg-size float-regs-size ;
-
-M: float-regs inc-reg-class
- dup (inc-reg-class)
- macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
-
-GENERIC: v>operand
-
-M: integer v>operand tag-bits shift ;
-
-M: vreg v>operand vreg-n vregs nth ;
-
-M: f v>operand address ;
-
-! A virtual operation
-TUPLE: vop inputs outputs label ;
-
-: (scratch)
- vop get dup vop-inputs swap vop-outputs append
- [ vreg? ] subset [ v>operand ] map vregs diff ;
-
-: scratch ( n -- reg )
- #! Output a scratch register that is not used by the
- #! current VOP.
- \ scratch get nth ;
-
-: with-vop ( vop quot -- )
- swap vop set (scratch) \ scratch set call ; inline
-
-: input ( n -- obj ) vop get vop-inputs nth ;
-: input-operand ( n -- n ) input v>operand ;
-: output ( n -- obj ) vop get vop-outputs nth ;
-: output-operand ( n -- n ) output v>operand ;
-: label ( -- label ) vop get vop-label ;
-
-: make-vop ( inputs outputs label vop -- vop )
- [ >r <vop> r> set-delegate ] keep ;
-
-: empty-vop f f f ;
-: label-vop ( label) >r f f r> ;
-: label/src-vop ( label src) 1array swap f swap ;
-: src-vop ( src) 1array f f ;
-: dest-vop ( dest) 1array dup f ;
-: src/dest-vop ( src dest) >r 1array r> 1array f ;
-: 2-in-vop ( in1 in2) 2array f f ;
-: 3-in-vop ( in1 in2 in3) 3array f f ;
-: 2-in/label-vop ( in1 in2 label) >r 2array f r> ;
-: 2-vop ( in dest) [ 2array ] keep 1array f ;
-: 3-vop ( in1 in2 dest) >r 2array r> 1array f ;
-
-! miscellanea
-TUPLE: %prologue ;
-C: %prologue make-vop ;
-: %prologue src-vop <%prologue> ;
-
-TUPLE: %label ;
-C: %label make-vop ;
-: %label label-vop <%label> ;
-
-TUPLE: %return ;
-C: %return make-vop ;
-: %return empty-vop <%return> ;
-
-TUPLE: %jump ;
-C: %jump make-vop ;
-: %jump label-vop <%jump> ;
-
-TUPLE: %jump-label ;
-C: %jump-label make-vop ;
-: %jump-label label-vop <%jump-label> ;
-
-TUPLE: %call ;
-C: %call make-vop ;
-: %call label-vop <%call> ;
-
-TUPLE: %jump-t ;
-C: %jump-t make-vop ;
-: %jump-t label/src-vop <%jump-t> ;
-
-! dispatch tables
-TUPLE: %dispatch ;
-C: %dispatch make-vop ;
-: %dispatch src-vop <%dispatch> ;
-
-TUPLE: %target-label ;
-C: %target-label make-vop ;
-: %target-label label-vop <%target-label> ;
-
-! stack operations
-TUPLE: %peek ;
-C: %peek make-vop ;
-: %peek swap src/dest-vop <%peek> ;
-
-TUPLE: %replace ;
-C: %replace make-vop ;
-: %replace ( vreg loc -- vop ) src/dest-vop <%replace> ;
-
-TUPLE: %inc-d ;
-C: %inc-d make-vop ;
-: %inc-d ( n -- node ) src-vop <%inc-d> ;
-
-TUPLE: %inc-r ;
-C: %inc-r make-vop ;
-: %inc-r ( n -- ) src-vop <%inc-r> ;
-
-TUPLE: %immediate ;
-C: %immediate make-vop ;
-
-: %immediate ( obj vreg -- vop )
- src/dest-vop <%immediate> ;
-
-! indirect load of a literal through a table
-TUPLE: %indirect ;
-C: %indirect make-vop ;
-: %indirect ( obj vreg -- )
- src/dest-vop <%indirect> ;
-
-! object slot accessors
-TUPLE: %untag ;
-C: %untag make-vop ;
-: %untag dest-vop <%untag> ;
-
-TUPLE: %slot ;
-C: %slot make-vop ;
-: %slot ( n vreg ) 2-vop <%slot> ;
-
-: set-slot-vop
- [ 3array ] keep 1array f ;
-
-TUPLE: %set-slot ;
-C: %set-slot make-vop ;
-
-: %set-slot ( value obj n )
- #! %set-slot writes to vreg obj.
- set-slot-vop <%set-slot> ;
-
-! in the 'fast' versions, the object's type and slot number is
-! known at compile time, so these become a single instruction
-TUPLE: %fast-slot ;
-C: %fast-slot make-vop ;
-: %fast-slot ( n vreg )
- 2-vop <%fast-slot> ;
-
-TUPLE: %fast-set-slot ;
-C: %fast-set-slot make-vop ;
-: %fast-set-slot ( value obj n )
- #! %fast-set-slot writes to vreg obj.
- over >r 3array r> 1array f <%fast-set-slot> ;
-
-! Char readers and writers
-TUPLE: %char-slot ;
-C: %char-slot make-vop ;
-: %char-slot ( n vreg ) 2-vop <%char-slot> ;
-
-TUPLE: %set-char-slot ;
-C: %set-char-slot make-vop ;
-
-: %set-char-slot ( value ch n )
- #! %set-char-slot writes to vreg obj.
- set-slot-vop <%set-char-slot> ;
-
-TUPLE: %write-barrier ;
-C: %write-barrier make-vop ;
-: %write-barrier ( ptr ) dest-vop <%write-barrier> ;
-
-! fixnum intrinsics
-TUPLE: %fixnum+ ;
-C: %fixnum+ make-vop ; : %fixnum+ 3-vop <%fixnum+> ;
-TUPLE: %fixnum+fast ;
-C: %fixnum+fast make-vop ; : %fixnum+fast 3-vop <%fixnum+fast> ;
-TUPLE: %fixnum- ;
-C: %fixnum- make-vop ; : %fixnum- 3-vop <%fixnum-> ;
-TUPLE: %fixnum-fast ;
-C: %fixnum-fast make-vop ; : %fixnum-fast 3-vop <%fixnum-fast> ;
-TUPLE: %fixnum* ;
-C: %fixnum* make-vop ; : %fixnum* 3-vop <%fixnum*> ;
-TUPLE: %fixnum-mod ;
-C: %fixnum-mod make-vop ; : %fixnum-mod 3-vop <%fixnum-mod> ;
-TUPLE: %fixnum/i ;
-C: %fixnum/i make-vop ; : %fixnum/i 3-vop <%fixnum/i> ;
-TUPLE: %fixnum/mod ;
-C: %fixnum/mod make-vop ; : %fixnum/mod f <%fixnum/mod> ;
-
-TUPLE: %fixnum-bitand ;
-C: %fixnum-bitand make-vop ; : %fixnum-bitand 3-vop <%fixnum-bitand> ;
-
-TUPLE: %fixnum-bitor ;
-C: %fixnum-bitor make-vop ; : %fixnum-bitor 3-vop <%fixnum-bitor> ;
-
-TUPLE: %fixnum-bitxor ;
-C: %fixnum-bitxor make-vop ; : %fixnum-bitxor 3-vop <%fixnum-bitxor> ;
-
-TUPLE: %fixnum-bitnot ;
-C: %fixnum-bitnot make-vop ; : %fixnum-bitnot 2-vop <%fixnum-bitnot> ;
-
-! At the VOP level, the 'shift' operation is split into four
-! distinct operations:
-! - shifts with a positive count: calls runtime to make
-! a bignum
-! - shifts with a small negative count: %fixnum>>
-! - shifts with a small negative count: %fixnum>>
-! - shifts with a large negative count: %fixnum-sgn
-TUPLE: %fixnum>> ;
-C: %fixnum>> make-vop ; : %fixnum>> 3-vop <%fixnum>>> ;
-
-! due to x86 limitations the destination of this VOP must be
-! vreg 2 (EDX), and the source must be vreg 0 (EAX).
-TUPLE: %fixnum-sgn ;
-C: %fixnum-sgn make-vop ; : %fixnum-sgn src/dest-vop <%fixnum-sgn> ;
-
-! Integer comparison followed by a conditional branch is
-! optimized
-TUPLE: %jump-fixnum<= ;
-C: %jump-fixnum<= make-vop ;
-: %jump-fixnum<= 2-in/label-vop <%jump-fixnum<=> ;
-
-TUPLE: %jump-fixnum< ;
-C: %jump-fixnum< make-vop ;
-: %jump-fixnum< 2-in/label-vop <%jump-fixnum<> ;
-
-TUPLE: %jump-fixnum>= ;
-C: %jump-fixnum>= make-vop ;
-: %jump-fixnum>= 2-in/label-vop <%jump-fixnum>=> ;
-
-TUPLE: %jump-fixnum> ;
-C: %jump-fixnum> make-vop ;
-: %jump-fixnum> 2-in/label-vop <%jump-fixnum>> ;
-
-TUPLE: %jump-eq? ;
-C: %jump-eq? make-vop ;
-: %jump-eq? 2-in/label-vop <%jump-eq?> ;
-
-! some slightly optimized inline assembly
-TUPLE: %type ;
-C: %type make-vop ;
-: %type ( vreg ) dest-vop <%type> ;
-
-TUPLE: %tag ;
-C: %tag make-vop ;
-: %tag ( vreg ) dest-vop <%tag> ;
-
-TUPLE: %getenv ;
-C: %getenv make-vop ;
-: %getenv src/dest-vop <%getenv> ;
-
-TUPLE: %setenv ;
-C: %setenv make-vop ;
-: %setenv 2-in-vop <%setenv> ;
-
-TUPLE: %stack>freg ;
-C: %stack>freg make-vop ;
-: %stack>freg ( n reg reg-class -- vop ) 3-in-vop <%stack>freg> ;
-
-TUPLE: %freg>stack ;
-C: %freg>stack make-vop ;
-: %freg>stack ( n reg reg-class -- vop ) 3-in-vop <%freg>stack> ;
-
-TUPLE: %cleanup ;
-C: %cleanup make-vop ;
-: %cleanup ( n -- vop ) src-vop <%cleanup> ;
-
-TUPLE: %unbox ;
-C: %unbox make-vop ;
-: %unbox ( n reg-class func -- vop ) 3-in-vop <%unbox> ;
-
-TUPLE: %unbox-struct ;
-C: %unbox-struct make-vop ;
-: %unbox-struct ( n reg-class size -- vop )
- 3-in-vop <%unbox-struct> ;
-
-TUPLE: %box ;
-C: %box make-vop ;
-: %box ( n reg-class func -- vop ) 3-in-vop <%box> ;
-
-TUPLE: %box-struct ;
-C: %box-struct make-vop ;
-: %box-struct ( n reg-class size -- vop )
- 3-in-vop <%box-struct> ;
-
-TUPLE: %alien-invoke ;
-C: %alien-invoke make-vop ;
-: %alien-invoke ( func lib -- vop ) 2-in-vop <%alien-invoke> ;
-
-TUPLE: %alien-callback ;
-C: %alien-callback make-vop ;
-: %alien-callback ( quot -- vop ) src-vop <%alien-callback> ;
-
-TUPLE: %callback-value ;
-C: %callback-value make-vop ;
-: %callback-value ( reg-class func -- vop )
- 2-in-vop <%callback-value> ;
! ESI datastack
! EBX callstack
-: fixnum-imm? ( -- ? )
- #! Can fixnum operations take immediate operands?
- t ; inline
-
: ds-reg ESI ; inline
: cs-reg EBX ; inline
: remainder-reg EDX ; inline
kernel-internals lists math namespaces prettyprint sequences
strings vectors words ;
+: <label> ( -- label )
+ #! Make a label.
+ gensym dup t "label" set-word-prop ;
+
+: label? ( obj -- ? )
+ dup word? [ "label" word-prop ] [ drop f ] if ;
+
! We use a hashtable "compiled-xts" that maps words to
! xt's that are currently being compiled. The commit-xt's word
! sets the xt of each word in the hashtable to the value in the
#! added to the list of words to be compiled.
dup compiled?
over label? or
- over linearized get ?hash or
over compile-words get member? or
swap compiled-xts get hash or ;
[ 3 ] [ f dummy-unless-3 ] unit-test
[ 4 ] [ 4 dummy-unless-3 ] unit-test
+! Test cond expansion
[ "even" ] [
[
2 {
[ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-1 ] unit-test
[ 11 ] [ [ 12 7 fixnum-bitxor ] compile-1 ] unit-test
-[ f ] [ 12 7 [ fixnum< ] compile-1 ] unit-test
-[ f ] [ 12 [ 7 fixnum< ] compile-1 ] unit-test
-[ f ] [ [ 12 7 fixnum< ] compile-1 ] unit-test
-[ f ] [ [ 12 12 fixnum< ] compile-1 ] unit-test
-
-[ t ] [ 12 70 [ fixnum< ] compile-1 ] unit-test
-[ t ] [ 12 [ 70 fixnum< ] compile-1 ] unit-test
-[ t ] [ [ 12 70 fixnum< ] compile-1 ] unit-test
-
-[ f ] [ 12 7 [ fixnum<= ] compile-1 ] unit-test
-[ f ] [ 12 [ 7 fixnum<= ] compile-1 ] unit-test
-[ f ] [ [ 12 7 fixnum<= ] compile-1 ] unit-test
-[ t ] [ [ 12 12 fixnum<= ] compile-1 ] unit-test
-
-[ t ] [ 12 70 [ fixnum<= ] compile-1 ] unit-test
-[ t ] [ 12 [ 70 fixnum<= ] compile-1 ] unit-test
-[ t ] [ [ 12 70 fixnum<= ] compile-1 ] unit-test
-
-[ t ] [ 12 7 [ fixnum> ] compile-1 ] unit-test
-[ t ] [ 12 [ 7 fixnum> ] compile-1 ] unit-test
-[ t ] [ [ 12 7 fixnum> ] compile-1 ] unit-test
-[ f ] [ [ 12 12 fixnum> ] compile-1 ] unit-test
-
-[ f ] [ 12 70 [ fixnum> ] compile-1 ] unit-test
-[ f ] [ 12 [ 70 fixnum> ] compile-1 ] unit-test
-[ f ] [ [ 12 70 fixnum> ] compile-1 ] unit-test
-
-[ t ] [ 12 7 [ fixnum>= ] compile-1 ] unit-test
-[ t ] [ 12 [ 7 fixnum>= ] compile-1 ] unit-test
-[ t ] [ [ 12 7 fixnum>= ] compile-1 ] unit-test
-[ t ] [ [ 12 12 fixnum>= ] compile-1 ] unit-test
-
-[ f ] [ 12 70 [ fixnum>= ] compile-1 ] unit-test
-[ f ] [ 12 [ 70 fixnum>= ] compile-1 ] unit-test
-[ f ] [ [ 12 70 fixnum>= ] compile-1 ] unit-test
-
-[ f ] [ 1 2 [ eq? ] compile-1 ] unit-test
-[ f ] [ 1 [ 2 eq? ] compile-1 ] unit-test
-[ f ] [ [ 1 2 eq? ] compile-1 ] unit-test
-[ t ] [ 3 3 [ eq? ] compile-1 ] unit-test
-[ t ] [ 3 [ 3 eq? ] compile-1 ] unit-test
-[ t ] [ [ 3 3 eq? ] compile-1 ] unit-test
+[ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+
+[ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+
+[ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+
+[ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+
+[ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+
+[ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+
+[ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+
+[ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+
+[ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-1 ] unit-test
[ -1 ] [ 0 [ fixnum-bitnot ] compile-1 ] unit-test
[ -1 ] [ [ 0 fixnum-bitnot ] compile-1 ] unit-test
+++ /dev/null
-IN: temporary
-USE: test
-USE: kernel
-USE: compiler
-USE: inference
-USE: words
-USE: sequences
-
-: fie [ ] [ ] if ;
-
-[ ] [ \ fie dup word-def dataflow linearize drop ] unit-test
-
-: foo all-words [ drop ] each ;
-
-[ ] [ \ foo dup word-def dataflow linearize drop ] unit-test
: foo dup [ dup [ ] [ ] if drop ] [ drop ] if ; compiled
[ 10 ] [ 10 2 foo ] unit-test
+
+: foox dup [ foox ] when ; inline
+: bar foox ;
+
+[ ] [ \ bar compile ] unit-test
"compiler/simple" "compiler/templates"
"compiler/stack" "compiler/ifte"
"compiler/generic" "compiler/bail-out"
- "compiler/linearizer" "compiler/intrinsics"
+ "compiler/intrinsics"
"compiler/identities" "compiler/optimizer"
"compiler/alien" "compiler/callbacks"
} run-tests ;
projects / factor.git / commitdiff