From 0ae748d9bac879944abbc9c3172393c379860b9c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 20:39:58 -0500 Subject: [PATCH] Compiler fixes --- core/compiler/tests/simple.factor | 10 +++- core/cpu/x86/allot/allot.factor | 2 +- core/inference/class/class.factor | 9 ++-- core/optimizer/backend/backend.factor | 66 +++++++++++++-------------- core/optimizer/optimizer-tests.factor | 2 +- 5 files changed, 47 insertions(+), 42 deletions(-) diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index dce2ec562a..bc9c56864c 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -1,6 +1,6 @@ USING: compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings -alien arrays memory ; +alien arrays memory vocabs parser ; IN: compiler.tests ! Test empty word @@ -230,3 +230,11 @@ M: f single-combination-test-2 single-combination-test-4 ; ! Regression [ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test + +! Regression +10 [ + [ "compiler.tests.foo" forget-vocab ] with-compilation-unit + [ t ] [ + "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval + ] unit-test +] times diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index bfcede7ef7..63870f94cd 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -29,7 +29,7 @@ IN: cpu.x86.allot allot-reg POP allot-reg cell [+] swap 8 align ADD ; -M: x86.32 %gc ( -- ) +M: x86 %gc ( -- ) "end" define-label temp-reg-1 load-zone-ptr temp-reg-2 temp-reg-1 cell [+] MOV diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index c2629f107f..2bc260593c 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -325,16 +325,15 @@ M: #call-label infer-classes-before ( #call-label -- ) [ set-value-class* ] 2each ; M: #return infer-classes-around + dup call-next-method nested-labels get length 0 > [ dup param>> nested-labels get peek param>> eq? [ [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri - classes= [ - drop - ] [ + classes= not [ fixed-point? off [ in-d>> value-classes get extract-keys ] keep set-node-classes - ] if + ] [ drop ] if ] [ drop ] if ] [ drop ] if ; @@ -369,5 +368,5 @@ M: object infer-classes-around : infer-classes/node ( node existing -- ) #! Infer classes, using the existing node's class info as a #! starting point. - [ node-classes ] [ node-literals ] [ node-intervals ] tri + [ classes>> ] [ literals>> ] [ intervals>> ] tri infer-classes-with ; diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 3237f095bf..9630f9dc70 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -3,7 +3,7 @@ USING: arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables -combinators classes optimizer.def-use ; +combinators classes optimizer.def-use accessors ; IN: optimizer.backend SYMBOL: class-substitutions @@ -16,37 +16,32 @@ SYMBOL: optimizer-changed GENERIC: optimize-node* ( node -- node/t changed? ) -: ?union ( assoc/f assoc -- hash ) - over [ assoc-union ] [ nip ] if ; +: ?union ( assoc assoc/f -- assoc' ) + dup assoc-empty? [ drop ] [ swap assoc-union ] if ; -: add-node-literals ( assoc node -- ) - over assoc-empty? [ +: add-node-literals ( node assoc -- ) + [ ?union ] curry change-literals drop ; + +: add-node-classes ( node assoc -- ) + [ ?union ] curry change-classes drop ; + +: substitute-values ( node assoc -- ) + dup assoc-empty? [ 2drop ] [ - [ node-literals ?union ] keep set-node-literals - ] if ; - -: add-node-classes ( assoc node -- ) - over assoc-empty? [ - 2drop - ] [ - [ node-classes ?union ] keep set-node-classes - ] if ; - -: substitute-values ( assoc node -- ) - over assoc-empty? [ - 2drop - ] [ - 2dup node-in-d swap substitute-here - 2dup node-in-r swap substitute-here - 2dup node-out-d swap substitute-here - node-out-r swap substitute-here + { + [ >r in-d>> r> substitute-here ] + [ >r in-r>> r> substitute-here ] + [ >r out-d>> r> substitute-here ] + [ >r out-r>> r> substitute-here ] + } 2cleave ] if ; : perform-substitutions ( node -- ) - class-substitutions get over add-node-classes - literal-substitutions get over add-node-literals - value-substitutions get swap substitute-values ; + [ class-substitutions get add-node-classes ] + [ literal-substitutions get add-node-literals ] + [ value-substitutions get substitute-values ] + tri ; DEFER: optimize-nodes @@ -90,18 +85,21 @@ M: node optimize-node* drop t f ; #! Not very efficient. dupd union* update ; -: compute-value-substitutions ( #return/#values #call/#merge -- assoc ) - node-out-d swap node-in-d 2array unify-lengths flip +: compute-value-substitutions ( #call/#merge #return/#values -- assoc ) + [ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip [ = not ] assoc-subset >hashtable ; : cleanup-inlining ( #return/#values -- newnode changed? ) - dup node-successor dup [ - class-substitutions get pick node-classes update - literal-substitutions get pick node-literals update - tuck compute-value-substitutions value-substitutions get swap update* - node-successor t + dup node-successor [ + [ node-successor ] keep + { + [ nip classes>> class-substitutions get swap update ] + [ nip literals>> literal-substitutions get swap update ] + [ compute-value-substitutions value-substitutions get swap update* ] + [ drop node-successor ] + } 2cleave t ] [ - 2drop t f + drop t f ] if ; ! #return diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 63a63a2f92..14dcd62c61 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -291,7 +291,6 @@ TUPLE: silly-tuple a b ; [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test -! Make sure we don't lose GENERIC: generic-inline-test ( x -- y ) M: integer generic-inline-test ; @@ -308,6 +307,7 @@ M: integer generic-inline-test ; generic-inline-test generic-inline-test ; +! Inlining all of the above should only take two passes [ { t f } ] [ \ generic-inline-test-1 word-def dataflow [ optimize-1 , optimize-1 , drop ] { } make