diff --git a/unfinished/compiler/alien/alien.factor b/unfinished/compiler/alien/alien.factor new file mode 100644 index 0000000000..1d63a06057 --- /dev/null +++ b/unfinished/compiler/alien/alien.factor @@ -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 + ; diff --git a/unfinished/compiler/backend/alien/alien.factor b/unfinished/compiler/backend/alien/alien.factor new file mode 100644 index 0000000000..0c5a6afb75 --- /dev/null +++ b/unfinished/compiler/backend/alien/alien.factor @@ -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 % ; + +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 ; diff --git a/unfinished/compiler/backend/backend.factor b/unfinished/compiler/backend/backend.factor new file mode 100644 index 0000000000..c1944eb9a7 --- /dev/null +++ b/unfinished/compiler/backend/backend.factor @@ -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 ) diff --git a/unfinished/compiler/backend/x86/32/32.factor b/unfinished/compiler/backend/x86/32/32.factor new file mode 100644 index 0000000000..85df673839 --- /dev/null +++ b/unfinished/compiler/backend/x86/32/32.factor @@ -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 } } + } ; diff --git a/unfinished/compiler/cfg/alias/alias.factor b/unfinished/compiler/cfg.bluesky/alias/alias.factor similarity index 100% rename from unfinished/compiler/cfg/alias/alias.factor rename to unfinished/compiler/cfg.bluesky/alias/alias.factor diff --git a/unfinished/compiler/cfg/authors.txt b/unfinished/compiler/cfg.bluesky/authors.txt similarity index 100% rename from unfinished/compiler/cfg/authors.txt rename to unfinished/compiler/cfg.bluesky/authors.txt diff --git a/unfinished/compiler/cfg.bluesky/builder/builder-tests.factor b/unfinished/compiler/cfg.bluesky/builder/builder-tests.factor new file mode 100644 index 0000000000..098919c868 --- /dev/null +++ b/unfinished/compiler/cfg.bluesky/builder/builder-tests.factor @@ -0,0 +1,4 @@ +IN: compiler.cfg.builder.tests +USING: compiler.cfg.builder tools.test ; + +\ build-cfg must-infer diff --git a/unfinished/compiler/cfg.bluesky/builder/builder.factor b/unfinished/compiler/cfg.bluesky/builder/builder.factor new file mode 100644 index 0000000000..76a1b67dd2 --- /dev/null +++ b/unfinished/compiler/cfg.bluesky/builder/builder.factor @@ -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 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 ] [ + [ ] 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 ] [ + [ ] 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 ) + [ + + [ 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 + + [ '[ , _ 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 ; diff --git a/unfinished/compiler/cfg.bluesky/cfg.factor b/unfinished/compiler/cfg.bluesky/cfg.factor new file mode 100644 index 0000000000..ae14f3e009 --- /dev/null +++ b/unfinished/compiler/cfg.bluesky/cfg.factor @@ -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 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 diff --git a/unfinished/compiler/cfg/elaboration/elaboration.factor b/unfinished/compiler/cfg.bluesky/elaboration/elaboration.factor similarity index 100% rename from unfinished/compiler/cfg/elaboration/elaboration.factor rename to unfinished/compiler/cfg.bluesky/elaboration/elaboration.factor diff --git a/unfinished/compiler/cfg/kill-nops/kill-nops.factor b/unfinished/compiler/cfg.bluesky/kill-nops/kill-nops.factor similarity index 100% rename from unfinished/compiler/cfg/kill-nops/kill-nops.factor rename to unfinished/compiler/cfg.bluesky/kill-nops/kill-nops.factor diff --git a/unfinished/compiler/cfg/live-ranges/live-ranges.factor b/unfinished/compiler/cfg.bluesky/live-ranges/live-ranges.factor similarity index 100% rename from unfinished/compiler/cfg/live-ranges/live-ranges.factor rename to unfinished/compiler/cfg.bluesky/live-ranges/live-ranges.factor diff --git a/unfinished/compiler/cfg/predecessors/predecessors.factor b/unfinished/compiler/cfg.bluesky/predecessors/predecessors.factor similarity index 100% rename from unfinished/compiler/cfg/predecessors/predecessors.factor rename to unfinished/compiler/cfg.bluesky/predecessors/predecessors.factor diff --git a/unfinished/compiler/cfg/simplifier/simplifier.factor b/unfinished/compiler/cfg.bluesky/simplifier/simplifier.factor similarity index 100% rename from unfinished/compiler/cfg/simplifier/simplifier.factor rename to unfinished/compiler/cfg.bluesky/simplifier/simplifier.factor diff --git a/unfinished/compiler/cfg/stack/stack.factor b/unfinished/compiler/cfg.bluesky/stack/stack.factor similarity index 100% rename from unfinished/compiler/cfg/stack/stack.factor rename to unfinished/compiler/cfg.bluesky/stack/stack.factor diff --git a/unfinished/compiler/cfg/summary.txt b/unfinished/compiler/cfg.bluesky/summary.txt similarity index 100% rename from unfinished/compiler/cfg/summary.txt rename to unfinished/compiler/cfg.bluesky/summary.txt diff --git a/unfinished/compiler/cfg/vn/conditions/conditions.factor b/unfinished/compiler/cfg.bluesky/vn/conditions/conditions.factor similarity index 100% rename from unfinished/compiler/cfg/vn/conditions/conditions.factor rename to unfinished/compiler/cfg.bluesky/vn/conditions/conditions.factor diff --git a/unfinished/compiler/cfg/vn/constant-fold/constant-fold.factor b/unfinished/compiler/cfg.bluesky/vn/constant-fold/constant-fold.factor similarity index 100% rename from unfinished/compiler/cfg/vn/constant-fold/constant-fold.factor rename to unfinished/compiler/cfg.bluesky/vn/constant-fold/constant-fold.factor diff --git a/unfinished/compiler/cfg/vn/expressions/expressions.factor b/unfinished/compiler/cfg.bluesky/vn/expressions/expressions.factor similarity index 100% rename from unfinished/compiler/cfg/vn/expressions/expressions.factor rename to unfinished/compiler/cfg.bluesky/vn/expressions/expressions.factor diff --git a/unfinished/compiler/cfg/vn/graph/graph.factor b/unfinished/compiler/cfg.bluesky/vn/graph/graph.factor similarity index 100% rename from unfinished/compiler/cfg/vn/graph/graph.factor rename to unfinished/compiler/cfg.bluesky/vn/graph/graph.factor diff --git a/unfinished/compiler/cfg/vn/liveness/liveness.factor b/unfinished/compiler/cfg.bluesky/vn/liveness/liveness.factor similarity index 100% rename from unfinished/compiler/cfg/vn/liveness/liveness.factor rename to unfinished/compiler/cfg.bluesky/vn/liveness/liveness.factor diff --git a/unfinished/compiler/cfg/vn/propagate/propagate.factor b/unfinished/compiler/cfg.bluesky/vn/propagate/propagate.factor similarity index 100% rename from unfinished/compiler/cfg/vn/propagate/propagate.factor rename to unfinished/compiler/cfg.bluesky/vn/propagate/propagate.factor diff --git a/unfinished/compiler/cfg/vn/simplify/simplify.factor b/unfinished/compiler/cfg.bluesky/vn/simplify/simplify.factor similarity index 100% rename from unfinished/compiler/cfg/vn/simplify/simplify.factor rename to unfinished/compiler/cfg.bluesky/vn/simplify/simplify.factor diff --git a/unfinished/compiler/cfg/vn/vn.factor b/unfinished/compiler/cfg.bluesky/vn/vn.factor similarity index 100% rename from unfinished/compiler/cfg/vn/vn.factor rename to unfinished/compiler/cfg.bluesky/vn/vn.factor diff --git a/unfinished/compiler/cfg/write-barrier/write-barrier.factor b/unfinished/compiler/cfg.bluesky/write-barrier/write-barrier.factor similarity index 100% rename from unfinished/compiler/cfg/write-barrier/write-barrier.factor rename to unfinished/compiler/cfg.bluesky/write-barrier/write-barrier.factor diff --git a/unfinished/compiler/cfg/builder/authors.txt b/unfinished/compiler/cfg/builder/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/unfinished/compiler/cfg/builder/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unfinished/compiler/cfg/builder/builder-tests.factor b/unfinished/compiler/cfg/builder/builder-tests.factor index 098919c868..ddc7d13f25 100644 --- a/unfinished/compiler/cfg/builder/builder-tests.factor +++ b/unfinished/compiler/cfg/builder/builder-tests.factor @@ -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 diff --git a/unfinished/compiler/cfg/builder/builder.factor b/unfinished/compiler/cfg/builder/builder.factor old mode 100644 new mode 100755 index 76a1b67dd2..0e13491a08 --- a/unfinished/compiler/cfg/builder/builder.factor +++ b/unfinished/compiler/cfg/builder/builder.factor @@ -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 get - [ - end-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 + 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 ] [ - [ ] 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 ] [ - [ ] 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 ) - [ - - [ 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 - - [ '[ , _ 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>> 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 ; diff --git a/unfinished/compiler/cfg/builder/summary.txt b/unfinished/compiler/cfg/builder/summary.txt new file mode 100644 index 0000000000..cf857ad971 --- /dev/null +++ b/unfinished/compiler/cfg/builder/summary.txt @@ -0,0 +1 @@ +Final stage of compilation generates machine code from dataflow IR diff --git a/unfinished/compiler/cfg/builder/tags.txt b/unfinished/compiler/cfg/builder/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/unfinished/compiler/cfg/builder/tags.txt @@ -0,0 +1 @@ +compiler diff --git a/unfinished/compiler/cfg/cfg.factor b/unfinished/compiler/cfg/cfg.factor index ae14f3e009..92a5700af4 100644 --- a/unfinished/compiler/cfg/cfg.factor +++ b/unfinished/compiler/cfg/cfg.factor @@ -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 + +! - "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 diff --git a/unfinished/compiler/cfg/iterator/iterator.factor b/unfinished/compiler/cfg/iterator/iterator.factor new file mode 100644 index 0000000000..904da3f0c3 --- /dev/null +++ b/unfinished/compiler/cfg/iterator/iterator.factor @@ -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? ; diff --git a/unfinished/compiler/cfg/stacks/authors.txt b/unfinished/compiler/cfg/stacks/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/unfinished/compiler/cfg/stacks/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unfinished/compiler/cfg/stacks/stacks.factor b/unfinished/compiler/cfg/stacks/stacks.factor new file mode 100755 index 0000000000..f2cfbb70a1 --- /dev/null +++ b/unfinished/compiler/cfg/stacks/stacks.factor @@ -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 + 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: ( n stack -- loc ) + +TUPLE: phantom-datastack < phantom-stack ; + +: ( -- stack ) + phantom-datastack new-phantom-stack ; + +M: phantom-datastack (loc) ; + +M: phantom-datastack finalize-height + \ %inc-d (finalize-height) ; + +TUPLE: phantom-retainstack < phantom-stack ; + +: ( -- stack ) + phantom-retainstack new-phantom-stack ; + +M: phantom-retainstack (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 r> '[ _ ] 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 [ ] } + { unboxed-alien [ ] } + { unboxed-byte-array [ ] } + { unboxed-f [ ] } + { 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 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 set + 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 ; diff --git a/unfinished/compiler/cfg/templates/templates.factor b/unfinished/compiler/cfg/templates/templates.factor new file mode 100644 index 0000000000..798e1fd563 --- /dev/null +++ b/unfinished/compiler/cfg/templates/templates.factor @@ -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 + [ ] 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 ; diff --git a/unfinished/compiler/codegen/fixup/authors.txt b/unfinished/compiler/codegen/fixup/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/unfinished/compiler/codegen/fixup/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unfinished/compiler/codegen/fixup/fixup.factor b/unfinished/compiler/codegen/fixup/fixup.factor new file mode 100755 index 0000000000..1f1cf81cb9 --- /dev/null +++ b/unfinished/compiler/codegen/fixup/fixup.factor @@ -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 ; + +: