Removing linear IR
slava
parent
acb7a68b24
commit
17d6efb543
|
|
@ -9,8 +9,6 @@ should fix in 0.82:
|
|||
- 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
|
||||
|
|
|
|||
|
|
@ -32,35 +32,34 @@ M: alien-callback-error summary ( error -- )
|
|||
] "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 ;
|
||||
|
|
|
|||
|
|
@ -39,35 +39,35 @@ M: alien-invoke-error summary ( error -- )
|
|||
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*
|
||||
|
|
|
|||
|
|
@ -36,22 +36,22 @@ kernel-internals math namespaces sequences words ;
|
|||
[ 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 )
|
||||
|
|
|
|||
|
|
@ -126,12 +126,8 @@ vectors words ;
|
|||
"/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"
|
||||
|
||||
|
|
@ -297,11 +293,11 @@ vectors words ;
|
|||
{
|
||||
"/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"
|
||||
}
|
||||
]
|
||||
} {
|
||||
|
|
|
|||
|
|
@ -23,12 +23,7 @@ H{ } clone help-graph set-global xref-articles
|
|||
|
||||
"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
|
||||
|
|
|
|||
|
|
@ -10,10 +10,6 @@ kernel-internals math namespaces sequences ;
|
|||
! 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
|
||||
|
|
|
|||
|
|
@ -1,10 +1,110 @@
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -5,23 +5,21 @@ USING: errors hashtables inference io kernel lists math
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -1,18 +1,39 @@
|
|||
! 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> - ;
|
||||
|
||||
|
|
@ -21,46 +42,175 @@ GENERIC: generate-node ( vop -- )
|
|||
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
|
||||
|
||||
M: %label generate-node ( vop -- )
|
||||
vop-label save-xt ;
|
||||
: generate-loop ( -- )
|
||||
generate-queue get dup queue-empty? [
|
||||
drop
|
||||
] [
|
||||
deque first3 generate-1 generate-loop
|
||||
] if ;
|
||||
|
||||
M: %target-label generate-node ( vop -- )
|
||||
drop label 0 assemble-cell absolute-cell ;
|
||||
: generate-block ( word node quot -- | quot: node -- )
|
||||
3array generate-queue get enque ;
|
||||
|
||||
M: %cleanup generate-node ( vop -- ) drop ;
|
||||
GENERIC: generate-node ( node -- )
|
||||
|
||||
M: %freg>stack generate-node ( vop -- ) drop ;
|
||||
: generate-nodes ( node -- )
|
||||
[ node@ generate-node ] iterate-nodes end-basic-block ;
|
||||
|
||||
M: %stack>freg generate-node ( vop -- ) drop ;
|
||||
: generate-word ( node -- )
|
||||
[ [ generate-nodes ] with-node-iterator ]
|
||||
generate-block ;
|
||||
|
||||
M: %alien-invoke generate-node
|
||||
#! call a C function.
|
||||
drop 0 input 1 input compile-c-call ;
|
||||
: generate ( word node -- )
|
||||
[
|
||||
<queue> generate-queue set
|
||||
generate-word generate-loop
|
||||
] with-scope ;
|
||||
|
||||
: dest/src ( -- dest src ) 0 output-operand 0 input-operand ;
|
||||
! 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 ;
|
||||
|
||||
: 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 generate-node ( #shuffle -- )
|
||||
node-shuffle phantom-shuffle iterate-next ;
|
||||
|
||||
! #return
|
||||
M: #return generate-node drop end-basic-block %return f ;
|
||||
|
||||
! These constants must match native/card.h
|
||||
: card-bits 7 ;
|
||||
|
|
|
|||
|
|
@ -1,134 +0,0 @@
|
|||
! 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 ;
|
||||
|
|
@ -1,89 +0,0 @@
|
|||
! 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 ;
|
||||
|
|
@ -1,15 +1,13 @@
|
|||
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 ;
|
||||
|
|
@ -21,3 +19,158 @@ M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ;
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -1,133 +0,0 @@
|
|||
! 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 ;
|
||||
|
|
@ -1,108 +0,0 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,225 @@
|
|||
! 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 ;
|
||||
|
|
@ -1,64 +0,0 @@
|
|||
! 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 ;
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
! 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 ;
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
! 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 ;
|
||||
|
|
@ -34,7 +34,7 @@ GENERIC: <loc> ( n stack -- loc )
|
|||
#! 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
|
||||
|
||||
|
|
@ -89,7 +89,7 @@ SYMBOL: phantom-r
|
|||
: 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 ;
|
||||
|
|
@ -98,7 +98,7 @@ SYMBOL: phantom-r
|
|||
over loc? [
|
||||
2drop
|
||||
] [
|
||||
over [ %replace , ] [ 2drop ] if
|
||||
over [ %replace ] [ 2drop ] if
|
||||
] if ;
|
||||
|
||||
: vregs>stack ( phantom -- )
|
||||
|
|
@ -257,3 +257,5 @@ SYMBOL: +clobber
|
|||
: with-template ( quot spec -- )
|
||||
fix-spec [ template-inputs call template-outputs ] bind
|
||||
compute-free-vregs ; inline
|
||||
|
||||
: operand ( var -- op ) get v>operand ; inline
|
||||
|
|
|
|||
|
|
@ -1,340 +0,0 @@
|
|||
! 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> ;
|
||||
|
|
@ -7,10 +7,6 @@ sequences words ;
|
|||
! 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
|
||||
|
|
|
|||
|
|
@ -5,6 +5,13 @@ USING: assembler errors generic hashtables kernel
|
|||
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
|
||||
|
|
@ -170,7 +177,6 @@ SYMBOL: compile-words
|
|||
#! 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -96,6 +96,7 @@ DEFER: countdown-b
|
|||
[ 3 ] [ f dummy-unless-3 ] unit-test
|
||||
[ 4 ] [ 4 dummy-unless-3 ] unit-test
|
||||
|
||||
! Test cond expansion
|
||||
[ "even" ] [
|
||||
[
|
||||
2 {
|
||||
|
|
|
|||
|
|
@ -64,48 +64,54 @@ math-internals sequences strings test words ;
|
|||
[ 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
|
||||
[ 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< ] compile-1 ] unit-test
|
||||
[ t ] [ 12 [ 70 fixnum< ] compile-1 ] unit-test
|
||||
[ t ] [ [ 12 70 fixnum< ] 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<= ] 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
|
||||
[ 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<= ] compile-1 ] unit-test
|
||||
[ t ] [ 12 [ 70 fixnum<= ] compile-1 ] unit-test
|
||||
[ t ] [ [ 12 70 fixnum<= ] 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> ] 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
|
||||
[ 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> ] compile-1 ] unit-test
|
||||
[ f ] [ 12 [ 70 fixnum> ] compile-1 ] unit-test
|
||||
[ f ] [ [ 12 70 fixnum> ] 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>= ] 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
|
||||
[ 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>= ] compile-1 ] unit-test
|
||||
[ f ] [ 12 [ 70 fixnum>= ] compile-1 ] unit-test
|
||||
[ f ] [ [ 12 70 fixnum>= ] 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? ] 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 ] [ 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
|
||||
|
|
|
|||
|
|
@ -1,15 +0,0 @@
|
|||
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
|
||||
|
|
@ -42,3 +42,8 @@ full-gc
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -104,7 +104,7 @@ SYMBOL: failures
|
|||
"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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue