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

Rewritten linearizer

release
slava 2006-03-02 06:12:32 +00:00
parent f33bd6d03b
commit 46331ebefa
10 changed files with 141 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
library/alien/alien-callback.factor
View File

@ -62,4 +62,4 @@ M: alien-callback-error summary ( error -- )
] make-linear ;
M: alien-callback linearize* ( node -- )
compile-gc dup linearize-callback linearize-next ;
compile-gc linearize-callback iterate-next ;

5
library/alien/alien-invoke.factor
View File

@ -73,9 +73,8 @@ M: alien-invoke linearize* ( node -- )
compile-gc
dup alien-invoke-parameters objects>registers
dup alien-invoke-dlsym %alien-invoke ,
dup linearize-cleanup
dup box-return
linearize-next ;
dup linearize-cleanup box-return
iterate-next ;
: parse-arglist ( return seq -- types stack-effect )
unpair [

1
library/bootstrap/boot-stage1.factor
View File

@ -120,7 +120,6 @@ vectors words ;
"/library/inference/words.factor"
"/library/inference/class-infer.factor"
"/library/inference/kill-literals.factor"
"/library/inference/split-nodes.factor"
"/library/inference/optimizer.factor"
"/library/inference/inline-methods.factor"
"/library/inference/known-words.factor"

142
library/compiler/linearizer.factor
View File

@ -1,14 +1,48 @@
! 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.
USING: arrays compiler-backend hashtables inference kernel
namespaces sequences words ;
IN: compiler-frontend
USING: arrays compiler-backend errors generic hashtables
inference kernel math namespaces prettyprint sequences
strings words ;
: in-1 0 0 %peek-d , ;
: in-2 0 1 %peek-d , 1 0 %peek-d , ;
: in-3 0 2 %peek-d , 1 1 %peek-d , 2 0 %peek-d , ;
: out-1 T{ vreg f 0 } 0 %replace-d , ;
SYMBOL: node-stack
: >node node-stack get push ;
: node> node-stack get pop ;
: node@ node-stack get peek ;
DEFER: iterate-nodes
: iterate-children ( quot -- )
node@ node-children [ swap iterate-nodes ] each ;
: iterate-next ( -- node ) node@ node-successor ;
: iterate-nodes ( node quot -- )
over [
[ swap >node call node> drop ] keep
over [ iterate-nodes ] [ 2drop ] if
] [
2drop
] if ; inline
: with-node-iterator ( quot -- )
[
V{ } clone node-stack set call
] with-scope ; inline
DEFER: #terminal?
PREDICATE: #merge #terminal-merge node-successor #terminal? ;
UNION: #terminal POSTPONE: f #return #values #terminal-merge ;
: tail-call? ( -- ? )
node-stack get [ node-successor ] map [ #terminal? ] all? ;
GENERIC: linearize* ( node -- next )
: linearize-child ( node -- )
[ node@ linearize* ] iterate-nodes ;
! A map from words to linear IR.
SYMBOL: linearized
@ -17,20 +51,14 @@ SYMBOL: linearized
! name in different scopes.
SYMBOL: renamed-labels
: rename-label ( label -- label )
<label> dup rot renamed-labels get set-hash ;
: renamed-label ( label -- label )
renamed-labels get hash ;
GENERIC: linearize* ( node -- )
: make-linear ( word quot -- )
swap >r [ %prologue , call ] { } make r>
linearized get set-hash ; inline
[
swap >r [ %prologue , call ] { } make r>
linearized get set-hash
] with-node-iterator ; inline
: linearize-1 ( word dataflow -- )
swap [ linearize* ] make-linear ;
: linearize-1 ( word node -- )
swap [ linearize-child ] make-linear ;
: init-linearizer ( -- )
H{ } clone linearized set
@ -41,25 +69,36 @@ GENERIC: linearize* ( node -- )
#! respective linear IR.
init-linearizer linearize-1 linearized get ;
: linearize-next node-successor linearize* ;
M: node linearize* ( node -- next ) drop iterate-next ;
M: f linearize* ( f -- ) drop ;
: linearize-call ( label -- next )
tail-call? [
%jump , f
] [
%call , iterate-next
] if ;
M: node linearize* ( node -- ) linearize-next ;
: rename-label ( label -- label )
<label> dup rot renamed-labels get set-hash ;
: linearize-call ( node label -- )
over node-successor #return?
[ %jump , drop ] [ %call , linearize-next ] if ;
: renamed-label ( label -- label )
renamed-labels get hash ;
: linearize-call-label ( node -- )
dup node-param rename-label linearize-call ;
: linearize-call-label ( label -- next )
rename-label linearize-call ;
M: #label linearize* ( node -- )
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 linearize-call-label dup node-param renamed-label
swap node-child linearize-1 ;
dup node-param dup linearize-call-label >r
renamed-label swap node-child linearize-1
r> ;
: in-1 0 0 %peek-d , ;
: in-2 0 1 %peek-d , 1 0 %peek-d , ;
: in-3 0 2 %peek-d , 1 1 %peek-d , 2 0 %peek-d , ;
: out-1 T{ vreg f 0 } 0 %replace-d , ;
: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
@ -67,47 +106,40 @@ M: #label linearize* ( node -- )
dup node-successor #if?
[ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
: linearize-if ( node label -- )
<label> dup >r >r >r dup node-children first2 linearize*
r> r> %jump-label , %label , linearize* r> %label ,
linearize-next ;
: linearize-if ( node label -- next )
<label> dup >r >r >r node-children first2 linearize-child
r> r> %jump-label , %label , linearize-child r> %label ,
iterate-next ;
M: #call linearize* ( node -- )
dup if-intrinsic [
>r <label> 2dup r> call
>r node-successor r> linearize-if
] [
dup intrinsic [
dupd call linearize-next
] [
dup node-param linearize-call
] if*
dup intrinsic
[ call iterate-next ] [ node-param linearize-call ] if*
] if* ;
M: #call-label linearize* ( node -- )
dup node-param renamed-label linearize-call ;
M: #call-label linearize* ( node -- next )
node-param renamed-label linearize-call ;
M: #if linearize* ( node -- )
M: #if linearize* ( node -- next )
in-1 -1 %inc-d , <label> dup 0 %jump-t , linearize-if ;
: dispatch-head ( vtable -- label/code )
: dispatch-head ( vtable -- label/node )
#! Output the jump table insn and return a list of
#! label/branch pairs.
in-1
-1 %inc-d ,
0 %dispatch ,
in-1 -1 %inc-d , 0 %dispatch ,
[ <label> dup %target-label , 2array ] map ;
: dispatch-body ( label/param -- )
: dispatch-body ( label/node -- )
<label> swap [
first2 %label , linearize* dup %jump-label ,
first2 %label , linearize-child dup %jump-label ,
] each %label , ;
M: #dispatch linearize* ( vtable -- )
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.
dup node-children dispatch-head dispatch-body
linearize-next ;
node-children dispatch-head dispatch-body iterate-next ;
M: #return linearize* ( node -- )
drop %return , ;
M: #return linearize* drop %return , f ;

6
library/compiler/stack.factor
View File

@ -88,7 +88,5 @@ M: #shuffle linearize* ( #shuffle -- )
0 vreg-allocator set
dup node-in-d over node-out-d live-stores live-d set
dup node-in-r over node-out-r live-stores live-r set
dup stacks>vregs
dup shuffle-height
vregs>stacks
] with-scope linearize-next ;
dup stacks>vregs shuffle-height vregs>stacks
] with-scope iterate-next ;

23
library/inference/inline-methods.factor
View File

@ -54,6 +54,22 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
: method-dataflow ( node -- dataflow )
dup will-inline swap node-in-d dataflow-with ;
: post-inline ( #return/#values #call/#merge -- )
dup [
[
>r node-in-d r> node-out-d
2array unify-lengths first2
] keep node-successor subst-values
] [
2drop
] if ;
: subst-node ( old new -- )
#! The last node of 'new' becomes 'old', then values are
#! substituted. A subsequent optimizer phase kills the
#! last node of 'new' and the first node of 'old'.
last-node 2dup swap post-inline set-node-successor ;
: inline-method ( node -- node )
#! We set the #call node's param to f so that it gets killed
#! later.
@ -73,6 +89,13 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
2drop f
] if ;
: inline-literals ( node literals -- node )
#! Make #push -> #return -> successor
over drop-inputs [
>r >list [ literalize ] map dataflow [ subst-node ] keep
r> set-node-successor
] keep ;
: optimize-predicate ( #call -- node )
dup node-param "predicating" word-prop >r
dup dup node-in-d node-classes* first r> class<

28
library/inference/kill-literals.factor
View File

@ -2,7 +2,7 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: optimizer
USING: arrays generic hashtables inference kernel math
namespaces sequences ;
namespaces sequences words ;
: node-union ( node quot -- hash | quot: node -- )
[
@ -14,17 +14,18 @@ GENERIC: literals* ( node -- seq )
: literals ( node -- hash )
[ literals* ] node-union ;
GENERIC: flushable-values* ( node -- seq )
: flushable-values ( node -- hash )
[ flushable-values* ] node-union ;
GENERIC: live-values* ( node -- seq )
: live-values ( node -- hash )
#! All values that are returned or passed to calls.
[ live-values* ] node-union ;
: kill-set ( node -- hash )
#! Push a list of literals that may be killed in the IR.
dup live-values swap literals hash-diff ;
: remove-values ( values node -- )
: kill-node* ( values node -- )
2dup [ node-in-d remove-all ] keep set-node-in-d
2dup [ node-out-d remove-all ] keep set-node-out-d
2dup [ node-in-r remove-all ] keep set-node-in-r
@ -32,11 +33,19 @@ GENERIC: live-values* ( node -- seq )
: kill-node ( values node -- )
over hash-empty?
[ 2drop ] [ [ remove-values ] each-node-with ] if ;
[ 2drop ] [ [ kill-node* ] each-node-with ] if ;
: kill-unused-literals ( node -- )
\ live-values get over literals hash-diff swap kill-node ;
: kill-values ( node -- )
dup live-values over literals hash-diff swap kill-node ;
! Generic nodes
M: node literals* ( node -- ) drop { } ;
M: node flushable-values* ( node -- ) drop { } ;
M: node live-values* ( node -- ) node-values ;
! #shuffle
@ -44,6 +53,11 @@ M: #shuffle literals* ( node -- seq )
dup node-out-d swap node-out-r
[ [ value? ] subset ] 2apply append ;
! #call
M: #call flushable-values* ( node -- )
dup node-param "flushable" word-prop
[ node-out-d ] [ drop { } ] if ;
! #return
M: #return live-values* ( node -- seq )
#! Values returned by local labels can be killed.

18
library/inference/optimizer.factor
View File

@ -1,13 +1,9 @@
! 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: optimizer
USING: compiler-backend generic hashtables inference kernel
lists math namespaces sequences vectors ;
! We use the recursive-state variable here, to track nested
! label scopes, to prevent infinite loops when inlining
! recursive methods.
GENERIC: optimize-node* ( node -- node/t )
: keep-optimizing ( node -- node ? )
@ -30,16 +26,10 @@ DEFER: optimize-node
] [ r> ] if ;
: optimize-1 ( dataflow -- dataflow ? )
recursive-state off
dup kill-set over kill-node
dup infer-classes
optimize-node ;
: optimize-loop ( dataflow -- dataflow )
optimize-1 [ optimize-loop ] when ;
dup kill-values dup infer-classes optimize-node ;
: optimize ( dataflow -- dataflow )
[ dup split-node optimize-loop ] with-scope ;
[ optimize-1 ] with-scope [ optimize ] when ;
: prune-if ( node quot -- successor/t )
over >r call [ r> node-successor ] [ r> drop t ] if ;

62
library/inference/split-nodes.factor
View File

@ -1,62 +0,0 @@
IN: optimizer
USING: arrays inference kernel lists sequences words ;
! #if --> X
! |
! +--> Y
! |
! +--> Z
! Becomes:
! #if
! |
! +--> Y --> X
! |
! +--> Z --> X
GENERIC: split-node* ( node -- )
: split-node ( node -- ) drop ;
! [ dup split-node* node-successor split-node ] when* ;
M: node split-node* ( node -- ) drop ;
: post-inline ( #return/#values #call/#merge -- )
dup [
[
>r node-in-d r> node-out-d
2array unify-lengths first2
] keep node-successor subst-values
] [
2drop
] if ;
: subst-node ( old new -- )
#! The last node of 'new' becomes 'old', then values are
#! substituted. A subsequent optimizer phase kills the
#! last node of 'new' and the first node of 'old'.
[ last-node 2dup swap post-inline set-node-successor ] keep
split-node ;
: inline-literals ( node literals -- node )
#! Make #push -> #return -> successor
over drop-inputs [
>r >list [ literalize ] map dataflow [ subst-node ] keep
r> set-node-successor
] keep ;
: split-branch ( node -- )
dup node-successor over node-children
[ >r clone-node r> subst-node ] each-with
f swap set-node-successor ;
M: #if split-node* ( node -- )
split-branch ;
M: #dispatch split-node* ( node -- )
split-branch ;
! #label
M: #label split-node* ( node -- )
node-child split-node ;

2
library/syntax/parse-syntax.factor
View File

@ -43,7 +43,7 @@ SYMBOL: t
: \ scan-word literalize swons ; parsing
: parsing word t "parsing" set-word-prop ; parsing
: inline word t "inline" set-word-prop ; parsing
: flushable ( not implemented ) ; parsing
: flushable word t "flushable" set-word-prop ; parsing
: foldable word t "foldable" set-word-prop ; parsing
: SYMBOL: CREATE dup reset-generic define-symbol ; parsing
DEFER: PRIMITIVE: parsing