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

Checking in new codegen

db4
Slava Pestov 2008-09-10 22:11:03 -05:00
parent 63a1e604ae
commit 83aa1ccb68
54 changed files with 2145 additions and 258 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
unfinished/compiler/alien/alien.factor Normal file
View File

@ -0,0 +1,46 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces make math sequences layouts
alien.c-types alien.structs compiler.backend ;
IN: compiler.alien
! Common utilities
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
swap return>> large-struct? [ "void*" prefix ] when ;
: alien-return ( params -- ctype )
return>> dup large-struct? [ drop "void" ] when ;
: c-type-stack-align ( type -- align )
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
: parameter-align ( n type -- n delta )
over >r c-type-stack-align align dup r> - ;
: parameter-sizes ( types -- total offsets )
#! Compute stack frame locations.
[
0 [
[ parameter-align drop dup , ] keep stack-size +
] reduce cell align
] { } make ;
: return-size ( ctype -- n )
#! Amount of space we reserve for a return value.
dup large-struct? [ heap-size ] [ drop 0 ] if ;
: alien-stack-frame ( params -- n )
alien-parameters parameter-sizes drop ;
: alien-invoke-frame ( params -- n )
#! One cell is temporary storage, temp@
dup return>> return-size
swap alien-stack-frame +
cell + ;

281
unfinished/compiler/backend/alien/alien.factor Normal file
View File

@ -0,0 +1,281 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.backend.alien
! #alien-invoke
: set-stack-frame ( n -- )
dup [ frame-required ] when* \ stack-frame set ;
: with-stack-frame ( n quot -- )
swap set-stack-frame
call
f set-stack-frame ; inline
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
GENERIC: reg-class-variable ( register-class -- symbol )
M: reg-class reg-class-variable ;
M: float-regs reg-class-variable drop float-regs ;
GENERIC: inc-reg-class ( register-class -- )
M: reg-class inc-reg-class
dup reg-class-variable inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
M: float-regs inc-reg-class
dup call-next-method
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
GENERIC: reg-class-full? ( class -- ? )
M: stack-params reg-class-full? drop t ;
M: object reg-class-full?
[ reg-class-variable get ] [ param-regs length ] bi >= ;
: spill-param ( reg-class -- n reg-class )
stack-params get
>r reg-size stack-params +@ r>
stack-params ;
: fastcall-param ( reg-class -- n reg-class )
[ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
: alloc-parameter ( parameter -- reg reg-class )
c-type-reg-class dup reg-class-full?
[ spill-param ] [ fastcall-param ] if
[ param-reg ] keep ;
: (flatten-int-type) ( size -- )
cell /i "void*" c-type <repetition> % ;
GENERIC: flatten-value-type ( type -- )
M: object flatten-value-type , ;
M: struct-type flatten-value-type ( type -- )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- )
stack-size cell align (flatten-int-type) ;
: flatten-value-types ( params -- params )
#! Convert value type structs to consecutive void*s.
[
0 [
c-type
[ parameter-align (flatten-int-type) ] keep
[ stack-size cell align + ] keep
flatten-value-type
] reduce drop
] { } make ;
: each-parameter ( parameters quot -- )
>r [ parameter-sizes nip ] keep r> 2each ; inline
: reverse-each-parameter ( parameters quot -- )
>r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
: reset-freg-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
: with-param-regs ( quot -- )
#! In quot you can call alloc-parameter
[ reset-freg-counts call ] with-scope ; inline
: move-parameters ( node word -- )
#! Moves values from C stack to registers (if word is
#! %load-param-reg) and registers to C stack (if word is
#! %save-param-reg).
>r
alien-parameters
flatten-value-types
r> [ >r alloc-parameter r> execute ] curry each-parameter ;
inline
: unbox-parameters ( offset node -- )
parameters>> [
%prepare-unbox >r over + r> unbox-parameter
] reverse-each-parameter drop ;
: prepare-box-struct ( node -- offset )
#! Return offset on C stack where to store unboxed
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
return>> dup large-struct?
[ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
: objects>registers ( params -- )
#! Generate code for unboxing a list of C types, then
#! generate code for moving these parameters to register on
#! architectures where parameters are passed in registers.
[
[ prepare-box-struct ] keep
[ unbox-parameters ] keep
\ %load-param-reg move-parameters
] with-param-regs ;
: box-return* ( node -- )
return>> [ ] [ box-return ] if-void ;
TUPLE: no-such-library name ;
M: no-such-library summary
drop "Library not found" ;
M: no-such-library compiler-error-type
drop +linkage+ ;
: no-such-library ( name -- )
\ no-such-library boa
compiling-word get compiler-error ;
TUPLE: no-such-symbol name ;
M: no-such-symbol summary
drop "Symbol not found" ;
M: no-such-symbol compiler-error-type
drop +linkage+ ;
: no-such-symbol ( name -- )
\ no-such-symbol boa
compiling-word get compiler-error ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd [ dlsym ] curry contains?
[ drop ] [ no-such-symbol ] if
] [
dll-path no-such-library drop
] if ;
: stdcall-mangle ( symbol node -- symbol )
"@"
swap parameters>> parameter-sizes drop
number>string 3append ;
: alien-invoke-dlsym ( params -- symbols dll )
dup function>> dup pick stdcall-mangle 2array
swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
M: #alien-invoke generate-node
params>>
dup alien-invoke-frame [
end-basic-block
%prepare-alien-invoke
dup objects>registers
%prepare-var-args
dup alien-invoke-dlsym %alien-invoke
dup %cleanup
box-return*
iterate-next
] with-stack-frame ;
! #alien-indirect
M: #alien-indirect generate-node
params>>
dup alien-invoke-frame [
! Flush registers
end-basic-block
! Save registers for GC
%prepare-alien-invoke
! Save alien at top of stack to temporary storage
%prepare-alien-indirect
dup objects>registers
%prepare-var-args
! Call alien in temporary storage
%alien-indirect
dup %cleanup
box-return*
iterate-next
] with-stack-frame ;
! #alien-callback
: box-parameters ( params -- )
alien-parameters [ box-parameter ] each-parameter ;
: registers>objects ( node -- )
[
dup \ %save-param-reg move-parameters
"nest_stacks" f %alien-invoke
box-parameters
] with-param-regs ;
TUPLE: callback-context ;
: current-callback 2 getenv ;
: wait-to-return ( token -- )
dup current-callback eq? [
drop
] [
yield wait-to-return
] if ;
: do-callback ( quot token -- )
init-catchstack
dup 2 setenv
slip
wait-to-return ; inline
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
[ c-type c-type-unboxer-quot ]
} cond ;
: callback-prep-quot ( params -- quot )
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
: wrap-callback-quot ( params -- quot )
[
[ callback-prep-quot ]
[ quot>> ]
[ callback-return-quot ] tri 3append ,
[ callback-context new do-callback ] %
] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
: callback-unwind ( params -- n )
{
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
: %callback-return ( params -- )
#! All the extra book-keeping for %unwind is only for x86.
#! On other platforms its an alias for %return.
dup alien-return
[ %unnest-stacks ] [ %callback-value ] if-void
callback-unwind %unwind ;
: generate-callback ( params -- )
dup xt>> dup [
init-templates
%prologue
dup alien-stack-frame [
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
tri
] with-stack-frame
] with-cfg-builder ;
M: #alien-callback generate-node
end-basic-block
params>> generate-callback iterate-next ;

10
unfinished/compiler/backend/backend.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system ;
IN: compiler.backend
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( size -- ? )
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )

10
unfinished/compiler/backend/x86/32/32.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system cpu.x86.assembler compiler.registers compiler.backend ;
IN: compiler.backend.x86.32
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
{ float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;

0
unfinished/compiler/cfg/alias/alias.factor → unfinished/compiler/cfg.bluesky/alias/alias.factor
View File

0
unfinished/compiler/cfg/authors.txt → unfinished/compiler/cfg.bluesky/authors.txt
View File

4
unfinished/compiler/cfg.bluesky/builder/builder-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: compiler.cfg.builder.tests
USING: compiler.cfg.builder tools.test ;
\ build-cfg must-infer

256
unfinished/compiler/cfg.bluesky/builder/builder.factor Normal file
View File

@ -0,0 +1,256 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel assocs sequences sequences.lib fry accessors
namespaces math combinators math.order
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
compiler.cfg
compiler.vops
compiler.vops.builder ;
IN: compiler.cfg.builder
! Convert tree SSA IR to CFG SSA IR.
! We construct the graph and set successors first, then we
! set predecessors in a separate pass. This simplifies the
! logic.
SYMBOL: procedures
SYMBOL: loop-nesting
SYMBOL: values>vregs
GENERIC: convert ( node -- )
M: #introduce convert drop ;
: init-builder ( -- )
H{ } clone values>vregs set ;
: end-basic-block ( -- )
basic-block get [ %b emit ] when ;
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;
: begin-basic-block ( -- )
<basic-block> basic-block get
[
end-basic-block
dupd successors>> push
] when*
set-basic-block ;
: convert-nodes ( node -- )
[ convert ] each ;
: (build-cfg) ( node word -- )
init-builder
begin-basic-block
basic-block get swap procedures get set-at
convert-nodes ;
: build-cfg ( node word -- procedures )
H{ } clone [
procedures [ (build-cfg) ] with-variable
] keep ;
: value>vreg ( value -- vreg )
values>vregs get at ;
: output-vreg ( value vreg -- )
swap values>vregs get set-at ;
: produce-vreg ( value -- vreg )
next-vreg [ output-vreg ] keep ;
: (load-inputs) ( seq stack -- )
over empty? [ 2drop ] [
[ <reversed> ] dip
[ '[ produce-vreg _ , %peek emit ] each-index ]
[ [ length neg ] dip %height emit ]
2bi
] if ;
: load-in-d ( node -- ) in-d>> %data (load-inputs) ;
: load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
: (store-outputs) ( seq stack -- )
over empty? [ 2drop ] [
[ <reversed> ] dip
[ [ length ] dip %height emit ]
[ '[ value>vreg _ , %replace emit ] each-index ]
2bi
] if ;
: store-out-d ( node -- ) out-d>> %data (store-outputs) ;
: store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
: (emit-call) ( word -- )
begin-basic-block %call emit begin-basic-block ;
: intrinsic-inputs ( node -- )
[ load-in-d ]
[ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
bi ;
: intrinsic-outputs ( node -- )
[ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
[ store-out-d ]
bi ;
: intrinsic ( node quot -- )
[
init-intrinsic
[ intrinsic-inputs ]
swap
[ intrinsic-outputs ]
tri
] with-scope ; inline
USING: kernel.private math.private slots.private ;
: maybe-emit-fixnum-shift-fast ( node -- node )
dup dup in-d>> second node-value-info literal>> dup fixnum? [
'[ , emit-fixnum-shift-fast ] intrinsic
] [
drop dup word>> (emit-call)
] if ;
: emit-call ( node -- )
dup word>> {
{ \ tag [ [ emit-tag ] intrinsic ] }
{ \ slot [ [ dup emit-slot ] intrinsic ] }
{ \ set-slot [ [ dup emit-set-slot ] intrinsic ] }
{ \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] }
{ \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] }
{ \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] }
{ \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] }
{ \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] }
{ \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] }
{ \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] }
{ \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] }
{ \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] }
{ \ fixnum< [ [ emit-fixnum< ] intrinsic ] }
{ \ fixnum> [ [ emit-fixnum> ] intrinsic ] }
{ \ eq? [ [ emit-eq? ] intrinsic ] }
{ \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] }
{ \ float+ [ [ emit-float+ ] intrinsic ] }
{ \ float- [ [ emit-float- ] intrinsic ] }
{ \ float* [ [ emit-float* ] intrinsic ] }
{ \ float/f [ [ emit-float/f ] intrinsic ] }
{ \ float<= [ [ emit-float<= ] intrinsic ] }
{ \ float>= [ [ emit-float>= ] intrinsic ] }
{ \ float< [ [ emit-float< ] intrinsic ] }
{ \ float> [ [ emit-float> ] intrinsic ] }
{ \ float? [ [ emit-float= ] intrinsic ] }
! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
[ (emit-call) ]
} case drop ;
M: #call convert emit-call ;
: emit-call-loop ( #recursive -- )
dup label>> loop-nesting get at basic-block get successors>> push
end-basic-block
basic-block off
drop ;
: emit-call-recursive ( #recursive -- )
label>> id>> (emit-call) ;
M: #call-recursive convert
dup label>> loop?>>
[ emit-call-loop ] [ emit-call-recursive ] if ;
M: #push convert
[
[ out-d>> first produce-vreg ]
[ node-output-infos first literal>> ]
bi emit-literal
]
[ store-out-d ] bi ;
M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
M: #terminate convert drop ;
: integer-conditional ( in1 in2 cc -- )
[ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
: float-conditional ( in1 in2 branch -- )
[ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
: emit-if ( #if -- )
in-d>> first value>vreg
next-vreg dup f emit-literal
cc/= integer-conditional ;
: convert-nested ( node -- last-bb )
[
<basic-block>
[ set-basic-block ] keep
[ convert-nodes end-basic-block ] dip
basic-block get
] with-scope
[ basic-block get successors>> push ] dip ;
: convert-if-children ( #if -- )
children>> [ convert-nested ] map sift
<basic-block>
[ '[ , _ successors>> push ] each ]
[ set-basic-block ]
bi ;
M: #if convert
[ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
M: #dispatch convert
"Unimplemented" throw ;
M: #phi convert drop ;
M: #declare convert drop ;
M: #return convert drop %return emit ;
: convert-recursive ( #recursive -- )
[ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
[ (emit-call) ]
bi ;
: begin-loop ( #recursive -- )
label>> basic-block get 2array loop-nesting get push ;
: end-loop ( -- )
loop-nesting get pop* ;
: convert-loop ( #recursive -- )
begin-basic-block
[ begin-loop ]
[ child>> convert-nodes ]
[ drop end-loop ]
tri ;
M: #recursive convert
dup label>> loop?>>
[ convert-loop ] [ convert-recursive ] if ;
M: #copy convert drop ;

47
unfinished/compiler/cfg.bluesky/cfg.factor Normal file
View File

@ -0,0 +1,47 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sequences sets fry ;
IN: compiler.cfg
! The id is a globally unique id used for fast hashcode* and
! equal? on basic blocks. The number is assigned by
! linearization.
TUPLE: basic-block < identity-tuple
id
number
instructions
successors
predecessors
stack-frame ;
SYMBOL: next-block-id
: <basic-block> ( -- basic-block )
basic-block new
next-block-id counter >>id
V{ } clone >>instructions
V{ } clone >>successors
V{ } clone >>predecessors ;
M: basic-block hashcode* id>> nip ;
! Utilities
SYMBOL: visited-blocks
: visit-block ( basic-block quot -- )
over visited-blocks get 2dup key?
[ 2drop 2drop ] [ conjoin call ] if ; inline
: (each-block) ( basic-block quot -- )
'[
,
[ call ]
[ [ successors>> ] dip '[ , (each-block) ] each ]
2bi
] visit-block ; inline
: each-block ( basic-block quot -- )
H{ } clone visited-blocks [ (each-block) ] with-variable ; inline
: copy-at ( from to assoc -- )
3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline

0
unfinished/compiler/cfg/elaboration/elaboration.factor → unfinished/compiler/cfg.bluesky/elaboration/elaboration.factor
View File

0
unfinished/compiler/cfg/kill-nops/kill-nops.factor → unfinished/compiler/cfg.bluesky/kill-nops/kill-nops.factor
View File

0
unfinished/compiler/cfg/live-ranges/live-ranges.factor → unfinished/compiler/cfg.bluesky/live-ranges/live-ranges.factor
View File

0
unfinished/compiler/cfg/predecessors/predecessors.factor → unfinished/compiler/cfg.bluesky/predecessors/predecessors.factor
View File

0
unfinished/compiler/cfg/simplifier/simplifier.factor → unfinished/compiler/cfg.bluesky/simplifier/simplifier.factor
View File

0
unfinished/compiler/cfg/stack/stack.factor → unfinished/compiler/cfg.bluesky/stack/stack.factor
View File

0
unfinished/compiler/cfg/summary.txt → unfinished/compiler/cfg.bluesky/summary.txt
View File

0
unfinished/compiler/cfg/vn/conditions/conditions.factor → unfinished/compiler/cfg.bluesky/vn/conditions/conditions.factor
View File

0
unfinished/compiler/cfg/vn/constant-fold/constant-fold.factor → unfinished/compiler/cfg.bluesky/vn/constant-fold/constant-fold.factor
View File

0
unfinished/compiler/cfg/vn/expressions/expressions.factor → unfinished/compiler/cfg.bluesky/vn/expressions/expressions.factor
View File

0
unfinished/compiler/cfg/vn/graph/graph.factor → unfinished/compiler/cfg.bluesky/vn/graph/graph.factor
View File

0
unfinished/compiler/cfg/vn/liveness/liveness.factor → unfinished/compiler/cfg.bluesky/vn/liveness/liveness.factor
View File

0
unfinished/compiler/cfg/vn/propagate/propagate.factor → unfinished/compiler/cfg.bluesky/vn/propagate/propagate.factor
View File

0
unfinished/compiler/cfg/vn/simplify/simplify.factor → unfinished/compiler/cfg.bluesky/vn/simplify/simplify.factor
View File

0
unfinished/compiler/cfg/vn/vn.factor → unfinished/compiler/cfg.bluesky/vn/vn.factor
View File

0
unfinished/compiler/cfg/write-barrier/write-barrier.factor → unfinished/compiler/cfg.bluesky/write-barrier/write-barrier.factor
View File

1
unfinished/compiler/cfg/builder/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

45
unfinished/compiler/cfg/builder/builder-tests.factor
View File

@ -1,4 +1,45 @@
IN: compiler.cfg.builder.tests
USING: compiler.cfg.builder tools.test ;
USING: compiler.cfg.builder tools.test kernel sequences
math.private compiler.tree.builder compiler.tree.optimizer
words sequences.private fry prettyprint alien ;
\ build-cfg must-infer
! Just ensure that various CFGs build correctly.
: test-cfg ( quot -- result )
build-tree optimize-tree gensym gensym build-cfg ;
{
[ ]
[ dup ]
[ swap ]
[ >r r> ]
[ fixnum+ ]
[ fixnum< ]
[ [ 1 ] [ 2 ] if ]
[ fixnum< [ 1 ] [ 2 ] if ]
[ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
[ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
[ [ t ] loop ]
[ [ dup ] loop ]
[ [ 2 ] [ 3 throw ] if 4 ]
[ "int" f "malloc" { "int" } alien-invoke ]
[ "int" { "int" } "cdecl" alien-indirect ]
[ "int" { "int" } "cdecl" [ ] alien-callback ]
} [
'[ _ test-cfg drop ] [ ] swap unit-test
] each
: test-word-cfg ( word -- result )
[ build-tree-from-word nip optimize-tree ] keep dup
build-cfg ;
: test-1 ( -- ) test-1 ;
: test-2 ( -- ) 3 . test-2 ;
: test-3 ( a -- b ) dup [ test-3 ] when ;
{
test-1
test-2
test-3
} [
'[ _ test-word-cfg drop ] [ ] swap unit-test
] each

495
unfinished/compiler/cfg/builder/builder.factor Normal file → Executable file
View File

@ -1,256 +1,295 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel assocs sequences sequences.lib fry accessors
namespaces math combinators math.order
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words stack-checker.inlining
compiler.tree
compiler.tree.builder
compiler.tree.combinators
compiler.tree.propagation.info
compiler.cfg
compiler.vops
compiler.vops.builder ;
compiler.cfg.stacks
compiler.cfg.templates
compiler.cfg.iterator
compiler.alien
compiler.instructions
compiler.registers ;
IN: compiler.cfg.builder
! Convert tree SSA IR to CFG SSA IR.
! We construct the graph and set successors first, then we
! set predecessors in a separate pass. This simplifies the
! logic.
SYMBOL: procedures
SYMBOL: loop-nesting
SYMBOL: values>vregs
GENERIC: convert ( node -- )
M: #introduce convert drop ;
: init-builder ( -- )
H{ } clone values>vregs set ;
: end-basic-block ( -- )
basic-block get [ %b emit ] when ;
! Convert tree SSA IR to CFG (not quite SSA yet) IR.
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;
: begin-basic-block ( -- )
<basic-block> basic-block get
[
end-basic-block
<basic-block> basic-block get [
dupd successors>> push
] when*
set-basic-block ;
: convert-nodes ( node -- )
[ convert ] each ;
: end-basic-block ( -- )
building off
basic-block off ;
: (build-cfg) ( node word -- )
init-builder
USE: qualified
FROM: compiler.generator.registers => +input+ ;
FROM: compiler.generator.registers => +output+ ;
FROM: compiler.generator.registers => +scratch+ ;
FROM: compiler.generator.registers => +clobber+ ;
SYMBOL: procedures
SYMBOL: current-word
SYMBOL: current-label
SYMBOL: loops
! Basic block after prologue, makes recursion faster
SYMBOL: current-label-start
: add-procedure ( -- )
basic-block get current-word get current-label get
<procedure> procedures get push ;
: begin-procedure ( word label -- )
end-basic-block
begin-basic-block
basic-block get swap procedures get set-at
convert-nodes ;
H{ } clone loops set
current-label set
current-word set
add-procedure ;
: build-cfg ( node word -- procedures )
H{ } clone [
procedures [ (build-cfg) ] with-variable
: with-cfg-builder ( nodes word label quot -- )
'[ begin-procedure @ ] with-scope ; inline
GENERIC: emit-node ( node -- next )
: check-basic-block ( node -- node' )
basic-block get [ drop f ] unless ; inline
: emit-nodes ( nodes -- )
[ current-node emit-node check-basic-block ] iterate-nodes
finalize-phantoms ;
: remember-loop ( label -- )
basic-block get swap loops get set-at ;
: begin-word ( -- )
#! We store the basic block after the prologue as a loop
#! labelled by the current word, so that self-recursive
#! calls can skip an epilogue/prologue.
init-phantoms
%prologue
%branch
begin-basic-block
current-label get remember-loop ;
: (build-cfg) ( nodes word label -- )
[
begin-word
[ emit-nodes ] with-node-iterator
] with-cfg-builder ;
: build-cfg ( nodes word label -- procedures )
V{ } clone [
procedures [
(build-cfg)
] with-variable
] keep ;
: value>vreg ( value -- vreg )
values>vregs get at ;
: if-intrinsics ( #call -- quot )
word>> "if-intrinsics" word-prop ;
: output-vreg ( value vreg -- )
swap values>vregs get set-at ;
: local-recursive-call ( basic-block -- )
%branch
basic-block get successors>> push
end-basic-block ;
: produce-vreg ( value -- vreg )
next-vreg [ output-vreg ] keep ;
: emit-call ( word -- next )
finalize-phantoms
{
{ [ tail-call? not ] [ 0 %frame-required %call iterate-next ] }
{ [ dup loops get key? ] [ loops get at local-recursive-call f ] }
[ %epilogue %jump f ]
} cond ;
: (load-inputs) ( seq stack -- )
over empty? [ 2drop ] [
[ <reversed> ] dip
[ '[ produce-vreg _ , %peek emit ] each-index ]
[ [ length neg ] dip %height emit ]
2bi
] if ;
! #recursive
: compile-recursive ( node -- next )
[ label>> id>> emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: load-in-d ( node -- ) in-d>> %data (load-inputs) ;
: load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
: (store-outputs) ( seq stack -- )
over empty? [ 2drop ] [
[ <reversed> ] dip
[ [ length ] dip %height emit ]
[ '[ value>vreg _ , %replace emit ] each-index ]
2bi
] if ;
: store-out-d ( node -- ) out-d>> %data (store-outputs) ;
: store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
: (emit-call) ( word -- )
begin-basic-block %call emit begin-basic-block ;
: intrinsic-inputs ( node -- )
[ load-in-d ]
[ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
bi ;
: intrinsic-outputs ( node -- )
[ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
[ store-out-d ]
bi ;
: intrinsic ( node quot -- )
[
init-intrinsic
[ intrinsic-inputs ]
swap
[ intrinsic-outputs ]
tri
] with-scope ; inline
USING: kernel.private math.private slots.private ;
: maybe-emit-fixnum-shift-fast ( node -- node )
dup dup in-d>> second node-value-info literal>> dup fixnum? [
'[ , emit-fixnum-shift-fast ] intrinsic
] [
drop dup word>> (emit-call)
] if ;
: emit-call ( node -- )
dup word>> {
{ \ tag [ [ emit-tag ] intrinsic ] }
{ \ slot [ [ dup emit-slot ] intrinsic ] }
{ \ set-slot [ [ dup emit-set-slot ] intrinsic ] }
{ \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] }
{ \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] }
{ \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] }
{ \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] }
{ \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] }
{ \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] }
{ \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] }
{ \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] }
{ \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] }
{ \ fixnum< [ [ emit-fixnum< ] intrinsic ] }
{ \ fixnum> [ [ emit-fixnum> ] intrinsic ] }
{ \ eq? [ [ emit-eq? ] intrinsic ] }
{ \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] }
{ \ float+ [ [ emit-float+ ] intrinsic ] }
{ \ float- [ [ emit-float- ] intrinsic ] }
{ \ float* [ [ emit-float* ] intrinsic ] }
{ \ float/f [ [ emit-float/f ] intrinsic ] }
{ \ float<= [ [ emit-float<= ] intrinsic ] }
{ \ float>= [ [ emit-float>= ] intrinsic ] }
{ \ float< [ [ emit-float< ] intrinsic ] }
{ \ float> [ [ emit-float> ] intrinsic ] }
{ \ float? [ [ emit-float= ] intrinsic ] }
! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
[ (emit-call) ]
} case drop ;
M: #call convert emit-call ;
: emit-call-loop ( #recursive -- )
dup label>> loop-nesting get at basic-block get successors>> push
end-basic-block
basic-block off
drop ;
: emit-call-recursive ( #recursive -- )
label>> id>> (emit-call) ;
M: #call-recursive convert
dup label>> loop?>>
[ emit-call-loop ] [ emit-call-recursive ] if ;
M: #push convert
[
[ out-d>> first produce-vreg ]
[ node-output-infos first literal>> ]
bi emit-literal
]
[ store-out-d ] bi ;
M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
M: #terminate convert drop ;
: integer-conditional ( in1 in2 cc -- )
[ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
: float-conditional ( in1 in2 branch -- )
[ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
: emit-if ( #if -- )
in-d>> first value>vreg
next-vreg dup f emit-literal
cc/= integer-conditional ;
: convert-nested ( node -- last-bb )
[
<basic-block>
[ set-basic-block ] keep
[ convert-nodes end-basic-block ] dip
basic-block get
] with-scope
[ basic-block get successors>> push ] dip ;
: convert-if-children ( #if -- )
children>> [ convert-nested ] map sift
<basic-block>
[ '[ , _ successors>> push ] each ]
[ set-basic-block ]
bi ;
M: #if convert
[ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
M: #dispatch convert
"Unimplemented" throw ;
M: #phi convert drop ;
M: #declare convert drop ;
M: #return convert drop %return emit ;
: convert-recursive ( #recursive -- )
[ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
[ (emit-call) ]
bi ;
: begin-loop ( #recursive -- )
label>> basic-block get 2array loop-nesting get push ;
: end-loop ( -- )
loop-nesting get pop* ;
: convert-loop ( #recursive -- )
: compile-loop ( node -- next )
finalize-phantoms
begin-basic-block
[ begin-loop ]
[ child>> convert-nodes ]
[ drop end-loop ]
tri ;
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
iterate-next ;
M: #recursive convert
dup label>> loop?>>
[ convert-loop ] [ convert-recursive ] if ;
M: #recursive emit-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
M: #copy convert drop ;
! #if
: emit-branch ( nodes -- final-bb )
[
begin-basic-block copy-phantoms
emit-nodes
basic-block get dup [ %branch ] when
] with-scope ;
: emit-if ( node -- next )
children>> [ emit-branch ] map
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each
init-phantoms
iterate-next ;
M: #if emit-node
{ { f "flag" } } lazy-load first %branch-t
emit-if ;
! #dispatch
: dispatch-branch ( nodes word -- label )
gensym [
[
copy-phantoms
%prologue
[ emit-nodes ] with-node-iterator
%epilogue
%return
] with-cfg-builder
] keep ;
: dispatch-branches ( node -- )
children>> [
current-word get dispatch-branch
%dispatch-label
] each ;
: emit-dispatch ( node -- )
%dispatch dispatch-branches init-phantoms ;
M: #dispatch emit-node
#! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the
#! correct register state
tail-call? [
emit-dispatch iterate-next
] [
current-word get gensym [
[
begin-word
emit-dispatch
] with-cfg-builder
] keep emit-call
] if ;
! #call
: define-intrinsics ( word intrinsics -- )
"intrinsics" set-word-prop ;
: define-intrinsic ( word quot assoc -- )
2array 1array define-intrinsics ;
: define-if-intrinsics ( word intrinsics -- )
[ +input+ associate ] assoc-map
"if-intrinsics" set-word-prop ;
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
: find-intrinsic ( #call -- pair/f )
word>> "intrinsics" word-prop find-template ;
: find-boolean-intrinsic ( #call -- pair/f )
word>> "if-intrinsics" word-prop find-template ;
: find-if-intrinsic ( #call -- pair/f )
node@ {
{ [ dup length 2 < ] [ 2drop f ] }
{ [ dup second #if? ] [ drop find-boolean-intrinsic ] }
[ 2drop f ]
} cond ;
: do-if-intrinsic ( pair -- next )
[ %if-intrinsic ] apply-template skip-next emit-if ;
: do-boolean-intrinsic ( pair -- next )
[
f alloc-vreg [ %boolean-intrinsic ] keep phantom-push
] apply-template iterate-next ;
: do-intrinsic ( pair -- next )
[ %intrinsic ] apply-template iterate-next ;
: setup-operand-classes ( #call -- )
node-input-infos [ class>> ] map set-operand-classes ;
M: #call emit-node
dup setup-operand-classes
dup find-if-intrinsic [ do-if-intrinsic ] [
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
dup find-intrinsic [ do-intrinsic ] [
word>> emit-call
] ?if
] ?if
] ?if ;
! #call-recursive
M: #call-recursive emit-node label>> id>> emit-call ;
! #push
M: #push emit-node
literal>> <constant> phantom-push iterate-next ;
! #shuffle
M: #shuffle emit-node
shuffle-effect phantom-shuffle iterate-next ;
M: #>r emit-node
[ in-d>> length ] [ out-r>> empty? ] bi
[ phantom-drop ] [ phantom->r ] if
iterate-next ;
M: #r> emit-node
[ in-r>> length ] [ out-d>> empty? ] bi
[ phantom-rdrop ] [ phantom-r> ] if
iterate-next ;
! #return
M: #return emit-node
drop finalize-phantoms %epilogue %return f ;
M: #return-recursive emit-node
finalize-phantoms
label>> id>> loops get key?
[ %epilogue %return ] unless f ;
! #terminate
M: #terminate emit-node drop end-basic-block f ;
! FFI
M: #alien-invoke emit-node
params>>
[ alien-invoke-frame %frame-required ]
[ %alien-invoke iterate-next ]
bi ;
M: #alien-indirect emit-node
params>>
[ alien-invoke-frame %frame-required ]
[ %alien-indirect iterate-next ]
bi ;
M: #alien-callback emit-node
params>> dup xt>> dup
[ init-phantoms %alien-callback ] with-cfg-builder
iterate-next ;
! No-op nodes
M: #introduce emit-node drop iterate-next ;
M: #copy emit-node drop iterate-next ;
M: #enter-recursive emit-node drop iterate-next ;
M: #phi emit-node drop iterate-next ;

1
unfinished/compiler/cfg/builder/summary.txt Normal file
View File

@ -0,0 +1 @@
Final stage of compilation generates machine code from dataflow IR

1
unfinished/compiler/cfg/builder/tags.txt Normal file
View File

@ -0,0 +1 @@
compiler

20
unfinished/compiler/cfg/cfg.factor
View File

@ -3,16 +3,19 @@
USING: kernel accessors namespaces assocs sequences sets fry ;
IN: compiler.cfg
! The id is a globally unique id used for fast hashcode* and
! equal? on basic blocks. The number is assigned by
! linearization.
TUPLE: procedure entry word label ;
C: <procedure> procedure
! - "id" is a globally unique id used for hashcode*.
! - "number" is assigned by linearization.
TUPLE: basic-block < identity-tuple
id
number
label
instructions
successors
predecessors
stack-frame ;
predecessors ;
SYMBOL: next-block-id
@ -34,14 +37,11 @@ SYMBOL: visited-blocks
: (each-block) ( basic-block quot -- )
'[
,
_
[ call ]
[ [ successors>> ] dip '[ , (each-block) ] each ]
[ [ successors>> ] dip '[ _ (each-block) ] each ]
2bi
] visit-block ; inline
: each-block ( basic-block quot -- )
H{ } clone visited-blocks [ (each-block) ] with-variable ; inline
: copy-at ( from to assoc -- )
3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline

48
unfinished/compiler/cfg/iterator/iterator.factor Normal file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences kernel compiler.tree ;
IN: compiler.cfg.iterator
SYMBOL: node-stack
: >node ( cursor -- ) node-stack get push ;
: node> ( -- cursor ) node-stack get pop ;
: node@ ( -- cursor ) node-stack get peek ;
: current-node ( -- node ) node@ first ;
: iterate-next ( -- cursor ) node@ rest-slice ;
: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
: iterate-nodes ( cursor quot: ( -- ) -- )
over empty? [
2drop
] [
[ swap >node call node> drop ] keep iterate-nodes
] if ; inline recursive
: with-node-iterator ( quot -- )
>r V{ } clone node-stack r> with-variable ; inline
DEFER: (tail-call?)
: tail-phi? ( cursor -- ? )
[ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
: (tail-call?) ( cursor -- ? )
[ t ] [
[
first
[ #return? ]
[ #return-recursive? ]
[ #terminate? ] tri or or
] [ tail-phi? ] bi or
] if-empty ;
: tail-call? ( -- ? )
node-stack get [
rest-slice
[ t ] [
[ (tail-call?) ]
[ first #terminate? not ]
bi and
] if-empty
] all? ;

1
unfinished/compiler/cfg/stacks/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

389
unfinished/compiler/cfg/stacks/stacks.factor Executable file
View File

@ -0,0 +1,389 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes classes.private classes.algebra
combinators hashtables kernel layouts math fry namespaces
quotations sequences system vectors words effects alien
byte-arrays accessors sets math.order compiler.instructions
compiler.registers ;
IN: compiler.cfg.stacks
! Converting stack operations into register operations, while
! doing a bit of optimization along the way.
USE: qualified
FROM: compiler.generator.registers => +input+ ;
FROM: compiler.generator.registers => +output+ ;
FROM: compiler.generator.registers => +scratch+ ;
FROM: compiler.generator.registers => +clobber+ ;
SYMBOL: known-tag
! Value protocol
GENERIC: set-operand-class ( class obj -- )
GENERIC: operand-class* ( operand -- class )
GENERIC: move-spec ( obj -- spec )
GENERIC: live-loc? ( actual current -- ? )
GENERIC# (lazy-load) 1 ( value spec -- value )
GENERIC# (eager-load) 1 ( value spec -- value )
GENERIC: lazy-store ( dst src -- )
GENERIC: minimal-ds-loc* ( min obj -- min )
! This will be a multimethod soon
DEFER: %move
PRIVATE>
: operand-class ( operand -- class )
operand-class* object or ;
! Default implementation
M: value set-operand-class 2drop ;
M: value operand-class* drop f ;
M: value live-loc? 2drop f ;
M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
M: vreg move-spec reg-class>> move-spec ;
M: int-regs move-spec drop f ;
M: int-regs operand-class* drop object ;
M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ;
M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc?
over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
M: rs-loc live-loc?
over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
M: loc operand-class* class>> ;
M: loc set-operand-class (>>class) ;
M: loc move-spec drop loc ;
M: f move-spec drop loc ;
M: f operand-class* ;
M: cached set-operand-class vreg>> set-operand-class ;
M: cached operand-class* vreg>> operand-class* ;
M: cached move-spec drop cached ;
M: cached live-loc? loc>> live-loc? ;
M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
M: cached (eager-load) >r vreg>> r> (eager-load) ;
M: cached lazy-store
2dup loc>> live-loc?
[ "live-locs" get at %move ] [ 2drop ] if ;
M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
M: tagged set-operand-class (>>class) ;
M: tagged operand-class* class>> ;
M: tagged move-spec drop f ;
M: unboxed-alien operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ;
M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ;
M: unboxed-f operand-class* drop \ f ;
M: unboxed-f move-spec class ;
M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ;
M: constant operand-class* value>> class ;
M: constant move-spec class ;
! Moving values between locations and registers
: %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
dup operand-class {
{ [ dup \ f class<= ] [ drop %unbox-f ] }
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
[ drop %unbox-any-c-ptr ]
} cond ; inline
: %move-via-temp ( dst src -- )
#! For many transfers, such as loc to unboxed-alien, we
#! don't have an intrinsic, so we transfer the source to
#! temp then temp to the destination.
int-regs next-vreg [ over %move operand-class ] keep
tagged new
swap >>vreg
swap >>class
%move ;
: %move ( dst src -- )
2dup [ move-spec ] bi@ 2array {
{ { f f } [ %copy ] }
{ { unboxed-alien unboxed-alien } [ %copy ] }
{ { unboxed-byte-array unboxed-byte-array } [ %copy ] }
{ { unboxed-f unboxed-f } [ %copy ] }
{ { unboxed-c-ptr unboxed-c-ptr } [ %copy ] }
{ { float float } [ %copy-float ] }
{ { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] }
{ { f constant } [ value>> swap %load-literal ] }
{ { f float } [ %box-float ] }
{ { f unboxed-alien } [ %box-alien ] }
{ { f loc } [ %peek ] }
{ { float f } [ %unbox-float ] }
{ { unboxed-alien f } [ %unbox-alien ] }
{ { unboxed-byte-array f } [ %unbox-byte-array ] }
{ { unboxed-f f } [ %unbox-f ] }
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
{ { loc f } [ swap %replace ] }
[ drop %move-via-temp ]
} case ;
! A compile-time stack
TUPLE: phantom-stack height stack ;
M: phantom-stack clone
call-next-method [ clone ] change-stack ;
GENERIC: finalize-height ( stack -- )
: new-phantom-stack ( class -- stack )
>r 0 V{ } clone r> boa ; inline
: (loc) ( m stack -- n )
#! Utility for methods on <loc>
height>> - ;
: (finalize-height) ( stack word -- )
#! We consolidate multiple stack height changes until the
#! last moment, and we emit the final height changing
#! instruction here.
'[ dup zero? [ drop ] [ _ execute ] if 0 ] change-height drop ; inline
GENERIC: <loc> ( n stack -- loc )
TUPLE: phantom-datastack < phantom-stack ;
: <phantom-datastack> ( -- stack )
phantom-datastack new-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ;
TUPLE: phantom-retainstack < phantom-stack ;
: <phantom-retainstack> ( -- stack )
phantom-retainstack new-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
M: phantom-retainstack finalize-height
\ %inc-r (finalize-height) ;
: phantom-locs ( n phantom -- locs )
#! A sequence of n ds-locs or rs-locs indexing the stack.
>r <reversed> r> '[ _ <loc> ] map ;
: phantom-locs* ( phantom -- locs )
[ stack>> length ] keep phantom-locs ;
: phantoms ( -- phantom phantom )
phantom-datastack get phantom-retainstack get ;
: (each-loc) ( phantom quot -- )
>r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
: each-loc ( quot -- )
phantoms 2array swap '[ _ (each-loc) ] each ; inline
: adjust-phantom ( n phantom -- )
swap '[ _ + ] change-height drop ;
: cut-phantom ( n phantom -- seq )
swap '[ _ cut* swap ] change-stack drop ;
: phantom-append ( seq stack -- )
over length over adjust-phantom stack>> push-all ;
: add-locs ( n phantom -- )
2dup stack>> length <= [
2drop
] [
[ phantom-locs ] keep
[ stack>> length head-slice* ] keep
[ append >vector ] change-stack drop
] if ;
: phantom-input ( n phantom -- seq )
2dup add-locs
2dup cut-phantom
>r >r neg r> adjust-phantom r> ;
: each-phantom ( quot -- ) phantoms rot bi@ ; inline
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
[ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-filter
values ;
: live-locs ( -- seq )
[ (live-locs) ] each-phantom append prune ;
! Operands holding pointers to freshly-allocated objects which
! are guaranteed to be in the nursery
SYMBOL: fresh-objects
: reg-spec>class ( spec -- class )
float eq? double-float-regs int-regs ? ;
: alloc-vreg ( spec -- reg )
[ reg-spec>class next-vreg ] keep {
{ f [ <tagged> ] }
{ unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] }
{ unboxed-f [ <unboxed-f> ] }
{ unboxed-c-ptr [ <unboxed-c-ptr> ] }
[ drop ]
} case ;
: compatible? ( value spec -- ? )
>r move-spec r> {
{ [ 2dup = ] [ t ] }
{ [ dup unboxed-c-ptr eq? ] [
over { unboxed-byte-array unboxed-alien } member?
] }
[ f ]
} cond 2nip ;
: alloc-vreg-for ( value spec -- vreg )
alloc-vreg swap operand-class
over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
{
{ [ dup quotation? ] [ drop ] }
{ [ 2dup compatible? ] [ drop ] }
[ (eager-load) ]
} cond ;
M: value (eager-load) ( value spec -- vreg )
[ alloc-vreg-for ] [ drop ] 2bi
[ %move ] [ drop ] 2bi ;
M: loc lazy-store
2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
: finalize-locs ( -- )
#! Perform any deferred stack shuffling.
live-locs [ dup f (lazy-load) ] H{ } map>assoc
dup assoc-empty? [ drop ] [
"live-locs" set [ lazy-store ] each-loc
] if ;
: finalize-vregs ( -- )
#! Store any vregs to their final stack locations.
[
dup loc? over cached? or [ 2drop ] [ %move ] if
] each-loc ;
: reset-phantom ( phantom -- )
#! Kill register assignments but preserve constants and
#! class information.
dup phantom-locs*
over stack>> [
dup constant? [ nip ] [
operand-class over set-operand-class
] if
] 2map
over stack>> delete-all
swap stack>> push-all ;
: reset-phantoms ( -- )
[ reset-phantom ] each-phantom ;
: finalize-contents ( -- )
finalize-locs finalize-vregs reset-phantoms ;
! Loading stacks to vregs
: vreg-substitution ( value vreg -- pair )
dupd <cached> 2array ;
: substitute-vreg? ( old new -- ? )
#! We don't substitute locs for float or alien vregs,
#! since in those cases the boxing overhead might kill us.
vreg>> tagged? >r loc? r> and ;
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-filter >hashtable
'[ stack>> _ substitute-here ] each-phantom ;
: clear-phantoms ( -- )
[ stack>> delete-all ] each-phantom ;
: set-operand-classes ( classes -- )
phantom-datastack get
over length over add-locs
stack>> [ set-operand-class ] 2reverse-each ;
: finalize-phantoms ( -- )
#! Commit all deferred stacking shuffling, and ensure the
#! in-memory data and retain stacks are up to date with
#! respect to the compiler's current picture.
finalize-contents
clear-phantoms
finalize-heights
fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
: fresh-object ( obj -- ) fresh-objects get push ;
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
: init-phantoms ( -- )
V{ } clone fresh-objects set
<phantom-datastack> phantom-datastack set
<phantom-retainstack> phantom-retainstack set ;
: copy-phantoms ( -- )
fresh-objects [ clone ] change
phantom-datastack [ clone ] change
phantom-retainstack [ clone ] change ;
: operand-tag ( operand -- tag/f )
operand-class dup [ class-tag ] when ;
UNION: immediate fixnum POSTPONE: f ;
: operand-immediate? ( operand -- ? )
operand-class immediate class<= ;
: phantom-push ( obj -- )
1 phantom-datastack get adjust-phantom
phantom-datastack get stack>> push ;
: phantom-shuffle ( shuffle -- )
[ in>> length phantom-datastack get phantom-input ] keep
shuffle phantom-datastack get phantom-append ;
: phantom->r ( n -- )
phantom-datastack get phantom-input
phantom-retainstack get phantom-append ;
: phantom-r> ( n -- )
phantom-retainstack get phantom-input
phantom-datastack get phantom-append ;
: phantom-drop ( n -- )
phantom-datastack get phantom-input drop ;
: phantom-rdrop ( n -- )
phantom-retainstack get phantom-input drop ;

103
unfinished/compiler/cfg/templates/templates.factor Normal file
View File

@ -0,0 +1,103 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors sequences kernel fry namespaces
quotations combinators classes.algebra compiler.instructions
compiler.registers compiler.cfg.stacks ;
IN: compiler.cfg.templates
USE: qualified
FROM: compiler.generator.registers => +input+ ;
FROM: compiler.generator.registers => +output+ ;
FROM: compiler.generator.registers => +scratch+ ;
FROM: compiler.generator.registers => +clobber+ ;
: template-input +input+ swap at ; inline
: template-output +output+ swap at ; inline
: template-scratch +scratch+ swap at ; inline
: template-clobber +clobber+ swap at ; inline
: phantom&spec ( phantom specs -- phantom' specs' )
>r stack>> r>
[ length f pad-left ] keep
[ <reversed> ] bi@ ; inline
: phantom&spec-agree? ( phantom spec quot -- ? )
>r phantom&spec r> 2all? ; inline
: live-vregs ( -- seq )
[ stack>> [ >vreg ] map sift ] each-phantom append ;
: clobbered ( template -- seq )
[ template-output ] [ template-clobber ] bi append ;
: clobbered? ( value name -- ? )
\ clobbered get member? [
>vreg \ live-vregs get member?
] [ drop f ] if ;
: lazy-load ( specs -- seq )
[ length phantom-datastack get phantom-input ] keep
[ drop ] [
[
2dup second clobbered?
[ first (eager-load) ] [ first (lazy-load) ] if
] 2map
] 2bi
[ substitute-vregs ] keep ;
: load-inputs ( template -- assoc )
[
live-vregs \ live-vregs set
dup clobbered \ clobbered set
template-input [ values ] [ lazy-load ] bi zip
] with-scope ;
: alloc-scratch ( template -- assoc )
template-scratch [ swap alloc-vreg ] assoc-map ;
: do-template-inputs ( template -- inputs )
#! Load input values into registers and allocates scratch
#! registers.
[ load-inputs ] [ alloc-scratch ] bi assoc-union ;
: do-template-outputs ( template inputs -- )
[ template-output ] dip '[ _ at ] map
phantom-datastack get phantom-append ;
: apply-template ( pair quot -- vregs )
[
first2 dup do-template-inputs
[ do-template-outputs ] keep
] dip call ; inline
: value-matches? ( value spec -- ? )
#! If the spec is a quotation and the value is a literal
#! fixnum, see if the quotation yields true when applied
#! to the fixnum. Otherwise, the values don't match. If the
#! spec is not a quotation, its a reg-class, in which case
#! the value is always good.
dup quotation? [
over constant?
[ >r value>> r> 2drop f ] [ 2drop f ] if
] [
2drop t
] if ;
: class-matches? ( actual expected -- ? )
{
{ f [ drop t ] }
{ known-tag [ dup [ class-tag >boolean ] when ] }
[ class<= ]
} case ;
: spec-matches? ( value spec -- ? )
2dup first value-matches?
>r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( template -- ? )
template-input phantom-datastack get swap
[ spec-matches? ] phantom&spec-agree? ;
: find-template ( templates -- pair/f )
#! Pair has shape { quot assoc }
[ second template-matches? ] find nip ;

1
unfinished/compiler/codegen/fixup/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

154
unfinished/compiler/codegen/fixup/fixup.factor Executable file
View File

@ -0,0 +1,154 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private cpu.architecture
math.order accessors growable ;
IN: compiler.cfg.fixup
: no-stack-frame -1 ; inline
TUPLE: frame-required n ;
: frame-required ( n -- ) \ frame-required boa , ;
: stack-frame-size ( code -- n )
no-stack-frame [
dup frame-required? [ n>> max ] [ drop ] if
] reduce ;
GENERIC: fixup* ( frame-size obj -- frame-size )
: code-format 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;
TUPLE: label offset ;
: <label> ( -- label ) label new ;
M: label fixup*
compiled-offset >>offset drop ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
: if-stack-frame ( frame-size quot -- )
swap dup no-stack-frame =
[ 2drop ] [ stack-frame swap call ] if ; inline
M: word fixup*
{
{ \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
{ \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
} case ;
SYMBOL: relocation-table
SYMBOL: label-table
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
: rc-absolute? ( n -- ? )
dup rc-absolute-cell =
over rc-absolute =
rot rc-absolute-ppc-2/2 = or or ;
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
TUPLE: label-fixup label class ;
: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
dup label>> swap class>> compiled-offset 4 - rot
3array label-table get push ;
TUPLE: rel-fixup arg class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
[ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
[ relocation-table get push-4 ] bi@ ;
M: frame-required fixup* drop ;
M: integer fixup* , ;
: adjoin* ( obj table -- n )
2dup swap [ eq? ] curry find drop
[ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;
: rel-dlsym ( name dll class -- )
>r literal-table get length >r
add-dlsym-literals
r> r> rt-dlsym rel-fixup ;
: rel-word ( word class -- )
>r add-literal r> rt-xt rel-fixup ;
: rel-primitive ( word class -- )
>r def>> first r> rt-primitive rel-fixup ;
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
: rel-here ( class -- )
0 swap rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set
V{ } clone label-table set ;
: resolve-labels ( labels -- labels' )
[
first3 offset>>
[ "Unresolved label" throw ] unless*
3array
] map concat ;
: fixup ( code -- literals relocation labels code )
[
init-fixup
dup stack-frame-size swap [ fixup* ] each drop
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
] { } make ;

1
unfinished/compiler/codegen/fixup/summary.txt Normal file
View File

@ -0,0 +1 @@
Support for generation of relocatable code

72
unfinished/compiler/instructions/instructions.factor Normal file
View File

@ -0,0 +1,72 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences
compiler.instructions.syntax ;
IN: compiler.instructions
! Virtual CPU instructions, used by CFG and machine IRs
INSN: %cond-branch vreg ;
INSN: %unary dst src ;
! Stack operations
INSN: %peek vreg loc ;
INSN: %replace vreg loc ;
INSN: %inc-d n ;
INSN: %inc-r n ;
INSN: %load-literal obj vreg ;
! Calling convention
INSN: %prologue ;
INSN: %epilogue ;
INSN: %frame-required n ;
INSN: %return ;
! Subroutine calls
INSN: %call word ;
INSN: %jump word ;
INSN: %intrinsic quot vregs ;
! Jump tables
INSN: %dispatch-label label ;
INSN: %dispatch ;
! Unconditional branch to successor (CFG only)
INSN: %branch ;
! Conditional branches (CFG only)
INSN: %branch-f < %cond-branch ;
INSN: %branch-t < %cond-branch ;
INSN: %if-intrinsic quot vregs ;
INSN: %boolean-intrinsic quot vregs out ;
! Boxing and unboxing
INSN: %copy < %unary ;
INSN: %copy-float < %unary ;
INSN: %unbox-float < %unary ;
INSN: %unbox-f < %unary ;
INSN: %unbox-alien < %unary ;
INSN: %unbox-byte-array < %unary ;
INSN: %unbox-any-c-ptr < %unary ;
INSN: %box-float < %unary ;
INSN: %box-alien < %unary ;
INSN: %gc ;
! FFI
INSN: %alien-invoke params ;
INSN: %alien-indirect params ;
INSN: %alien-callback params ;
GENERIC: uses-vregs ( insn -- seq )
M: insn uses-vregs drop f ;
M: %peek uses-vregs vreg>> 1array ;
M: %replace uses-vregs vreg>> 1array ;
M: %load-literal uses-vregs vreg>> 1array ;
M: %cond-branch uses-vregs vreg>> 1array ;
M: %unary uses-vregs [ dst>> ] [ src>> ] bi 2array ;
M: %intrinsic uses-vregs vregs>> values ;
M: %if-intrinsic uses-vregs vregs>> values ;
M: %boolean-intrinsic uses-vregs
[ vregs>> values ] [ out>> ] bi suffix ;

15
unfinished/compiler/instructions/syntax/syntax.factor Normal file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
make parser ;
IN: compiler.instructions.syntax
TUPLE: insn ;
: INSN:
parse-tuple-definition
[ dup tuple eq? [ drop insn ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
[ 2drop dup [ boa , ] curry define-inline ]
3tri ; parsing

0
unfinished/compiler/lvops/lvops.factor → unfinished/compiler/lvops.bluesky/lvops.factor
View File

50
unfinished/compiler/machine.bluesky/builder/builder.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces
compiler.cfg compiler.vops compiler.lvops ;
IN: compiler.machine.builder
SYMBOL: block-counter
: number-basic-block ( basic-block -- )
#! Make this fancy later.
dup number>> [ drop ] [
block-counter [ dup 1+ ] change >>number
[ , ] [
successors>> <reversed>
[ number-basic-block ] each
] bi
] if ;
: flatten-basic-blocks ( procedure -- blocks )
[
0 block-counter
[ number-basic-block ]
with-variable
] { } make ;
GENERIC: linearize-instruction ( basic-block insn -- )
M: object linearize-instruction
, drop ;
M: %b linearize-instruction
drop successors>> first number>> _b emit ;
: conditional-branch ( basic-block insn class -- )
[ successors>> ] 2dip
[ [ first number>> ] [ [ in>> ] [ code>> ] bi ] [ ] tri* emit ]
[ 2drop second number>> _b emit ]
3bi ; inline
M: %bi linearize-instruction _bi conditional-branch ;
M: %bf linearize-instruction _bf conditional-branch ;
: build-mr ( procedure -- insns )
[
flatten-basic-blocks [
[ number>> _label emit ]
[ dup instructions>> [ linearize-instruction ] with each ]
bi
] each
] { } make ;

0
unfinished/compiler/machine/debugger/debugger.factor → unfinished/compiler/machine.bluesky/debugger/debugger.factor
View File

0
unfinished/compiler/machine/simplifier/simplifier.factor → unfinished/compiler/machine.bluesky/simplifier/simplifier.factor
View File

58
unfinished/compiler/machine/builder/builder.factor
View File

@ -1,14 +1,17 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces
compiler.cfg compiler.vops compiler.lvops ;
USING: kernel math accessors sequences namespaces make
compiler.cfg compiler.instructions compiler.machine ;
IN: compiler.machine.builder
! Convert CFG IR to machine IR.
SYMBOL: block-counter
: number-basic-block ( basic-block -- )
#! Make this fancy later.
dup number>> [ drop ] [
<label> >>label
block-counter [ dup 1+ ] change >>number
[ , ] [
successors>> <reversed>
@ -23,28 +26,47 @@ SYMBOL: block-counter
with-variable
] { } make ;
GENERIC: linearize-instruction ( basic-block insn -- )
GENERIC: linearize* ( basic-block insn -- )
M: object linearize-instruction
, drop ;
M: object linearize* , drop ;
M: %b linearize-instruction
drop successors>> first number>> _b emit ;
M: %branch linearize*
drop successors>> first label>> _branch ;
: conditional-branch ( basic-block insn class -- )
[ successors>> ] 2dip
[ [ first number>> ] [ [ in>> ] [ code>> ] bi ] [ ] tri* emit ]
[ 2drop second number>> _b emit ]
3bi ; inline
: conditional ( basic-block -- label1 label2 )
successors>> first2 [ label>> ] bi@ swap ; inline
M: %bi linearize-instruction _bi conditional-branch ;
M: %bf linearize-instruction _bf conditional-branch ;
: boolean-conditional ( basic-block insn -- label1 vreg label2 )
[ conditional ] [ vreg>> ] bi* swap ; inline
: build-mr ( procedure -- insns )
M: %branch-f linearize*
boolean-conditional _branch-f _branch ;
M: %branch-t linearize*
boolean-conditional _branch-t _branch ;
M: %if-intrinsic linearize*
[ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi*
_if-intrinsic _branch ;
M: %boolean-intrinsic linearize*
[
flatten-basic-blocks [
[ number>> _label emit ]
[ dup instructions>> [ linearize-instruction ] with each ]
"false" define-label
"end" define-label
"false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
t over out>> %load-literal
"end" get _branch
"false" resolve-label
f over out>> %load-literal
"end" resolve-label
] with-scope
2drop ;
: build-machine ( procedure -- insns )
[
entry>> flatten-basic-blocks [
[ label>> _label ]
[ dup instructions>> [ linearize* ] with each ]
bi
] each
] { } make ;

90
unfinished/compiler/machine/linear-scan/allocation/allocation.factor Normal file
View File

@ -0,0 +1,90 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math math.order kernel assocs
accessors vectors fry
compiler.machine.linear-scan.live-intervals
compiler.backend ;
IN: compiler.machine.linear-scan.allocation
! Mapping from vregs to machine registers
SYMBOL: register-allocation
! Mapping from vregs to spill locations
SYMBOL: spill-locations
! Vector of active live intervals, in order of increasing end point
SYMBOL: active-intervals
: add-active ( live-interval -- )
active-intervals get push ;
: delete-active ( live-interval -- )
active-intervals get delete ;
! Mapping from register classes to sequences of machine registers
SYMBOL: free-registers
! Counter of spill locations
SYMBOL: spill-counter
: next-spill-location ( -- n )
spill-counter [ dup 1+ ] change ;
: assign-spill ( live-interval -- )
next-spill-location swap vreg>> spill-locations get set-at ;
: free-registers-for ( vreg -- seq )
reg-class>> free-registers get at ;
: free-register ( vreg -- )
#! Free machine register currently assigned to vreg.
[ register-allocation get at ] [ free-registers-for ] bi push ;
: expire-old-intervals ( live-interval -- )
active-intervals get
swap '[ end>> _ start>> < ] partition
active-intervals set
[ vreg>> free-register ] each ;
: interval-to-spill ( -- live-interval )
#! We spill the interval with the longest remaining range.
active-intervals get unclip-slice [
[ [ end>> ] bi@ > ] most
] reduce ;
: reuse-register ( live-interval to-spill -- )
vreg>> swap vreg>>
register-allocation get
tuck [ at ] [ set-at ] 2bi* ;
: spill-at-interval ( live-interval -- )
interval-to-spill
2dup [ end>> ] bi@ > [
[ reuse-register ]
[ nip assign-spill ]
[ [ add-active ] [ delete-active ] bi* ]
2tri
] [ drop assign-spill ] if ;
: init-allocator ( -- )
H{ } clone register-allocation set
H{ } clone spill-locations set
V{ } clone active-intervals set
machine-registers [ >vector ] assoc-map free-registers set
0 spill-counter set ;
: assign-register ( live-interval register -- )
swap vreg>> register-allocation get set-at ;
: allocate-register ( live-interval -- )
dup vreg>> free-registers-for [
spill-at-interval
] [
[ pop assign-register ]
[ drop add-active ]
2bi
] if-empty ;
: allocate-registers ( live-intervals -- )
init-allocator
[ [ expire-old-intervals ] [ allocate-register ] bi ] each ;

12
unfinished/compiler/machine/linear-scan/linear-scan.factor Normal file
View File

@ -0,0 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.machine.linear-scan
! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
! ! ! Step 1: compute live intervals
! ! ! Step 2: allocate registers

32
unfinished/compiler/machine/linear-scan/live-intervals/live-intervals.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math
math.order sorting compiler.instructions compiler.registers ;
IN: compiler.machine.linear-scan.live-intervals
TUPLE: live-interval < identity-tuple vreg start end ;
M: live-interval hashcode* nip [ start>> ] [ end>> 1000 * ] bi + ;
! Mapping from vreg to live-interval
SYMBOL: live-intervals
: update-live-interval ( n vreg -- )
>vreg
live-intervals get
[ over f live-interval boa ] cache
(>>end) ;
: compute-live-intervals* ( n insn -- )
uses-vregs [ update-live-interval ] with each ;
: sort-live-intervals ( assoc -- seq' )
#! Sort by increasing start location.
values [ [ start>> ] compare ] sort ;
: compute-live-intervals ( instructions -- live-intervals )
H{ } clone [
live-intervals [
[ swap compute-live-intervals* ] each-index
] with-variable
] keep sort-live-intervals ;

27
unfinished/compiler/machine/machine.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays namespaces kernel math
sequences compiler.instructions compiler.instructions.syntax ;
IN: compiler.machine
! Machine representation. Flat list of instructions, all
! registers allocated, with labels and jumps.
INSN: _prologue n ;
INSN: _epilogue n ;
INSN: _label label ;
: <label> ( -- label ) \ <label> counter ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup integer? [ get ] unless _label ;
TUPLE: _cond-branch vreg label ;
INSN: _branch label ;
INSN: _branch-f < _cond-branch ;
INSN: _branch-t < _cond-branch ;
INSN: _if-intrinsic label quot vregs ;
M: _cond-branch uses-vregs vreg>> 1array ;
M: _if-intrinsic uses-vregs vregs>> values ;

4
unfinished/compiler/machine/optimizer/optimizer-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: compiler.machine.optimizer.tests
USING: compiler.machine.optimizer tools.test ;
\ optimize-machine must-infer

39
unfinished/compiler/machine/optimizer/optimizer.factor Normal file
View File

@ -0,0 +1,39 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math namespaces make sequences
sequences.next
compiler.instructions
compiler.instructions.syntax
compiler.machine ;
IN: compiler.machine.optimizer
: frame-required ( insns -- n/f )
[ %frame-required? ] filter
[ f ] [ [ n>> ] map supremum ] if-empty ;
GENERIC: optimize* ( next insn -- )
: useless-branch? ( next insn -- ? )
over _label? [ [ label>> ] bi@ = ] [ 2drop f ] if ;
M: _branch optimize*
#! Remove unconditional branches to labels immediately
#! following.
tuck useless-branch? [ drop ] [ , ] if ;
M: %prologue optimize*
2drop \ frame-required get [ _prologue ] when* ;
M: %epilogue optimize*
2drop \ frame-required get [ _epilogue ] when* ;
M: %frame-required optimize* 2drop ;
M: insn optimize* nip , ;
: optimize-machine ( insns -- insns )
[
[ frame-required \ frame-required set ]
[ [ optimize* ] each-next ]
bi
] { } make ;

90
unfinished/compiler/registers/registers.factor Normal file
View File

@ -0,0 +1,90 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces math kernel ;
IN: compiler.registers
! Virtual CPU registers, used by CFG and machine IRs
MIXIN: value
GENERIC: >vreg ( obj -- vreg )
M: value >vreg drop f ;
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
! Virtual registers
TUPLE: vreg reg-class n ;
SYMBOL: vreg-counter
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
M: vreg >vreg ;
INSTANCE: vreg value
! Stack locations
TUPLE: loc n class ;
! A data stack location.
TUPLE: ds-loc < loc ;
: <ds-loc> ( n -- loc ) f ds-loc boa ;
TUPLE: rs-loc < loc ;
: <rs-loc> ( n -- loc ) f rs-loc boa ;
INSTANCE: loc value
! A stack location which has been loaded into a register. To
! read the location, we just read the register, but when time
! comes to save it back to the stack, we know the register just
! contains a stack value so we don't have to redundantly write
! it back.
TUPLE: cached loc vreg ;
C: <cached> cached
M: cached >vreg vreg>> >vreg ;
INSTANCE: cached value
! A tagged pointer
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged ) f tagged boa ;
M: tagged >vreg vreg>> ;
INSTANCE: tagged value
! Unboxed value
TUPLE: unboxed vreg ;
C: <unboxed> unboxed
M: unboxed >vreg vreg>> ;
INSTANCE: unboxed value
! Unboxed alien pointer
TUPLE: unboxed-alien < unboxed ;
C: <unboxed-alien> unboxed-alien
! Untagged byte array pointer
TUPLE: unboxed-byte-array < unboxed ;
C: <unboxed-byte-array> unboxed-byte-array
! A register set to f
TUPLE: unboxed-f < unboxed ;
C: <unboxed-f> unboxed-f
! An alien, byte array or f
TUPLE: unboxed-c-ptr < unboxed ;
C: <unboxed-c-ptr> unboxed-c-ptr
! A constant value
TUPLE: constant value ;
C: <constant> constant
INSTANCE: constant value

0
unfinished/compiler/vops/builder/builder.factor → unfinished/compiler/vops.bluesky/builder/builder.factor
View File

0
unfinished/compiler/vops/vops.factor → unfinished/compiler/vops.bluesky/vops.factor
View File