86 lines
2.4 KiB
Factor
86 lines
2.4 KiB
Factor
! Copyright (C) 2010 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors arrays assocs compiler.cfg compiler.cfg.debugger
|
|
compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.registers
|
|
compiler.cfg.representations.preferred compiler.cfg.rpo
|
|
compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.utilities
|
|
compiler.tree.builder compiler.tree.checker compiler.tree.def-use
|
|
compiler.tree.normalization compiler.tree.propagation
|
|
compiler.tree.propagation.info compiler.tree.recursive compiler.units
|
|
fry hashtables kernel math namespaces sequences stack-checker
|
|
tools.test vectors vocabs words ;
|
|
IN: compiler.test
|
|
|
|
: decompile ( word -- )
|
|
dup def>> 2array 1array t t modify-code-heap ;
|
|
|
|
: recompile-all ( -- )
|
|
all-words compile ;
|
|
|
|
: compile-call ( quot -- )
|
|
[ dup infer define-temp ] with-compilation-unit execute ;
|
|
|
|
<< \ compile-call t "no-compile" set-word-prop >>
|
|
|
|
: init-cfg-test ( -- )
|
|
reset-vreg-counter begin-stack-analysis
|
|
<basic-block> dup basic-block set begin-local-analysis
|
|
H{ } clone representations set
|
|
H{ } clone replaces set ;
|
|
|
|
: cfg-unit-test ( result quot -- )
|
|
'[ init-cfg-test @ ] unit-test ; inline
|
|
|
|
: edge ( from to -- )
|
|
[ get ] bi@ 1vector >>successors drop ;
|
|
|
|
: edges ( from tos -- )
|
|
[ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ;
|
|
|
|
: test-diamond ( -- )
|
|
0 1 edge
|
|
1 { 2 3 } edges
|
|
2 4 edge
|
|
3 4 edge ;
|
|
|
|
: resolve-phis ( bb -- )
|
|
[
|
|
[ [ [ get ] dip ] assoc-map ] change-inputs drop
|
|
] each-phi ;
|
|
|
|
: test-bb ( insns n -- )
|
|
[ insns>block dup ] keep set resolve-phis ;
|
|
|
|
: fake-representations ( cfg -- )
|
|
post-order [
|
|
instructions>> [
|
|
[ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
|
|
[ [ defs-vregs ] [ defs-vreg-reps ] bi zip ]
|
|
bi append
|
|
] map concat
|
|
] map concat >hashtable representations set ;
|
|
|
|
: count-insns ( quot insn-check -- ? )
|
|
[ test-regs [ cfg>insns ] map concat ] dip count ; inline
|
|
|
|
: contains-insn? ( quot insn-check -- ? )
|
|
count-insns 0 > ; inline
|
|
|
|
: make-edges ( block-map edgelist -- )
|
|
[ [ of ] with map first2 connect-bbs ] with each ;
|
|
|
|
: final-info ( quot -- seq )
|
|
build-tree
|
|
analyze-recursive
|
|
normalize
|
|
propagate
|
|
compute-def-use
|
|
dup check-nodes
|
|
last node-input-infos ;
|
|
|
|
: final-classes ( quot -- seq )
|
|
final-info [ class>> ] map ;
|
|
|
|
: final-literals ( quot -- seq )
|
|
final-info [ literal>> ] map ;
|