--- /dev/null
+! 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 + ;
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 )
--- /dev/null
+! 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 } }
+ } ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces assocs hashtables sequences
+accessors vectors combinators sets compiler.vops compiler.cfg ;
+IN: compiler.cfg.alias
+
+! Alias analysis -- must be run after compiler.cfg.stack.
+!
+! We try to eliminate redundant slot and stack
+! traffic using some simple heuristics.
+!
+! All heap-allocated objects which are loaded from the stack, or
+! other object slots are pessimistically assumed to belong to
+! the same alias class.
+!
+! Freshly-allocated objects get their own alias class.
+!
+! The data and retain stack pointer registers are treated
+! uniformly, and each one gets its own alias class.
+!
+! Simple pseudo-C example showing load elimination:
+!
+! int *x, *y, z: inputs
+! int a, b, c, d, e: locals
+!
+! Before alias analysis:
+!
+! a = x[2]
+! b = x[2]
+! c = x[3]
+! y[2] = z
+! d = x[2]
+! e = y[2]
+! f = x[3]
+!
+! After alias analysis:
+!
+! a = x[2]
+! b = a /* ELIMINATED */
+! c = x[3]
+! y[2] = z
+! d = x[2] /* if x=y, d=z, if x!=y, d=b; NOT ELIMINATED */
+! e = z /* ELIMINATED */
+! f = c /* ELIMINATED */
+!
+! Simple pseudo-C example showing store elimination:
+!
+! Before alias analysis:
+!
+! x[0] = a
+! b = x[n]
+! x[0] = c
+! x[1] = d
+! e = x[0]
+! x[1] = c
+!
+! After alias analysis:
+!
+! x[0] = a /* dead if n = 0, live otherwise; NOT ELIMINATED */
+! b = x[n]
+! x[0] = c
+! /* x[1] = d */ /* ELIMINATED */
+! e = c
+! x[1] = c
+
+! Map vregs -> alias classes
+SYMBOL: vregs>acs
+
+: check [ "BUG: static type error detected" throw ] unless* ; inline
+
+: vreg>ac ( vreg -- ac )
+ #! Only vregs produced by %%allot, %peek and %%slot can
+ #! ever be used as valid inputs to %%slot and %%set-slot,
+ #! so we assert this fact by not giving alias classes to
+ #! other vregs.
+ vregs>acs get at check ;
+
+! Map alias classes -> sequence of vregs
+SYMBOL: acs>vregs
+
+: ac>vregs ( ac -- vregs ) acs>vregs get at ;
+
+: aliases ( vreg -- vregs )
+ #! All vregs which may contain the same value as vreg.
+ vreg>ac ac>vregs ;
+
+: each-alias ( vreg quot -- )
+ [ aliases ] dip each ; inline
+
+! Map vregs -> slot# -> vreg
+SYMBOL: live-slots
+
+! Current instruction number
+SYMBOL: insn#
+
+! Load/store history, for dead store elimination
+TUPLE: load insn# ;
+TUPLE: store insn# ;
+
+: new-action ( class -- action )
+ insn# get swap boa ; inline
+
+! Maps vreg -> slot# -> sequence of loads/stores
+SYMBOL: histories
+
+: history ( vreg -- history ) histories get at ;
+
+: set-ac ( vreg ac -- )
+ #! Set alias class of newly-seen vreg.
+ {
+ [ drop H{ } clone swap histories get set-at ]
+ [ drop H{ } clone swap live-slots get set-at ]
+ [ swap vregs>acs get set-at ]
+ [ acs>vregs get push-at ]
+ } 2cleave ;
+
+: live-slot ( slot#/f vreg -- vreg' )
+ #! If the slot number is unknown, we never reuse a previous
+ #! value.
+ over [ live-slots get at at ] [ 2drop f ] if ;
+
+: load-constant-slot ( value slot# vreg -- )
+ live-slots get at check set-at ;
+
+: load-slot ( value slot#/f vreg -- )
+ over [ load-constant-slot ] [ 3drop ] if ;
+
+: record-constant-slot ( slot# vreg -- )
+ #! A load can potentially read every store of this slot#
+ #! in that alias class.
+ [
+ history [ load new-action swap ?push ] change-at
+ ] with each-alias ;
+
+: record-computed-slot ( vreg -- )
+ #! Computed load is like a load of every slot touched so far
+ [
+ history values [ load new-action swap push ] each
+ ] each-alias ;
+
+: remember-slot ( value slot#/f vreg -- )
+ over
+ [ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
+ [ 2nip record-computed-slot ] if ;
+
+SYMBOL: ac-counter
+
+: next-ac ( -- n )
+ ac-counter [ dup 1+ ] change ;
+
+! Alias class for objects which are loaded from the data stack
+! or other object slots. We pessimistically assume that they
+! can all alias each other.
+SYMBOL: heap-ac
+
+: set-heap-ac ( vreg -- ) heap-ac get set-ac ;
+
+: set-new-ac ( vreg -- ) next-ac set-ac ;
+
+: kill-constant-set-slot ( slot# vreg -- )
+ [ live-slots get at delete-at ] with each-alias ;
+
+: record-constant-set-slot ( slot# vreg -- )
+ history [
+ dup empty? [ dup peek store? [ dup pop* ] when ] unless
+ store new-action swap ?push
+ ] change-at ;
+
+: kill-computed-set-slot ( ac -- )
+ [ live-slots get at clear-assoc ] each-alias ;
+
+: remember-set-slot ( slot#/f vreg -- )
+ over [
+ [ record-constant-set-slot ]
+ [ kill-constant-set-slot ] 2bi
+ ] [ nip kill-computed-set-slot ] if ;
+
+SYMBOL: copies
+
+: resolve ( vreg -- vreg )
+ dup copies get at swap or ;
+
+SYMBOL: constants
+
+: constant ( vreg -- n/f )
+ #! Return an %iconst value, or f if the vreg was not
+ #! assigned by an %iconst.
+ resolve constants get at ;
+
+! We treat slot accessors and stack traffic alike
+GENERIC: insn-slot# ( insn -- slot#/f )
+GENERIC: insn-object ( insn -- vreg )
+
+M: %peek insn-slot# n>> ;
+M: %replace insn-slot# n>> ;
+M: %%slot insn-slot# slot>> constant ;
+M: %%set-slot insn-slot# slot>> constant ;
+
+M: %peek insn-object stack>> ;
+M: %replace insn-object stack>> ;
+M: %%slot insn-object obj>> resolve ;
+M: %%set-slot insn-object obj>> resolve ;
+
+: init-alias-analysis ( -- )
+ H{ } clone histories set
+ H{ } clone vregs>acs set
+ H{ } clone acs>vregs set
+ H{ } clone live-slots set
+ H{ } clone constants set
+ H{ } clone copies set
+
+ 0 ac-counter set
+ next-ac heap-ac set
+
+ %data next-ac set-ac
+ %retain next-ac set-ac ;
+
+GENERIC: analyze-aliases ( insn -- insn' )
+
+M: %iconst analyze-aliases
+ dup [ value>> ] [ out>> ] bi constants get set-at ;
+
+M: %%allot analyze-aliases
+ #! A freshly allocated object is distinct from any other
+ #! object.
+ dup out>> set-new-ac ;
+
+M: read-op analyze-aliases
+ dup out>> set-heap-ac
+ dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
+ 2dup live-slot dup [
+ 2nip %copy boa analyze-aliases nip
+ ] [
+ drop remember-slot
+ ] if ;
+
+: idempotent? ( value slot#/f vreg -- ? )
+ #! Are we storing a value back to the same slot it was read
+ #! from?
+ live-slot = ;
+
+M: write-op analyze-aliases
+ dup
+ [ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
+ 3dup idempotent? [
+ 2drop 2drop nop
+ ] [
+ [ remember-set-slot drop ] [ load-slot ] 3bi
+ ] if ;
+
+M: %copy analyze-aliases
+ #! The output vreg gets the same alias class as the input
+ #! vreg, since they both contain the same value.
+ dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
+
+M: vop analyze-aliases ;
+
+SYMBOL: live-stores
+
+: compute-live-stores ( -- )
+ histories get
+ values [
+ values [ [ store? ] filter [ insn#>> ] map ] map concat
+ ] map concat unique
+ live-stores set ;
+
+GENERIC: eliminate-dead-store ( insn -- insn' )
+
+: (eliminate-dead-store) ( insn -- insn' )
+ dup insn-slot# [
+ insn# get live-stores get key? [
+ drop nop
+ ] unless
+ ] when ;
+
+M: %replace eliminate-dead-store
+ #! Writes to above the top of the stack can be pruned also.
+ #! This is sound since any such writes are not observable
+ #! after the basic block, and any reads of those locations
+ #! will have been converted to copies by analyze-slot,
+ #! and the final stack height of the basic block is set at
+ #! the beginning by compiler.cfg.stack.
+ dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
+
+M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
+
+M: vop eliminate-dead-store ;
+
+: alias-analysis ( insns -- insns' )
+ init-alias-analysis
+ [ insn# set analyze-aliases ] map-index
+ compute-live-stores
+ [ insn# set eliminate-dead-store ] map-index ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: compiler.cfg.builder.tests
+USING: compiler.cfg.builder tools.test ;
+
+\ build-cfg must-infer
--- /dev/null
+! 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 ;
--- /dev/null
+! 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
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces math layouts sequences locals
+combinators compiler.vops compiler.vops.builder
+compiler.cfg.builder ;
+IN: compiler.cfg.elaboration
+
+! This pass must run before conversion to machine IR to ensure
+! correctness.
+
+GENERIC: elaborate* ( insn -- )
+
+: slot-shift ( -- n )
+ tag-bits get cell log2 - ;
+
+:: compute-slot-known-tag ( insn -- addr )
+ { $1 $2 $3 $4 $5 } temps
+ init-intrinsic
+ $1 slot-shift %iconst emit ! load shift offset
+ $2 insn slot>> $1 %shr emit ! shift slot by shift offset
+ $3 insn tag>> %iconst emit ! load tag number
+ $4 $2 $3 %isub emit
+ $5 insn obj>> $4 %iadd emit ! compute slot offset
+ $5
+ ;
+
+:: compute-slot-any-tag ( insn -- addr )
+ { $1 $2 $3 $4 } temps
+ init-intrinsic
+ $1 insn obj>> emit-untag ! untag object
+ $2 slot-shift %iconst emit ! load shift offset
+ $3 insn slot>> $2 %shr emit ! shift slot by shift offset
+ $4 $1 $3 %iadd emit ! compute slot offset
+ $4
+ ;
+
+: compute-slot ( insn -- addr )
+ dup tag>> [ compute-slot-known-tag ] [ compute-slot-any-tag ] if ;
+
+M: %%slot elaborate*
+ [ out>> ] [ compute-slot ] bi %load emit ;
+
+M: %%set-slot elaborate*
+ [ in>> ] [ compute-slot ] bi %store emit ;
+
+M: object elaborate* , ;
+
+: elaboration ( insns -- insns )
+ [ [ elaborate* ] each ] { } make ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel compiler.vops ;
+IN: compiler.cfg.kill-nops
+
+! Smallest compiler pass ever.
+
+: kill-nops ( instructions -- instructions' )
+ [ nop? not ] filter ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors math.order sequences
+compiler.vops ;
+IN: compiler.cfg.live-ranges
+
+TUPLE: live-range from to ;
+
+! Maps vregs to live ranges
+SYMBOL: live-ranges
+
+: def ( n vreg -- )
+ [ dup live-range boa ] dip live-ranges get set-at ;
+
+: use ( n vreg -- )
+ live-ranges get at [ max ] change-to drop ;
+
+GENERIC: compute-live-ranges* ( n insn -- )
+
+M: nullary-op compute-live-ranges*
+ 2drop ;
+
+M: flushable-op compute-live-ranges*
+ out>> def ;
+
+M: effect-op compute-live-ranges*
+ in>> use ;
+
+M: unary-op compute-live-ranges*
+ [ out>> def ] [ in>> use ] 2bi ;
+
+M: binary-op compute-live-ranges*
+ [ call-next-method ] [ in1>> use ] [ in2>> use ] 2tri ;
+
+M: %store compute-live-ranges*
+ [ call-next-method ] [ addr>> use ] 2bi ;
+
+: compute-live-ranges ( insns -- )
+ H{ } clone live-ranges set
+ [ swap compute-live-ranges* ] each-index ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg kernel accessors sequences ;
+IN: compiler.cfg.predecessors
+
+! Pass to compute precedecessors.
+
+: compute-predecessors ( procedure -- )
+ [
+ dup successors>>
+ [ predecessors>> push ] with each
+ ] each-block ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences kernel
+compiler.cfg
+compiler.cfg.predecessors
+compiler.cfg.stack
+compiler.cfg.alias
+compiler.cfg.write-barrier
+compiler.cfg.elaboration
+compiler.cfg.vn
+compiler.cfg.vn.conditions
+compiler.cfg.kill-nops ;
+IN: compiler.cfg.simplifier
+
+: simplify ( insns -- insns' )
+ normalize-height
+ alias-analysis
+ elaboration
+ value-numbering
+ eliminate-write-barrier
+ kill-nops ;
+
+: simplify-cfg ( procedure -- procedure )
+ dup compute-predecessors
+ dup [ [ simplify ] change-instructions drop ] each-block ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math namespaces sequences kernel fry
+compiler.vops ;
+IN: compiler.cfg.stack
+
+! Combine multiple stack height changes into one, done at the
+! start of the basic block.
+!
+! Alias analysis and value numbering assume this optimization
+! has been performed.
+
+! Current data and retain stack height is stored in
+! %data, %retain variables.
+GENERIC: compute-heights ( insn -- )
+
+M: %height compute-heights
+ [ n>> ] [ stack>> ] bi [ + ] change ;
+
+M: object compute-heights drop ;
+
+GENERIC: normalize-height* ( insn -- insn )
+
+M: %height normalize-height*
+ [ n>> ] [ stack>> ] bi [ swap - ] change nop ;
+
+: (normalize-height) ( insn -- insn )
+ dup stack>> get '[ , + ] change-n ; inline
+
+M: %peek normalize-height* (normalize-height) ;
+
+M: %replace normalize-height* (normalize-height) ;
+
+M: object normalize-height* ;
+
+: normalize-height ( insns -- insns' )
+ 0 %data set
+ 0 %retain set
+ [ [ compute-heights ] each ]
+ [ [ [ normalize-height* ] map ] with-scope ] bi
+ %data get dup zero? [ drop ] [ %data %height boa prefix ] if
+ %retain get dup zero? [ drop ] [ %retain %height boa prefix ] if ;
--- /dev/null
+Low-level optimizer operating on control flow graph SSA IR
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences layouts accessors compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions
+compiler.cfg.vn.liveness
+compiler.cfg.vn ;
+IN: compiler.cfg.vn.conditions
+
+! The CFG generator produces naive code for the following code
+! sequence:
+!
+! fixnum< [ ... ] [ ... ] if
+!
+! The fixnum< comparison generates a boolean, which is then
+! tested against f.
+!
+! Using value numbering, we optimize the comparison of a boolean
+! against f where the boolean is the result of comparison.
+
+: expr-f? ( expr -- ? )
+ dup op>> %iconst eq?
+ [ value>> \ f tag-number = ] [ drop f ] if ;
+
+: comparison-with-f? ( insn -- expr/f ? )
+ #! The expr is a binary-op %icmp or %fcmp.
+ dup code>> cc/= eq? [
+ in>> vreg>vn vn>expr dup in2>> vn>expr expr-f?
+ ] [ drop f f ] if ;
+
+: of-boolean? ( expr -- expr/f ? )
+ #! The expr is a binary-op %icmp or %fcmp.
+ in1>> vn>expr dup op>> { %%iboolean %%fboolean } memq? ;
+
+: original-comparison ( expr -- in/f code/f )
+ [ in>> vn>vreg ] [ code>> ] bi ;
+
+: eliminate-boolean ( insn -- in/f code/f )
+ comparison-with-f? [
+ of-boolean? [
+ original-comparison
+ ] [ drop f f ] if
+ ] [ drop f f ] if ;
+
+M: cond-branch make-value-node
+ #! If the conditional branch is testing the result of an
+ #! earlier comparison against f, we only mark as live the
+ #! earlier comparison, so DCE will eliminate the boolean.
+ dup eliminate-boolean drop swap in>> or live-vreg ;
+
+M: cond-branch eliminate
+ dup eliminate-boolean dup
+ [ [ >>in ] [ >>code ] bi* ] [ 2drop ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel compiler.vops compiler.cfg.vn.graph
+compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.constant-fold
+
+GENERIC: constant-fold ( insn -- insn' )
+
+M: vop constant-fold ;
+
+: expr>insn ( out constant-expr -- constant-op )
+ [ value>> ] [ op>> ] bi new swap >>value swap >>out ;
+
+M: pure-op constant-fold
+ dup out>>
+ dup vreg>vn vn>expr
+ dup constant-expr? [ expr>insn nip ] [ 2drop ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes kernel math namespaces sorting
+compiler.vops compiler.cfg.vn.graph ;
+IN: compiler.cfg.vn.expressions
+
+! Referentially-transparent expressions
+TUPLE: expr op ;
+TUPLE: nullary-expr < expr ;
+TUPLE: unary-expr < expr in ;
+TUPLE: binary-expr < expr in1 in2 ;
+TUPLE: commutative-expr < binary-expr ;
+TUPLE: boolean-expr < unary-expr code ;
+TUPLE: constant-expr < expr value ;
+TUPLE: literal-expr < unary-expr object ;
+
+! op is always %peek
+TUPLE: peek-expr < expr loc ;
+
+SYMBOL: input-expr-counter
+
+: next-input-expr ( -- n )
+ input-expr-counter [ dup 1 + ] change ;
+
+! Expressions whose values are inputs to the basic block. We
+! can eliminate a second computation having the same 'n' as
+! the first one; we can also eliminate input-exprs whose
+! result is not used.
+TUPLE: input-expr < expr n ;
+
+GENERIC: >expr ( insn -- expr )
+
+M: %literal-table >expr
+ class nullary-expr boa ;
+
+M: constant-op >expr
+ [ class ] [ value>> ] bi constant-expr boa ;
+
+M: %literal >expr
+ [ class ] [ in>> vreg>vn ] [ object>> ] tri literal-expr boa ;
+
+M: unary-op >expr
+ [ class ] [ in>> vreg>vn ] bi unary-expr boa ;
+
+M: binary-op >expr
+ [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
+ binary-expr boa ;
+
+M: commutative-op >expr
+ [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
+ sort-pair commutative-expr boa ;
+
+M: boolean-op >expr
+ [ class ] [ in>> vreg>vn ] [ code>> ] tri
+ boolean-expr boa ;
+
+M: %peek >expr
+ [ class ] [ stack-loc ] bi peek-expr boa ;
+
+M: flushable-op >expr
+ class next-input-expr input-expr boa ;
+
+: init-expressions ( -- )
+ 0 input-expr-counter set ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces assocs biassocs accessors
+math.order prettyprint.backend parser ;
+IN: compiler.cfg.vn.graph
+
+TUPLE: vn n ;
+
+SYMBOL: vn-counter
+
+: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
+
+: VN: scan-word vn boa parsed ; parsing
+
+M: vn <=> [ n>> ] compare ;
+
+M: vn pprint* \ VN: pprint-word n>> pprint* ;
+
+! biassoc mapping expressions to value numbers
+SYMBOL: exprs>vns
+
+: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
+
+: vn>expr ( vn -- expr ) exprs>vns get value-at ;
+
+SYMBOL: vregs>vns
+
+: vreg>vn ( vreg -- vn ) vregs>vns get at ;
+
+: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
+
+: set-vn ( vn vreg -- ) vregs>vns get set-at ;
+
+: init-value-graph ( -- )
+ 0 vn-counter set
+ <bihash> exprs>vns set
+ <bihash> vregs>vns set ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel assocs sets accessors compiler.vops
+compiler.cfg.vn.graph compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.liveness
+
+! A set of VNs which are (transitively) used by effect-ops. This
+! is precisely the set of VNs whose value is needed outside of
+! the basic block.
+SYMBOL: live-vns
+
+GENERIC: live-expr ( expr -- )
+
+: live-vn ( vn -- )
+ #! Mark a VN and all VNs used in its computation as live.
+ dup live-vns get key? [ drop ] [
+ [ live-vns get conjoin ] [ vn>expr live-expr ] bi
+ ] if ;
+
+: live-vreg ( vreg -- ) vreg>vn live-vn ;
+
+M: expr live-expr drop ;
+M: literal-expr live-expr in>> live-vn ;
+M: unary-expr live-expr in>> live-vn ;
+M: binary-expr live-expr [ in1>> live-vn ] [ in2>> live-vn ] bi ;
+
+: live? ( vreg -- ? )
+ dup vreg>vn tuck vn>vreg =
+ [ live-vns get key? ] [ drop f ] if ;
+
+: init-liveness ( -- )
+ H{ } clone live-vns set ;
+
+GENERIC: eliminate ( insn -- insn' )
+
+M: flushable-op eliminate dup out>> live? ?nop ;
+M: vop eliminate ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs sequences kernel accessors
+compiler.vops
+compiler.cfg.vn.graph ;
+IN: compiler.cfg.vn.propagate
+
+! If two vregs compute the same value, replace references to
+! the latter with the former.
+
+: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
+
+GENERIC: propogate ( insn -- insn )
+
+M: effect-op propogate
+ [ resolve ] change-in ;
+
+M: unary-op propogate
+ [ resolve ] change-in ;
+
+M: binary-op propogate
+ [ resolve ] change-in1
+ [ resolve ] change-in2 ;
+
+M: %phi propogate
+ [ [ resolve ] map ] change-in ;
+
+M: %%slot propogate
+ [ resolve ] change-obj
+ [ resolve ] change-slot ;
+
+M: %%set-slot propogate
+ call-next-method
+ [ resolve ] change-obj
+ [ resolve ] change-slot ;
+
+M: %store propogate
+ call-next-method
+ [ resolve ] change-addr ;
+
+M: nullary-op propogate ;
+
+M: flushable-op propogate ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators classes math math.order
+layouts locals
+compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.simplify
+
+! Return value of f means we didn't simplify.
+GENERIC: simplify* ( expr -- vn/expr/f )
+
+: constant ( val type -- expr ) swap constant-expr boa ;
+
+: simplify-not ( in -- vn/expr/f )
+ {
+ { [ dup constant-expr? ] [ value>> bitnot %iconst constant ] }
+ { [ dup op>> %not = ] [ in>> ] }
+ [ drop f ]
+ } cond ;
+
+: simplify-box-float ( in -- vn/expr/f )
+ {
+ { [ dup op>> %%unbox-float = ] [ in>> ] }
+ [ drop f ]
+ } cond ;
+
+: simplify-unbox-float ( in -- vn/expr/f )
+ {
+ { [ dup literal-expr? ] [ object>> %fconst constant ] }
+ { [ dup op>> %%box-float = ] [ in>> ] }
+ [ drop f ]
+ } cond ;
+
+M: unary-expr simplify*
+ #! Note the copy propagation: a %copy always simplifies to
+ #! its source vn.
+ [ in>> vn>expr ] [ op>> ] bi {
+ { %copy [ ] }
+ { %not [ simplify-not ] }
+ { %%box-float [ simplify-box-float ] }
+ { %%unbox-float [ simplify-unbox-float ] }
+ [ 2drop f ]
+ } case ;
+
+: izero? ( expr -- ? ) T{ constant-expr f %iconst 0 } = ;
+
+: ione? ( expr -- ? ) T{ constant-expr f %iconst 1 } = ;
+
+: ineg-one? ( expr -- ? ) T{ constant-expr f %iconst -1 } = ;
+
+: fzero? ( expr -- ? ) T{ constant-expr f %fconst 0 } = ;
+
+: fone? ( expr -- ? ) T{ constant-expr f %fconst 1 } = ;
+
+: fneg-one? ( expr -- ? ) T{ constant-expr f %fconst -1 } = ;
+
+: identity ( in1 in2 val type -- expr ) constant 2nip ;
+
+: constant-fold? ( in1 in2 -- ? )
+ [ constant-expr? ] both? ;
+
+:: constant-fold ( in1 in2 quot type -- expr )
+ in1 in2 constant-fold?
+ [ in1 value>> in2 value>> quot call type constant ]
+ [ f ]
+ if ; inline
+
+: simplify-iadd ( in1 in2 -- vn/expr/f )
+ {
+ { [ over izero? ] [ nip ] }
+ { [ dup izero? ] [ drop ] }
+ [ [ + ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-imul ( in1 in2 -- vn/expr/f )
+ {
+ { [ over ione? ] [ nip ] }
+ { [ dup ione? ] [ drop ] }
+ [ [ * ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-and ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ 0 %iconst identity ] }
+ { [ dup ineg-one? ] [ drop ] }
+ { [ 2dup = ] [ drop ] }
+ [ [ bitand ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-or ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ dup ineg-one? ] [ -1 %iconst identity ] }
+ { [ 2dup = ] [ drop ] }
+ [ [ bitor ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-xor ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ [ [ bitxor ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-fadd ( in1 in2 -- vn/expr/f )
+ {
+ { [ over fzero? ] [ nip ] }
+ { [ dup fzero? ] [ drop ] }
+ [ [ + ] %fconst constant-fold ]
+ } cond ;
+
+: simplify-fmul ( in1 in2 -- vn/expr/f )
+ {
+ { [ over fone? ] [ nip ] }
+ { [ dup fone? ] [ drop ] }
+ [ [ * ] %fconst constant-fold ]
+ } cond ;
+
+: commutative-operands ( expr -- in1 in2 )
+ [ in1>> vn>expr ] [ in2>> vn>expr ] bi
+ over constant-expr? [ swap ] when ;
+
+M: commutative-expr simplify*
+ [ commutative-operands ] [ op>> ] bi {
+ { %iadd [ simplify-iadd ] }
+ { %imul [ simplify-imul ] }
+ { %and [ simplify-and ] }
+ { %or [ simplify-or ] }
+ { %xor [ simplify-xor ] }
+ { %fadd [ simplify-fadd ] }
+ { %fmul [ simplify-fmul ] }
+ [ 3drop f ]
+ } case ;
+
+: simplify-isub ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ 2dup = ] [ 0 %iconst identity ] }
+ [ [ - ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-idiv ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup ione? ] [ drop ] }
+ [ [ /i ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-imod ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup ione? ] [ 0 %iconst identity ] }
+ { [ 2dup = ] [ 0 %iconst identity ] }
+ [ [ mod ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-shl ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ over izero? ] [ drop ] }
+ [ [ shift ] %iconst constant-fold ]
+ } cond ;
+
+: unsigned ( n -- n' )
+ cell-bits 2^ 1- bitand ;
+
+: useless-shift? ( in1 in2 -- ? )
+ over op>> %shl = [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ;
+
+: simplify-shr ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ over izero? ] [ drop ] }
+ { [ 2dup useless-shift? ] [ drop in1>> ] }
+ [ [ neg shift unsigned ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-sar ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ over izero? ] [ drop ] }
+ { [ 2dup useless-shift? ] [ drop in1>> ] }
+ [ [ neg shift ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-icmp ( in1 in2 -- vn/expr/f )
+ = [ +eq+ %cconst constant ] [ f ] if ;
+
+: simplify-fsub ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ [ [ - ] %fconst constant-fold ]
+ } cond ;
+
+: simplify-fdiv ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup fone? ] [ drop ] }
+ [ [ /i ] %fconst constant-fold ]
+ } cond ;
+
+M: binary-expr simplify*
+ [ in1>> vn>expr ] [ in2>> vn>expr ] [ op>> ] tri {
+ { %isub [ simplify-isub ] }
+ { %idiv [ simplify-idiv ] }
+ { %imod [ simplify-imod ] }
+ { %shl [ simplify-shl ] }
+ { %shr [ simplify-shr ] }
+ { %sar [ simplify-sar ] }
+ { %icmp [ simplify-icmp ] }
+ { %fsub [ simplify-fsub ] }
+ { %fdiv [ simplify-fdiv ] }
+ [ 3drop f ]
+ } case ;
+
+M: expr simplify* drop f ;
+
+: simplify ( expr -- vn )
+ dup simplify* {
+ { [ dup not ] [ drop expr>vn ] }
+ { [ dup expr? ] [ expr>vn nip ] }
+ { [ dup vn? ] [ nip ] }
+ } cond ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs biassocs classes kernel math accessors
+sorting sets sequences compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions
+compiler.cfg.vn.simplify
+compiler.cfg.vn.liveness
+compiler.cfg.vn.constant-fold
+compiler.cfg.vn.propagate ;
+IN: compiler.cfg.vn
+
+: insn>vn ( insn -- vn ) >expr simplify ; inline
+
+GENERIC: make-value-node ( insn -- )
+M: flushable-op make-value-node [ insn>vn ] [ out>> ] bi set-vn ;
+M: effect-op make-value-node in>> live-vreg ;
+M: %store make-value-node [ in>> live-vreg ] [ addr>> live-vreg ] bi ;
+M: %%set-slot make-value-node [ in>> live-vreg ] [ obj>> live-vreg ] bi ;
+M: nullary-op make-value-node drop ;
+
+: init-value-numbering ( -- )
+ init-value-graph
+ init-expressions
+ init-liveness ;
+
+: value-numbering ( instructions -- instructions )
+ init-value-numbering
+ [ [ make-value-node ] each ]
+ [ [ eliminate constant-fold propogate ] map ]
+ bi ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sets sequences
+compiler.vops compiler.cfg ;
+IN: compiler.cfg.write-barrier
+
+! Eliminate redundant write barrier hits.
+SYMBOL: hits
+
+GENERIC: eliminate-write-barrier* ( insn -- insn' )
+
+M: %%allot eliminate-write-barrier*
+ dup out>> hits get conjoin ;
+
+M: %write-barrier eliminate-write-barrier*
+ dup in>> hits get key?
+ [ drop nop ] [ dup in>> hits get conjoin ] if ;
+
+M: %copy eliminate-write-barrier*
+ dup in/out hits get copy-at ;
+
+M: vop eliminate-write-barrier* ;
+
+: eliminate-write-barrier ( insns -- insns )
+ H{ } clone hits set
+ [ eliminate-write-barrier* ] map ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs hashtables sequences
-accessors vectors combinators sets compiler.vops compiler.cfg ;
-IN: compiler.cfg.alias
-
-! Alias analysis -- must be run after compiler.cfg.stack.
-!
-! We try to eliminate redundant slot and stack
-! traffic using some simple heuristics.
-!
-! All heap-allocated objects which are loaded from the stack, or
-! other object slots are pessimistically assumed to belong to
-! the same alias class.
-!
-! Freshly-allocated objects get their own alias class.
-!
-! The data and retain stack pointer registers are treated
-! uniformly, and each one gets its own alias class.
-!
-! Simple pseudo-C example showing load elimination:
-!
-! int *x, *y, z: inputs
-! int a, b, c, d, e: locals
-!
-! Before alias analysis:
-!
-! a = x[2]
-! b = x[2]
-! c = x[3]
-! y[2] = z
-! d = x[2]
-! e = y[2]
-! f = x[3]
-!
-! After alias analysis:
-!
-! a = x[2]
-! b = a /* ELIMINATED */
-! c = x[3]
-! y[2] = z
-! d = x[2] /* if x=y, d=z, if x!=y, d=b; NOT ELIMINATED */
-! e = z /* ELIMINATED */
-! f = c /* ELIMINATED */
-!
-! Simple pseudo-C example showing store elimination:
-!
-! Before alias analysis:
-!
-! x[0] = a
-! b = x[n]
-! x[0] = c
-! x[1] = d
-! e = x[0]
-! x[1] = c
-!
-! After alias analysis:
-!
-! x[0] = a /* dead if n = 0, live otherwise; NOT ELIMINATED */
-! b = x[n]
-! x[0] = c
-! /* x[1] = d */ /* ELIMINATED */
-! e = c
-! x[1] = c
-
-! Map vregs -> alias classes
-SYMBOL: vregs>acs
-
-: check [ "BUG: static type error detected" throw ] unless* ; inline
-
-: vreg>ac ( vreg -- ac )
- #! Only vregs produced by %%allot, %peek and %%slot can
- #! ever be used as valid inputs to %%slot and %%set-slot,
- #! so we assert this fact by not giving alias classes to
- #! other vregs.
- vregs>acs get at check ;
-
-! Map alias classes -> sequence of vregs
-SYMBOL: acs>vregs
-
-: ac>vregs ( ac -- vregs ) acs>vregs get at ;
-
-: aliases ( vreg -- vregs )
- #! All vregs which may contain the same value as vreg.
- vreg>ac ac>vregs ;
-
-: each-alias ( vreg quot -- )
- [ aliases ] dip each ; inline
-
-! Map vregs -> slot# -> vreg
-SYMBOL: live-slots
-
-! Current instruction number
-SYMBOL: insn#
-
-! Load/store history, for dead store elimination
-TUPLE: load insn# ;
-TUPLE: store insn# ;
-
-: new-action ( class -- action )
- insn# get swap boa ; inline
-
-! Maps vreg -> slot# -> sequence of loads/stores
-SYMBOL: histories
-
-: history ( vreg -- history ) histories get at ;
-
-: set-ac ( vreg ac -- )
- #! Set alias class of newly-seen vreg.
- {
- [ drop H{ } clone swap histories get set-at ]
- [ drop H{ } clone swap live-slots get set-at ]
- [ swap vregs>acs get set-at ]
- [ acs>vregs get push-at ]
- } 2cleave ;
-
-: live-slot ( slot#/f vreg -- vreg' )
- #! If the slot number is unknown, we never reuse a previous
- #! value.
- over [ live-slots get at at ] [ 2drop f ] if ;
-
-: load-constant-slot ( value slot# vreg -- )
- live-slots get at check set-at ;
-
-: load-slot ( value slot#/f vreg -- )
- over [ load-constant-slot ] [ 3drop ] if ;
-
-: record-constant-slot ( slot# vreg -- )
- #! A load can potentially read every store of this slot#
- #! in that alias class.
- [
- history [ load new-action swap ?push ] change-at
- ] with each-alias ;
-
-: record-computed-slot ( vreg -- )
- #! Computed load is like a load of every slot touched so far
- [
- history values [ load new-action swap push ] each
- ] each-alias ;
-
-: remember-slot ( value slot#/f vreg -- )
- over
- [ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
- [ 2nip record-computed-slot ] if ;
-
-SYMBOL: ac-counter
-
-: next-ac ( -- n )
- ac-counter [ dup 1+ ] change ;
-
-! Alias class for objects which are loaded from the data stack
-! or other object slots. We pessimistically assume that they
-! can all alias each other.
-SYMBOL: heap-ac
-
-: set-heap-ac ( vreg -- ) heap-ac get set-ac ;
-
-: set-new-ac ( vreg -- ) next-ac set-ac ;
-
-: kill-constant-set-slot ( slot# vreg -- )
- [ live-slots get at delete-at ] with each-alias ;
-
-: record-constant-set-slot ( slot# vreg -- )
- history [
- dup empty? [ dup peek store? [ dup pop* ] when ] unless
- store new-action swap ?push
- ] change-at ;
-
-: kill-computed-set-slot ( ac -- )
- [ live-slots get at clear-assoc ] each-alias ;
-
-: remember-set-slot ( slot#/f vreg -- )
- over [
- [ record-constant-set-slot ]
- [ kill-constant-set-slot ] 2bi
- ] [ nip kill-computed-set-slot ] if ;
-
-SYMBOL: copies
-
-: resolve ( vreg -- vreg )
- dup copies get at swap or ;
-
-SYMBOL: constants
-
-: constant ( vreg -- n/f )
- #! Return an %iconst value, or f if the vreg was not
- #! assigned by an %iconst.
- resolve constants get at ;
-
-! We treat slot accessors and stack traffic alike
-GENERIC: insn-slot# ( insn -- slot#/f )
-GENERIC: insn-object ( insn -- vreg )
-
-M: %peek insn-slot# n>> ;
-M: %replace insn-slot# n>> ;
-M: %%slot insn-slot# slot>> constant ;
-M: %%set-slot insn-slot# slot>> constant ;
-
-M: %peek insn-object stack>> ;
-M: %replace insn-object stack>> ;
-M: %%slot insn-object obj>> resolve ;
-M: %%set-slot insn-object obj>> resolve ;
-
-: init-alias-analysis ( -- )
- H{ } clone histories set
- H{ } clone vregs>acs set
- H{ } clone acs>vregs set
- H{ } clone live-slots set
- H{ } clone constants set
- H{ } clone copies set
-
- 0 ac-counter set
- next-ac heap-ac set
-
- %data next-ac set-ac
- %retain next-ac set-ac ;
-
-GENERIC: analyze-aliases ( insn -- insn' )
-
-M: %iconst analyze-aliases
- dup [ value>> ] [ out>> ] bi constants get set-at ;
-
-M: %%allot analyze-aliases
- #! A freshly allocated object is distinct from any other
- #! object.
- dup out>> set-new-ac ;
-
-M: read-op analyze-aliases
- dup out>> set-heap-ac
- dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
- 2dup live-slot dup [
- 2nip %copy boa analyze-aliases nip
- ] [
- drop remember-slot
- ] if ;
-
-: idempotent? ( value slot#/f vreg -- ? )
- #! Are we storing a value back to the same slot it was read
- #! from?
- live-slot = ;
-
-M: write-op analyze-aliases
- dup
- [ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
- 3dup idempotent? [
- 2drop 2drop nop
- ] [
- [ remember-set-slot drop ] [ load-slot ] 3bi
- ] if ;
-
-M: %copy analyze-aliases
- #! The output vreg gets the same alias class as the input
- #! vreg, since they both contain the same value.
- dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
-
-M: vop analyze-aliases ;
-
-SYMBOL: live-stores
-
-: compute-live-stores ( -- )
- histories get
- values [
- values [ [ store? ] filter [ insn#>> ] map ] map concat
- ] map concat unique
- live-stores set ;
-
-GENERIC: eliminate-dead-store ( insn -- insn' )
-
-: (eliminate-dead-store) ( insn -- insn' )
- dup insn-slot# [
- insn# get live-stores get key? [
- drop nop
- ] unless
- ] when ;
-
-M: %replace eliminate-dead-store
- #! Writes to above the top of the stack can be pruned also.
- #! This is sound since any such writes are not observable
- #! after the basic block, and any reads of those locations
- #! will have been converted to copies by analyze-slot,
- #! and the final stack height of the basic block is set at
- #! the beginning by compiler.cfg.stack.
- dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
-
-M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
-
-M: vop eliminate-dead-store ;
-
-: alias-analysis ( insns -- insns' )
- init-alias-analysis
- [ insn# set analyze-aliases ] map-index
- compute-live-stores
- [ insn# set eliminate-dead-store ] map-index ;
+++ /dev/null
-Slava Pestov
--- /dev/null
+Slava Pestov
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
-! 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
- begin-basic-block
- basic-block get swap procedures get set-at
- convert-nodes ;
+USE: qualified
+FROM: compiler.generator.registers => +input+ ;
+FROM: compiler.generator.registers => +output+ ;
+FROM: compiler.generator.registers => +scratch+ ;
+FROM: compiler.generator.registers => +clobber+ ;
-: build-cfg ( node word -- procedures )
- H{ } clone [
- procedures [ (build-cfg) ] with-variable
- ] keep ;
+SYMBOL: procedures
-: value>vreg ( value -- vreg )
- values>vregs get at ;
+SYMBOL: current-word
-: output-vreg ( value vreg -- )
- swap values>vregs get set-at ;
+SYMBOL: current-label
-: produce-vreg ( value -- vreg )
- next-vreg [ output-vreg ] keep ;
+SYMBOL: loops
-: (load-inputs) ( seq stack -- )
- over empty? [ 2drop ] [
- [ <reversed> ] dip
- [ '[ produce-vreg _ , %peek emit ] each-index ]
- [ [ length neg ] dip %height emit ]
- 2bi
- ] if ;
+! Basic block after prologue, makes recursion faster
+SYMBOL: current-label-start
-: load-in-d ( node -- ) in-d>> %data (load-inputs) ;
+: add-procedure ( -- )
+ basic-block get current-word get current-label get
+ <procedure> procedures get push ;
-: load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
+: begin-procedure ( word label -- )
+ end-basic-block
+ begin-basic-block
+ H{ } clone loops set
+ current-label set
+ current-word set
+ add-procedure ;
-: (store-outputs) ( seq stack -- )
- over empty? [ 2drop ] [
- [ <reversed> ] dip
- [ [ length ] dip %height emit ]
- [ '[ value>vreg _ , %replace emit ] each-index ]
- 2bi
- ] if ;
+: with-cfg-builder ( nodes word label quot -- )
+ '[ begin-procedure @ ] with-scope ; inline
-: store-out-d ( node -- ) out-d>> %data (store-outputs) ;
+GENERIC: emit-node ( node -- next )
-: store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
+: check-basic-block ( node -- node' )
+ basic-block get [ drop f ] unless ; inline
-: (emit-call) ( word -- )
- begin-basic-block %call emit begin-basic-block ;
+: emit-nodes ( nodes -- )
+ [ current-node emit-node check-basic-block ] iterate-nodes
+ finalize-phantoms ;
-: intrinsic-inputs ( node -- )
- [ load-in-d ]
- [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
- bi ;
+: remember-loop ( label -- )
+ basic-block get swap loops get set-at ;
-: intrinsic-outputs ( node -- )
- [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
- [ store-out-d ]
- bi ;
+: 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 ;
-: intrinsic ( node quot -- )
+: (build-cfg) ( nodes word label -- )
[
- init-intrinsic
+ begin-word
+ [ emit-nodes ] with-node-iterator
+ ] with-cfg-builder ;
+
+: build-cfg ( nodes word label -- procedures )
+ V{ } clone [
+ procedures [
+ (build-cfg)
+ ] with-variable
+ ] keep ;
- [ intrinsic-inputs ]
- swap
- [ intrinsic-outputs ]
- tri
- ] with-scope ; inline
+: if-intrinsics ( #call -- quot )
+ word>> "if-intrinsics" word-prop ;
+
+: local-recursive-call ( basic-block -- )
+ %branch
+ basic-block get successors>> push
+ end-basic-block ;
+
+: 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 ;
+
+! #recursive
+: compile-recursive ( node -- next )
+ [ label>> id>> emit-call ]
+ [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
+
+: compile-loop ( node -- next )
+ finalize-phantoms
+ begin-basic-block
+ [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
+ iterate-next ;
-USING: kernel.private math.private slots.private ;
+M: #recursive emit-node
+ dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
-: 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 ;
+! #if
+: emit-branch ( nodes -- final-bb )
+ [
+ begin-basic-block copy-phantoms
+ emit-nodes
+ basic-block get dup [ %branch ] when
+ ] with-scope ;
-: 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
+: emit-if ( node -- next )
+ children>> [ emit-branch ] map
end-basic-block
- basic-block off
- drop ;
-
-: emit-call-recursive ( #recursive -- )
- label>> id>> (emit-call) ;
+ 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 ;
-M: #call-recursive convert
- dup label>> loop?>>
- [ emit-call-loop ] [ emit-call-recursive ] if ;
+: 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 ;
-M: #push convert
- [
- [ out-d>> first produce-vreg ]
- [ node-output-infos first literal>> ]
- bi emit-literal
- ]
- [ store-out-d ] bi ;
+! #call
+: define-intrinsics ( word intrinsics -- )
+ "intrinsics" set-word-prop ;
-M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
+: define-intrinsic ( word quot assoc -- )
+ 2array 1array define-intrinsics ;
-M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
+: define-if-intrinsics ( word intrinsics -- )
+ [ +input+ associate ] assoc-map
+ "if-intrinsics" set-word-prop ;
-M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
+: define-if-intrinsic ( word quot inputs -- )
+ 2array 1array define-if-intrinsics ;
-M: #terminate convert drop ;
+: find-intrinsic ( #call -- pair/f )
+ word>> "intrinsics" word-prop find-template ;
-: integer-conditional ( in1 in2 cc -- )
- [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
+: find-boolean-intrinsic ( #call -- pair/f )
+ word>> "if-intrinsics" word-prop find-template ;
-: float-conditional ( in1 in2 branch -- )
- [ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
+: find-if-intrinsic ( #call -- pair/f )
+ node@ {
+ { [ dup length 2 < ] [ 2drop f ] }
+ { [ dup second #if? ] [ drop find-boolean-intrinsic ] }
+ [ 2drop f ]
+ } cond ;
-: emit-if ( #if -- )
- in-d>> first value>vreg
- next-vreg dup f emit-literal
- cc/= integer-conditional ;
+: do-if-intrinsic ( pair -- next )
+ [ %if-intrinsic ] apply-template skip-next emit-if ;
-: convert-nested ( node -- last-bb )
+: do-boolean-intrinsic ( pair -- next )
[
- <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 ]
+ 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: #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) ]
+M: #alien-indirect emit-node
+ params>>
+ [ alien-invoke-frame %frame-required ]
+ [ %alien-indirect iterate-next ]
bi ;
-: begin-loop ( #recursive -- )
- label>> basic-block get 2array loop-nesting get push ;
+M: #alien-callback emit-node
+ params>> dup xt>> dup
+ [ init-phantoms %alien-callback ] with-cfg-builder
+ iterate-next ;
-: end-loop ( -- )
- loop-nesting get pop* ;
+! No-op nodes
+M: #introduce emit-node drop iterate-next ;
-: convert-loop ( #recursive -- )
- begin-basic-block
- [ begin-loop ]
- [ child>> convert-nodes ]
- [ drop end-loop ]
- tri ;
+M: #copy emit-node drop iterate-next ;
-M: #recursive convert
- dup label>> loop?>>
- [ convert-loop ] [ convert-recursive ] if ;
+M: #enter-recursive emit-node drop iterate-next ;
-M: #copy convert drop ;
+M: #phi emit-node drop iterate-next ;
--- /dev/null
+Final stage of compilation generates machine code from dataflow IR
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
: (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
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces math layouts sequences locals
-combinators compiler.vops compiler.vops.builder
-compiler.cfg.builder ;
-IN: compiler.cfg.elaboration
-
-! This pass must run before conversion to machine IR to ensure
-! correctness.
-
-GENERIC: elaborate* ( insn -- )
-
-: slot-shift ( -- n )
- tag-bits get cell log2 - ;
-
-:: compute-slot-known-tag ( insn -- addr )
- { $1 $2 $3 $4 $5 } temps
- init-intrinsic
- $1 slot-shift %iconst emit ! load shift offset
- $2 insn slot>> $1 %shr emit ! shift slot by shift offset
- $3 insn tag>> %iconst emit ! load tag number
- $4 $2 $3 %isub emit
- $5 insn obj>> $4 %iadd emit ! compute slot offset
- $5
- ;
-
-:: compute-slot-any-tag ( insn -- addr )
- { $1 $2 $3 $4 } temps
- init-intrinsic
- $1 insn obj>> emit-untag ! untag object
- $2 slot-shift %iconst emit ! load shift offset
- $3 insn slot>> $2 %shr emit ! shift slot by shift offset
- $4 $1 $3 %iadd emit ! compute slot offset
- $4
- ;
-
-: compute-slot ( insn -- addr )
- dup tag>> [ compute-slot-known-tag ] [ compute-slot-any-tag ] if ;
-
-M: %%slot elaborate*
- [ out>> ] [ compute-slot ] bi %load emit ;
-
-M: %%set-slot elaborate*
- [ in>> ] [ compute-slot ] bi %store emit ;
-
-M: object elaborate* , ;
-
-: elaboration ( insns -- insns )
- [ [ elaborate* ] each ] { } make ;
--- /dev/null
+! 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? ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel compiler.vops ;
-IN: compiler.cfg.kill-nops
-
-! Smallest compiler pass ever.
-
-: kill-nops ( instructions -- instructions' )
- [ nop? not ] filter ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs accessors math.order sequences
-compiler.vops ;
-IN: compiler.cfg.live-ranges
-
-TUPLE: live-range from to ;
-
-! Maps vregs to live ranges
-SYMBOL: live-ranges
-
-: def ( n vreg -- )
- [ dup live-range boa ] dip live-ranges get set-at ;
-
-: use ( n vreg -- )
- live-ranges get at [ max ] change-to drop ;
-
-GENERIC: compute-live-ranges* ( n insn -- )
-
-M: nullary-op compute-live-ranges*
- 2drop ;
-
-M: flushable-op compute-live-ranges*
- out>> def ;
-
-M: effect-op compute-live-ranges*
- in>> use ;
-
-M: unary-op compute-live-ranges*
- [ out>> def ] [ in>> use ] 2bi ;
-
-M: binary-op compute-live-ranges*
- [ call-next-method ] [ in1>> use ] [ in2>> use ] 2tri ;
-
-M: %store compute-live-ranges*
- [ call-next-method ] [ addr>> use ] 2bi ;
-
-: compute-live-ranges ( insns -- )
- H{ } clone live-ranges set
- [ swap compute-live-ranges* ] each-index ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg kernel accessors sequences ;
-IN: compiler.cfg.predecessors
-
-! Pass to compute precedecessors.
-
-: compute-predecessors ( procedure -- )
- [
- dup successors>>
- [ predecessors>> push ] with each
- ] each-block ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel
-compiler.cfg
-compiler.cfg.predecessors
-compiler.cfg.stack
-compiler.cfg.alias
-compiler.cfg.write-barrier
-compiler.cfg.elaboration
-compiler.cfg.vn
-compiler.cfg.vn.conditions
-compiler.cfg.kill-nops ;
-IN: compiler.cfg.simplifier
-
-: simplify ( insns -- insns' )
- normalize-height
- alias-analysis
- elaboration
- value-numbering
- eliminate-write-barrier
- kill-nops ;
-
-: simplify-cfg ( procedure -- procedure )
- dup compute-predecessors
- dup [ [ simplify ] change-instructions drop ] each-block ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math namespaces sequences kernel fry
-compiler.vops ;
-IN: compiler.cfg.stack
-
-! Combine multiple stack height changes into one, done at the
-! start of the basic block.
-!
-! Alias analysis and value numbering assume this optimization
-! has been performed.
-
-! Current data and retain stack height is stored in
-! %data, %retain variables.
-GENERIC: compute-heights ( insn -- )
-
-M: %height compute-heights
- [ n>> ] [ stack>> ] bi [ + ] change ;
-
-M: object compute-heights drop ;
-
-GENERIC: normalize-height* ( insn -- insn )
-
-M: %height normalize-height*
- [ n>> ] [ stack>> ] bi [ swap - ] change nop ;
-
-: (normalize-height) ( insn -- insn )
- dup stack>> get '[ , + ] change-n ; inline
-
-M: %peek normalize-height* (normalize-height) ;
-
-M: %replace normalize-height* (normalize-height) ;
-
-M: object normalize-height* ;
-
-: normalize-height ( insns -- insns' )
- 0 %data set
- 0 %retain set
- [ [ compute-heights ] each ]
- [ [ [ normalize-height* ] map ] with-scope ] bi
- %data get dup zero? [ drop ] [ %data %height boa prefix ] if
- %retain get dup zero? [ drop ] [ %retain %height boa prefix ] if ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
+++ /dev/null
-Low-level optimizer operating on control flow graph SSA IR
--- /dev/null
+! 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 ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences layouts accessors compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions
-compiler.cfg.vn.liveness
-compiler.cfg.vn ;
-IN: compiler.cfg.vn.conditions
-
-! The CFG generator produces naive code for the following code
-! sequence:
-!
-! fixnum< [ ... ] [ ... ] if
-!
-! The fixnum< comparison generates a boolean, which is then
-! tested against f.
-!
-! Using value numbering, we optimize the comparison of a boolean
-! against f where the boolean is the result of comparison.
-
-: expr-f? ( expr -- ? )
- dup op>> %iconst eq?
- [ value>> \ f tag-number = ] [ drop f ] if ;
-
-: comparison-with-f? ( insn -- expr/f ? )
- #! The expr is a binary-op %icmp or %fcmp.
- dup code>> cc/= eq? [
- in>> vreg>vn vn>expr dup in2>> vn>expr expr-f?
- ] [ drop f f ] if ;
-
-: of-boolean? ( expr -- expr/f ? )
- #! The expr is a binary-op %icmp or %fcmp.
- in1>> vn>expr dup op>> { %%iboolean %%fboolean } memq? ;
-
-: original-comparison ( expr -- in/f code/f )
- [ in>> vn>vreg ] [ code>> ] bi ;
-
-: eliminate-boolean ( insn -- in/f code/f )
- comparison-with-f? [
- of-boolean? [
- original-comparison
- ] [ drop f f ] if
- ] [ drop f f ] if ;
-
-M: cond-branch make-value-node
- #! If the conditional branch is testing the result of an
- #! earlier comparison against f, we only mark as live the
- #! earlier comparison, so DCE will eliminate the boolean.
- dup eliminate-boolean drop swap in>> or live-vreg ;
-
-M: cond-branch eliminate
- dup eliminate-boolean dup
- [ [ >>in ] [ >>code ] bi* ] [ 2drop ] if ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel compiler.vops compiler.cfg.vn.graph
-compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.constant-fold
-
-GENERIC: constant-fold ( insn -- insn' )
-
-M: vop constant-fold ;
-
-: expr>insn ( out constant-expr -- constant-op )
- [ value>> ] [ op>> ] bi new swap >>value swap >>out ;
-
-M: pure-op constant-fold
- dup out>>
- dup vreg>vn vn>expr
- dup constant-expr? [ expr>insn nip ] [ 2drop ] if ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes kernel math namespaces sorting
-compiler.vops compiler.cfg.vn.graph ;
-IN: compiler.cfg.vn.expressions
-
-! Referentially-transparent expressions
-TUPLE: expr op ;
-TUPLE: nullary-expr < expr ;
-TUPLE: unary-expr < expr in ;
-TUPLE: binary-expr < expr in1 in2 ;
-TUPLE: commutative-expr < binary-expr ;
-TUPLE: boolean-expr < unary-expr code ;
-TUPLE: constant-expr < expr value ;
-TUPLE: literal-expr < unary-expr object ;
-
-! op is always %peek
-TUPLE: peek-expr < expr loc ;
-
-SYMBOL: input-expr-counter
-
-: next-input-expr ( -- n )
- input-expr-counter [ dup 1 + ] change ;
-
-! Expressions whose values are inputs to the basic block. We
-! can eliminate a second computation having the same 'n' as
-! the first one; we can also eliminate input-exprs whose
-! result is not used.
-TUPLE: input-expr < expr n ;
-
-GENERIC: >expr ( insn -- expr )
-
-M: %literal-table >expr
- class nullary-expr boa ;
-
-M: constant-op >expr
- [ class ] [ value>> ] bi constant-expr boa ;
-
-M: %literal >expr
- [ class ] [ in>> vreg>vn ] [ object>> ] tri literal-expr boa ;
-
-M: unary-op >expr
- [ class ] [ in>> vreg>vn ] bi unary-expr boa ;
-
-M: binary-op >expr
- [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
- binary-expr boa ;
-
-M: commutative-op >expr
- [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
- sort-pair commutative-expr boa ;
-
-M: boolean-op >expr
- [ class ] [ in>> vreg>vn ] [ code>> ] tri
- boolean-expr boa ;
-
-M: %peek >expr
- [ class ] [ stack-loc ] bi peek-expr boa ;
-
-M: flushable-op >expr
- class next-input-expr input-expr boa ;
-
-: init-expressions ( -- )
- 0 input-expr-counter set ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs biassocs accessors
-math.order prettyprint.backend parser ;
-IN: compiler.cfg.vn.graph
-
-TUPLE: vn n ;
-
-SYMBOL: vn-counter
-
-: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
-
-: VN: scan-word vn boa parsed ; parsing
-
-M: vn <=> [ n>> ] compare ;
-
-M: vn pprint* \ VN: pprint-word n>> pprint* ;
-
-! biassoc mapping expressions to value numbers
-SYMBOL: exprs>vns
-
-: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
-
-: vn>expr ( vn -- expr ) exprs>vns get value-at ;
-
-SYMBOL: vregs>vns
-
-: vreg>vn ( vreg -- vn ) vregs>vns get at ;
-
-: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
-
-: set-vn ( vn vreg -- ) vregs>vns get set-at ;
-
-: init-value-graph ( -- )
- 0 vn-counter set
- <bihash> exprs>vns set
- <bihash> vregs>vns set ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs sets accessors compiler.vops
-compiler.cfg.vn.graph compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.liveness
-
-! A set of VNs which are (transitively) used by effect-ops. This
-! is precisely the set of VNs whose value is needed outside of
-! the basic block.
-SYMBOL: live-vns
-
-GENERIC: live-expr ( expr -- )
-
-: live-vn ( vn -- )
- #! Mark a VN and all VNs used in its computation as live.
- dup live-vns get key? [ drop ] [
- [ live-vns get conjoin ] [ vn>expr live-expr ] bi
- ] if ;
-
-: live-vreg ( vreg -- ) vreg>vn live-vn ;
-
-M: expr live-expr drop ;
-M: literal-expr live-expr in>> live-vn ;
-M: unary-expr live-expr in>> live-vn ;
-M: binary-expr live-expr [ in1>> live-vn ] [ in2>> live-vn ] bi ;
-
-: live? ( vreg -- ? )
- dup vreg>vn tuck vn>vreg =
- [ live-vns get key? ] [ drop f ] if ;
-
-: init-liveness ( -- )
- H{ } clone live-vns set ;
-
-GENERIC: eliminate ( insn -- insn' )
-
-M: flushable-op eliminate dup out>> live? ?nop ;
-M: vop eliminate ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs sequences kernel accessors
-compiler.vops
-compiler.cfg.vn.graph ;
-IN: compiler.cfg.vn.propagate
-
-! If two vregs compute the same value, replace references to
-! the latter with the former.
-
-: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
-
-GENERIC: propogate ( insn -- insn )
-
-M: effect-op propogate
- [ resolve ] change-in ;
-
-M: unary-op propogate
- [ resolve ] change-in ;
-
-M: binary-op propogate
- [ resolve ] change-in1
- [ resolve ] change-in2 ;
-
-M: %phi propogate
- [ [ resolve ] map ] change-in ;
-
-M: %%slot propogate
- [ resolve ] change-obj
- [ resolve ] change-slot ;
-
-M: %%set-slot propogate
- call-next-method
- [ resolve ] change-obj
- [ resolve ] change-slot ;
-
-M: %store propogate
- call-next-method
- [ resolve ] change-addr ;
-
-M: nullary-op propogate ;
-
-M: flushable-op propogate ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators classes math math.order
-layouts locals
-compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.simplify
-
-! Return value of f means we didn't simplify.
-GENERIC: simplify* ( expr -- vn/expr/f )
-
-: constant ( val type -- expr ) swap constant-expr boa ;
-
-: simplify-not ( in -- vn/expr/f )
- {
- { [ dup constant-expr? ] [ value>> bitnot %iconst constant ] }
- { [ dup op>> %not = ] [ in>> ] }
- [ drop f ]
- } cond ;
-
-: simplify-box-float ( in -- vn/expr/f )
- {
- { [ dup op>> %%unbox-float = ] [ in>> ] }
- [ drop f ]
- } cond ;
-
-: simplify-unbox-float ( in -- vn/expr/f )
- {
- { [ dup literal-expr? ] [ object>> %fconst constant ] }
- { [ dup op>> %%box-float = ] [ in>> ] }
- [ drop f ]
- } cond ;
-
-M: unary-expr simplify*
- #! Note the copy propagation: a %copy always simplifies to
- #! its source vn.
- [ in>> vn>expr ] [ op>> ] bi {
- { %copy [ ] }
- { %not [ simplify-not ] }
- { %%box-float [ simplify-box-float ] }
- { %%unbox-float [ simplify-unbox-float ] }
- [ 2drop f ]
- } case ;
-
-: izero? ( expr -- ? ) T{ constant-expr f %iconst 0 } = ;
-
-: ione? ( expr -- ? ) T{ constant-expr f %iconst 1 } = ;
-
-: ineg-one? ( expr -- ? ) T{ constant-expr f %iconst -1 } = ;
-
-: fzero? ( expr -- ? ) T{ constant-expr f %fconst 0 } = ;
-
-: fone? ( expr -- ? ) T{ constant-expr f %fconst 1 } = ;
-
-: fneg-one? ( expr -- ? ) T{ constant-expr f %fconst -1 } = ;
-
-: identity ( in1 in2 val type -- expr ) constant 2nip ;
-
-: constant-fold? ( in1 in2 -- ? )
- [ constant-expr? ] both? ;
-
-:: constant-fold ( in1 in2 quot type -- expr )
- in1 in2 constant-fold?
- [ in1 value>> in2 value>> quot call type constant ]
- [ f ]
- if ; inline
-
-: simplify-iadd ( in1 in2 -- vn/expr/f )
- {
- { [ over izero? ] [ nip ] }
- { [ dup izero? ] [ drop ] }
- [ [ + ] %iconst constant-fold ]
- } cond ;
-
-: simplify-imul ( in1 in2 -- vn/expr/f )
- {
- { [ over ione? ] [ nip ] }
- { [ dup ione? ] [ drop ] }
- [ [ * ] %iconst constant-fold ]
- } cond ;
-
-: simplify-and ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ 0 %iconst identity ] }
- { [ dup ineg-one? ] [ drop ] }
- { [ 2dup = ] [ drop ] }
- [ [ bitand ] %iconst constant-fold ]
- } cond ;
-
-: simplify-or ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ dup ineg-one? ] [ -1 %iconst identity ] }
- { [ 2dup = ] [ drop ] }
- [ [ bitor ] %iconst constant-fold ]
- } cond ;
-
-: simplify-xor ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- [ [ bitxor ] %iconst constant-fold ]
- } cond ;
-
-: simplify-fadd ( in1 in2 -- vn/expr/f )
- {
- { [ over fzero? ] [ nip ] }
- { [ dup fzero? ] [ drop ] }
- [ [ + ] %fconst constant-fold ]
- } cond ;
-
-: simplify-fmul ( in1 in2 -- vn/expr/f )
- {
- { [ over fone? ] [ nip ] }
- { [ dup fone? ] [ drop ] }
- [ [ * ] %fconst constant-fold ]
- } cond ;
-
-: commutative-operands ( expr -- in1 in2 )
- [ in1>> vn>expr ] [ in2>> vn>expr ] bi
- over constant-expr? [ swap ] when ;
-
-M: commutative-expr simplify*
- [ commutative-operands ] [ op>> ] bi {
- { %iadd [ simplify-iadd ] }
- { %imul [ simplify-imul ] }
- { %and [ simplify-and ] }
- { %or [ simplify-or ] }
- { %xor [ simplify-xor ] }
- { %fadd [ simplify-fadd ] }
- { %fmul [ simplify-fmul ] }
- [ 3drop f ]
- } case ;
-
-: simplify-isub ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ 2dup = ] [ 0 %iconst identity ] }
- [ [ - ] %iconst constant-fold ]
- } cond ;
-
-: simplify-idiv ( in1 in2 -- vn/expr/f )
- {
- { [ dup ione? ] [ drop ] }
- [ [ /i ] %iconst constant-fold ]
- } cond ;
-
-: simplify-imod ( in1 in2 -- vn/expr/f )
- {
- { [ dup ione? ] [ 0 %iconst identity ] }
- { [ 2dup = ] [ 0 %iconst identity ] }
- [ [ mod ] %iconst constant-fold ]
- } cond ;
-
-: simplify-shl ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ over izero? ] [ drop ] }
- [ [ shift ] %iconst constant-fold ]
- } cond ;
-
-: unsigned ( n -- n' )
- cell-bits 2^ 1- bitand ;
-
-: useless-shift? ( in1 in2 -- ? )
- over op>> %shl = [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ;
-
-: simplify-shr ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ over izero? ] [ drop ] }
- { [ 2dup useless-shift? ] [ drop in1>> ] }
- [ [ neg shift unsigned ] %iconst constant-fold ]
- } cond ;
-
-: simplify-sar ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ over izero? ] [ drop ] }
- { [ 2dup useless-shift? ] [ drop in1>> ] }
- [ [ neg shift ] %iconst constant-fold ]
- } cond ;
-
-: simplify-icmp ( in1 in2 -- vn/expr/f )
- = [ +eq+ %cconst constant ] [ f ] if ;
-
-: simplify-fsub ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- [ [ - ] %fconst constant-fold ]
- } cond ;
-
-: simplify-fdiv ( in1 in2 -- vn/expr/f )
- {
- { [ dup fone? ] [ drop ] }
- [ [ /i ] %fconst constant-fold ]
- } cond ;
-
-M: binary-expr simplify*
- [ in1>> vn>expr ] [ in2>> vn>expr ] [ op>> ] tri {
- { %isub [ simplify-isub ] }
- { %idiv [ simplify-idiv ] }
- { %imod [ simplify-imod ] }
- { %shl [ simplify-shl ] }
- { %shr [ simplify-shr ] }
- { %sar [ simplify-sar ] }
- { %icmp [ simplify-icmp ] }
- { %fsub [ simplify-fsub ] }
- { %fdiv [ simplify-fdiv ] }
- [ 3drop f ]
- } case ;
-
-M: expr simplify* drop f ;
-
-: simplify ( expr -- vn )
- dup simplify* {
- { [ dup not ] [ drop expr>vn ] }
- { [ dup expr? ] [ expr>vn nip ] }
- { [ dup vn? ] [ nip ] }
- } cond ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs biassocs classes kernel math accessors
-sorting sets sequences compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions
-compiler.cfg.vn.simplify
-compiler.cfg.vn.liveness
-compiler.cfg.vn.constant-fold
-compiler.cfg.vn.propagate ;
-IN: compiler.cfg.vn
-
-: insn>vn ( insn -- vn ) >expr simplify ; inline
-
-GENERIC: make-value-node ( insn -- )
-M: flushable-op make-value-node [ insn>vn ] [ out>> ] bi set-vn ;
-M: effect-op make-value-node in>> live-vreg ;
-M: %store make-value-node [ in>> live-vreg ] [ addr>> live-vreg ] bi ;
-M: %%set-slot make-value-node [ in>> live-vreg ] [ obj>> live-vreg ] bi ;
-M: nullary-op make-value-node drop ;
-
-: init-value-numbering ( -- )
- init-value-graph
- init-expressions
- init-liveness ;
-
-: value-numbering ( instructions -- instructions )
- init-value-numbering
- [ [ make-value-node ] each ]
- [ [ eliminate constant-fold propogate ] map ]
- bi ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets sequences
-compiler.vops compiler.cfg ;
-IN: compiler.cfg.write-barrier
-
-! Eliminate redundant write barrier hits.
-SYMBOL: hits
-
-GENERIC: eliminate-write-barrier* ( insn -- insn' )
-
-M: %%allot eliminate-write-barrier*
- dup out>> hits get conjoin ;
-
-M: %write-barrier eliminate-write-barrier*
- dup in>> hits get key?
- [ drop nop ] [ dup in>> hits get conjoin ] if ;
-
-M: %copy eliminate-write-barrier*
- dup in/out hits get copy-at ;
-
-M: vop eliminate-write-barrier* ;
-
-: eliminate-write-barrier ( insns -- insns )
- H{ } clone hits set
- [ eliminate-write-barrier* ] map ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
--- /dev/null
+Support for generation of relocatable code
--- /dev/null
+! 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 ;
--- /dev/null
+! 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
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.lvops
+
+! Machine representation ("linear virtual operations"). Uses
+! same operations as CFG basic blocks, except edges and branches
+! are replaced by linear jumps (_b* instances).
+
+TUPLE: _label label ;
+
+! Unconditional jump to label
+TUPLE: _b label ;
+
+! Integer
+TUPLE: _bi label in code ;
+TUPLE: _bf label in code ;
+
+! Dispatch table, jumps to one of following _address
+! depending value of 'in'
+TUPLE: _dispatch in ;
+TUPLE: _address word ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.lvops
-
-! Machine representation ("linear virtual operations"). Uses
-! same operations as CFG basic blocks, except edges and branches
-! are replaced by linear jumps (_b* instances).
-
-TUPLE: _label label ;
-
-! Unconditional jump to label
-TUPLE: _b label ;
-
-! Integer
-TUPLE: _bi label in code ;
-TUPLE: _bf label in code ;
-
-! Dispatch table, jumps to one of following _address
-! depending value of 'in'
-TUPLE: _dispatch in ;
-TUPLE: _address word ;
--- /dev/null
+! 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 ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces sequences assocs io
+prettyprint inference generator optimizer
+compiler.vops
+compiler.tree.builder
+compiler.tree.optimizer
+compiler.cfg.builder
+compiler.cfg.simplifier
+compiler.machine.builder
+compiler.machine.simplifier ;
+IN: compiler.machine.debugger
+
+: tree>linear ( tree word -- linear )
+ [
+ init-counter
+ build-cfg
+ [ simplify-cfg build-mr simplify-mr ] assoc-map
+ ] with-scope ;
+
+: linear. ( linear -- )
+ [
+ "==== " write swap .
+ [ . ] each
+ ] assoc-each ;
+
+: linearized-quot. ( quot -- )
+ build-tree optimize-tree
+ "Anonymous quotation" tree>linear
+ linear. ;
+
+: linearized-word. ( word -- )
+ dup build-tree-from-word nip optimize-tree
+ dup word-dataflow nip optimize swap tree>linear linear. ;
+
+: >basic-block ( quot -- basic-block )
+ build-tree optimize-tree
+ [
+ init-counter
+ "Anonymous quotation" build-cfg
+ >alist first second simplify-cfg
+ ] with-scope ;
+
+: basic-block. ( basic-block -- )
+ instructions>> [ . ] each ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces sequences.next compiler.lvops ;
+IN: compiler.machine.simplifier
+
+: useless-branch? ( next insn -- ? )
+ 2dup [ _label? ] [ _b? ] bi* and
+ [ [ label>> ] bi@ = ] [ 2drop f ] if ;
+
+: simplify-mr ( insns -- insns )
+ #! Remove unconditional branches to labels immediately
+ #! following.
+ [
+ [
+ tuck useless-branch?
+ [ drop ] [ , ] if
+ ] each-next
+ ] { } make ;
! 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>
with-variable
] { } make ;
-GENERIC: linearize-instruction ( basic-block insn -- )
+GENERIC: linearize* ( basic-block insn -- )
+
+M: object linearize* , drop ;
+
+M: %branch linearize*
+ drop successors>> first label>> _branch ;
-M: object linearize-instruction
- , drop ;
+: conditional ( basic-block -- label1 label2 )
+ successors>> first2 [ label>> ] bi@ swap ; inline
-M: %b linearize-instruction
- drop successors>> first number>> _b emit ;
+: boolean-conditional ( basic-block insn -- label1 vreg label2 )
+ [ conditional ] [ vreg>> ] bi* swap ; inline
-: conditional-branch ( basic-block insn class -- )
- [ successors>> ] 2dip
- [ [ first number>> ] [ [ in>> ] [ code>> ] bi ] [ ] tri* emit ]
- [ 2drop second number>> _b emit ]
- 3bi ; inline
+M: %branch-f linearize*
+ boolean-conditional _branch-f _branch ;
-M: %bi linearize-instruction _bi conditional-branch ;
-M: %bf linearize-instruction _bf conditional-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*
+ [
+ "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-mr ( procedure -- insns )
+: build-machine ( procedure -- insns )
[
- flatten-basic-blocks [
- [ number>> _label emit ]
- [ dup instructions>> [ linearize-instruction ] with each ]
+ entry>> flatten-basic-blocks [
+ [ label>> _label ]
+ [ dup instructions>> [ linearize* ] with each ]
bi
] each
] { } make ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences assocs io
-prettyprint inference generator optimizer
-compiler.vops
-compiler.tree.builder
-compiler.tree.optimizer
-compiler.cfg.builder
-compiler.cfg.simplifier
-compiler.machine.builder
-compiler.machine.simplifier ;
-IN: compiler.machine.debugger
-
-: tree>linear ( tree word -- linear )
- [
- init-counter
- build-cfg
- [ simplify-cfg build-mr simplify-mr ] assoc-map
- ] with-scope ;
-
-: linear. ( linear -- )
- [
- "==== " write swap .
- [ . ] each
- ] assoc-each ;
-
-: linearized-quot. ( quot -- )
- build-tree optimize-tree
- "Anonymous quotation" tree>linear
- linear. ;
-
-: linearized-word. ( word -- )
- dup build-tree-from-word nip optimize-tree
- dup word-dataflow nip optimize swap tree>linear linear. ;
-
-: >basic-block ( quot -- basic-block )
- build-tree optimize-tree
- [
- init-counter
- "Anonymous quotation" build-cfg
- >alist first second simplify-cfg
- ] with-scope ;
-
-: basic-block. ( basic-block -- )
- instructions>> [ . ] each ;
--- /dev/null
+! 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 ;
--- /dev/null
+! 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
+
+
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
--- /dev/null
+IN: compiler.machine.optimizer.tests
+USING: compiler.machine.optimizer tools.test ;
+
+\ optimize-machine must-infer
--- /dev/null
+! 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 ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces sequences.next compiler.lvops ;
-IN: compiler.machine.simplifier
-
-: useless-branch? ( next insn -- ? )
- 2dup [ _label? ] [ _b? ] bi* and
- [ [ label>> ] bi@ = ] [ 2drop f ] if ;
-
-: simplify-mr ( insns -- insns )
- #! Remove unconditional branches to labels immediately
- #! following.
- [
- [
- tuck useless-branch?
- [ drop ] [ , ] if
- ] each-next
- ] { } make ;
--- /dev/null
+! 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
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser kernel namespaces words layouts sequences classes
+classes.algebra accessors math arrays byte-arrays
+inference.dataflow optimizer.allot compiler.cfg compiler.vops ;
+IN: compiler.vops.builder
+
+<< : TEMP: CREATE dup [ get ] curry define-inline ; parsing >>
+
+! Temps Inputs Outputs
+TEMP: $1 TEMP: #1 TEMP: ^1
+TEMP: $2 TEMP: #2 TEMP: ^2
+TEMP: $3 TEMP: #3 TEMP: ^3
+TEMP: $4 TEMP: #4 TEMP: ^4
+TEMP: $5 TEMP: #5 TEMP: ^5
+
+GENERIC: emit-literal ( vreg object -- )
+
+M: fixnum emit-literal ( vreg object -- )
+ tag-bits get shift %iconst emit ;
+
+M: f emit-literal
+ class tag-number %iconst emit ;
+
+M: object emit-literal ( vreg object -- )
+ next-vreg [ %literal-table emit ] keep
+ swap %literal emit ;
+
+: temps ( seq -- ) [ next-vreg swap set ] each ;
+
+: init-intrinsic ( -- )
+ { $1 $2 $3 $4 ^1 ^2 ^3 ^4 } temps ;
+
+: load-iconst ( value -- vreg )
+ [ next-vreg dup ] dip %iconst emit ;
+
+: load-tag-mask ( -- vreg )
+ tag-mask get load-iconst ;
+
+: load-tag-bits ( -- vreg )
+ tag-bits get load-iconst ;
+
+: emit-tag-fixnum ( out in -- )
+ load-tag-bits %shl emit ;
+
+: emit-untag-fixnum ( out in -- )
+ load-tag-bits %sar emit ;
+
+: emit-untag ( out in -- )
+ next-vreg dup tag-mask get bitnot %iconst emit
+ %and emit ;
+
+: emit-tag ( -- )
+ $1 #1 load-tag-mask %and emit
+ ^1 $1 emit-tag-fixnum ;
+
+: emit-slot ( node -- )
+ [ ^1 #1 #2 ] dip dup in-d>> first node-class class-tag %%slot emit ;
+
+UNION: immediate fixnum POSTPONE: f ;
+
+: emit-write-barrier ( node -- )
+ dup in-d>> first node-class immediate class< [ #2 %write-barrier emit ] unless ;
+
+: emit-set-slot ( node -- )
+ [ emit-write-barrier ]
+ [ [ #1 #2 #3 ] dip dup in-d>> second node-class class-tag %%set-slot emit ]
+ bi ;
+
+: emit-fixnum-bitnot ( -- )
+ $1 #1 %not emit
+ ^1 $1 load-tag-mask %xor emit ;
+
+: emit-fixnum+fast ( -- )
+ ^1 #1 #2 %iadd emit ;
+
+: emit-fixnum-fast ( -- )
+ ^1 #1 #2 %isub emit ;
+
+: emit-fixnum-bitand ( -- )
+ ^1 #1 #2 %and emit ;
+
+: emit-fixnum-bitor ( -- )
+ ^1 #1 #2 %or emit ;
+
+: emit-fixnum-bitxor ( -- )
+ ^1 #1 #2 %xor emit ;
+
+: emit-fixnum*fast ( -- )
+ $1 #1 emit-untag-fixnum
+ ^1 $1 #2 %imul emit ;
+
+: emit-fixnum-shift-left-fast ( n -- )
+ [ $1 ] dip %iconst emit
+ ^1 #1 $1 %shl emit ;
+
+: emit-fixnum-shift-right-fast ( n -- )
+ [ $1 ] dip %iconst emit
+ $2 #1 $1 %sar emit
+ ^1 $2 emit-untag ;
+
+: emit-fixnum-shift-fast ( n -- )
+ dup 0 >=
+ [ emit-fixnum-shift-left-fast ]
+ [ neg emit-fixnum-shift-right-fast ] if ;
+
+: emit-fixnum-compare ( cc -- )
+ $1 #1 #2 %icmp emit
+ [ ^1 $1 ] dip %%iboolean emit ;
+
+: emit-fixnum<= ( -- )
+ cc<= emit-fixnum-compare ;
+
+: emit-fixnum>= ( -- )
+ cc>= emit-fixnum-compare ;
+
+: emit-fixnum< ( -- )
+ cc< emit-fixnum-compare ;
+
+: emit-fixnum> ( -- )
+ cc> emit-fixnum-compare ;
+
+: emit-eq? ( -- )
+ cc= emit-fixnum-compare ;
+
+: emit-unbox-float ( out in -- )
+ %%unbox-float emit ;
+
+: emit-box-float ( out in -- )
+ %%box-float emit ;
+
+: emit-unbox-floats ( -- )
+ $1 #1 emit-unbox-float
+ $2 #2 emit-unbox-float ;
+
+: emit-float+ ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fadd emit
+ ^1 $3 emit-box-float ;
+
+: emit-float- ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fsub emit
+ ^1 $3 emit-box-float ;
+
+: emit-float* ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fmul emit
+ ^1 $3 emit-box-float ;
+
+: emit-float/f ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fdiv emit
+ ^1 $3 emit-box-float ;
+
+: emit-float-compare ( cc -- )
+ emit-unbox-floats
+ $3 $1 $2 %fcmp emit
+ [ ^1 $3 ] dip %%fboolean emit ;
+
+: emit-float<= ( -- )
+ cc<= emit-float-compare ;
+
+: emit-float>= ( -- )
+ cc>= emit-float-compare ;
+
+: emit-float< ( -- )
+ cc< emit-float-compare ;
+
+: emit-float> ( -- )
+ cc> emit-float-compare ;
+
+: emit-float= ( -- )
+ cc= emit-float-compare ;
+
+: emit-allot ( vreg size class -- )
+ [ tag-number ] [ type-number ] bi %%allot emit ;
+
+: emit-(tuple) ( layout -- )
+ [ [ ^1 ] dip size>> 2 + tuple emit-allot ]
+ [ [ $1 ] dip emit-literal ] bi
+ $2 1 emit-literal
+ $1 ^1 $2 tuple tag-number %%set-slot emit ;
+
+: emit-(array) ( n -- )
+ [ [ ^1 ] dip 2 + array emit-allot ]
+ [ [ $1 ] dip emit-literal ] bi
+ $2 1 emit-literal
+ $1 ^1 $2 array tag-number %%set-slot emit ;
+
+: emit-(byte-array) ( n -- )
+ [ [ ^1 ] dip bytes>cells 2 + byte-array emit-allot ]
+ [ [ $1 ] dip emit-literal ] bi
+ $2 1 emit-literal
+ $1 ^1 $2 byte-array tag-number %%set-slot emit ;
+
+! fixnum>bignum
+! bignum>fixnum
+! fixnum+
+! fixnum-
+! getenv, setenv
+! alien accessors
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser prettyprint.backend kernel accessors math
+math.order sequences namespaces arrays assocs ;
+IN: compiler.vops
+
+TUPLE: vreg n ;
+
+: VREG: scan-word vreg boa parsed ; parsing
+
+M: vreg pprint* \ VREG: pprint-word n>> pprint* ;
+
+SYMBOL: vreg-counter
+
+: init-counter ( -- )
+ { 0 } clone vreg-counter set ;
+
+: next-vreg ( -- n )
+ 0 vreg-counter get [ dup 1+ ] change-nth vreg boa ;
+
+: emit ( ... class -- ) boa , ; inline
+
+! ! ! Instructions. Those prefixed with %% are high level
+! ! ! instructions eliminated during the elaboration phase.
+TUPLE: vop ;
+
+! Instruction which does not touch vregs.
+TUPLE: nullary-op < vop ;
+
+! Does nothing
+TUPLE: nop < nullary-op ;
+
+: nop ( -- vop ) T{ nop } ;
+
+: ?nop ( vop ? -- vop/nop ) [ drop nop ] unless ;
+
+! Instruction with no side effects; if 'out' is never read, we
+! can eliminate it.
+TUPLE: flushable-op < vop out ;
+
+! Instruction which is referentially transparent; we can replace
+! repeated computation with a reference to a previous value
+TUPLE: pure-op < flushable-op ;
+
+! Instruction only used for its side effect, produces no values
+TUPLE: effect-op < vop in ;
+
+TUPLE: binary-op < pure-op in1 in2 ;
+
+: inputs ( insn -- in1 in2 ) [ in1>> ] [ in2>> ] bi ; inline
+
+: in/out ( insn -- in out ) [ in>> ] [ out>> ] bi ; inline
+
+TUPLE: unary-op < pure-op in ;
+
+! Merge point; out is a sequence of vregs in a sequence of
+! sequences of vregs
+TUPLE: %phi < pure-op in ;
+
+! Integer, floating point, condition register copy
+TUPLE: %copy < unary-op ;
+
+! Constants
+TUPLE: constant-op < pure-op value ;
+
+TUPLE: %iconst < constant-op ; ! Integer
+TUPLE: %fconst < constant-op ; ! Float
+TUPLE: %cconst < constant-op ; ! Comparison result, +lt+ +eq+ +gt+
+
+! Load address of literal table into out
+TUPLE: %literal-table < pure-op ;
+
+! Load object literal from table.
+TUPLE: %literal < unary-op object ;
+
+! Read/write ops: candidates for alias analysis
+TUPLE: read-op < flushable-op ;
+TUPLE: write-op < effect-op ;
+
+! Stack shuffling
+SINGLETON: %data
+SINGLETON: %retain
+
+TUPLE: %peek < read-op n stack ;
+TUPLE: %replace < write-op n stack ;
+TUPLE: %height < nullary-op n stack ;
+
+: stack-loc ( insn -- pair ) [ n>> ] [ stack>> ] bi 2array ;
+
+TUPLE: commutative-op < binary-op ;
+
+! Integer arithmetic
+TUPLE: %iadd < commutative-op ;
+TUPLE: %isub < binary-op ;
+TUPLE: %imul < commutative-op ;
+TUPLE: %idiv < binary-op ;
+TUPLE: %imod < binary-op ;
+TUPLE: %icmp < binary-op ;
+
+! Bitwise ops
+TUPLE: %not < unary-op ;
+TUPLE: %and < commutative-op ;
+TUPLE: %or < commutative-op ;
+TUPLE: %xor < commutative-op ;
+TUPLE: %shl < binary-op ;
+TUPLE: %shr < binary-op ;
+TUPLE: %sar < binary-op ;
+
+! Float arithmetic
+TUPLE: %fadd < commutative-op ;
+TUPLE: %fsub < binary-op ;
+TUPLE: %fmul < commutative-op ;
+TUPLE: %fdiv < binary-op ;
+TUPLE: %fcmp < binary-op ;
+
+! Float/integer conversion
+TUPLE: %f>i < unary-op ;
+TUPLE: %i>f < unary-op ;
+
+! Float boxing/unboxing
+TUPLE: %%box-float < unary-op ;
+TUPLE: %%unbox-float < unary-op ;
+
+! High level slot accessors for alias analysis
+! tag is f; if its not f, we can generate a faster sequence
+TUPLE: %%slot < read-op obj slot tag ;
+TUPLE: %%set-slot < write-op obj slot tag ;
+
+TUPLE: %write-barrier < effect-op ;
+
+! Memory
+TUPLE: %load < unary-op ;
+TUPLE: %store < effect-op addr ;
+
+! Control flow; they jump to either the first or second successor
+! of the BB
+
+! Unconditional transfer to first successor
+TUPLE: %b < nullary-op ;
+
+SYMBOL: cc<
+SYMBOL: cc<=
+SYMBOL: cc=
+SYMBOL: cc>
+SYMBOL: cc>=
+SYMBOL: cc/=
+
+: evaluate-cc ( result cc -- ? )
+ H{
+ { cc< { +lt+ } }
+ { cc<= { +lt+ +eq+ } }
+ { cc= { +eq+ } }
+ { cc>= { +eq+ +gt+ } }
+ { cc> { +gt+ } }
+ { cc/= { +lt+ +gt+ } }
+ } at memq? ;
+
+TUPLE: cond-branch < effect-op code ;
+
+TUPLE: %bi < cond-branch ;
+TUPLE: %bf < cond-branch ;
+
+! Convert condition register to a boolean
+TUPLE: boolean-op < unary-op code ;
+
+TUPLE: %%iboolean < boolean-op ;
+TUPLE: %%fboolean < boolean-op ;
+
+! Dispatch table, jumps to successor 0..n-1 depending value of
+! in, which must be in the range [0,n)
+TUPLE: %dispatch < effect-op ;
+
+! Procedures
+TUPLE: %return < nullary-op ;
+TUPLE: %prolog < nullary-op ;
+TUPLE: %epilog < nullary-op ;
+TUPLE: %jump < nullary-op word ;
+TUPLE: %call < nullary-op word ;
+
+! Heap allocation
+TUPLE: %%allot < flushable-op size tag type ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel namespaces words layouts sequences classes
-classes.algebra accessors math arrays byte-arrays
-inference.dataflow optimizer.allot compiler.cfg compiler.vops ;
-IN: compiler.vops.builder
-
-<< : TEMP: CREATE dup [ get ] curry define-inline ; parsing >>
-
-! Temps Inputs Outputs
-TEMP: $1 TEMP: #1 TEMP: ^1
-TEMP: $2 TEMP: #2 TEMP: ^2
-TEMP: $3 TEMP: #3 TEMP: ^3
-TEMP: $4 TEMP: #4 TEMP: ^4
-TEMP: $5 TEMP: #5 TEMP: ^5
-
-GENERIC: emit-literal ( vreg object -- )
-
-M: fixnum emit-literal ( vreg object -- )
- tag-bits get shift %iconst emit ;
-
-M: f emit-literal
- class tag-number %iconst emit ;
-
-M: object emit-literal ( vreg object -- )
- next-vreg [ %literal-table emit ] keep
- swap %literal emit ;
-
-: temps ( seq -- ) [ next-vreg swap set ] each ;
-
-: init-intrinsic ( -- )
- { $1 $2 $3 $4 ^1 ^2 ^3 ^4 } temps ;
-
-: load-iconst ( value -- vreg )
- [ next-vreg dup ] dip %iconst emit ;
-
-: load-tag-mask ( -- vreg )
- tag-mask get load-iconst ;
-
-: load-tag-bits ( -- vreg )
- tag-bits get load-iconst ;
-
-: emit-tag-fixnum ( out in -- )
- load-tag-bits %shl emit ;
-
-: emit-untag-fixnum ( out in -- )
- load-tag-bits %sar emit ;
-
-: emit-untag ( out in -- )
- next-vreg dup tag-mask get bitnot %iconst emit
- %and emit ;
-
-: emit-tag ( -- )
- $1 #1 load-tag-mask %and emit
- ^1 $1 emit-tag-fixnum ;
-
-: emit-slot ( node -- )
- [ ^1 #1 #2 ] dip dup in-d>> first node-class class-tag %%slot emit ;
-
-UNION: immediate fixnum POSTPONE: f ;
-
-: emit-write-barrier ( node -- )
- dup in-d>> first node-class immediate class< [ #2 %write-barrier emit ] unless ;
-
-: emit-set-slot ( node -- )
- [ emit-write-barrier ]
- [ [ #1 #2 #3 ] dip dup in-d>> second node-class class-tag %%set-slot emit ]
- bi ;
-
-: emit-fixnum-bitnot ( -- )
- $1 #1 %not emit
- ^1 $1 load-tag-mask %xor emit ;
-
-: emit-fixnum+fast ( -- )
- ^1 #1 #2 %iadd emit ;
-
-: emit-fixnum-fast ( -- )
- ^1 #1 #2 %isub emit ;
-
-: emit-fixnum-bitand ( -- )
- ^1 #1 #2 %and emit ;
-
-: emit-fixnum-bitor ( -- )
- ^1 #1 #2 %or emit ;
-
-: emit-fixnum-bitxor ( -- )
- ^1 #1 #2 %xor emit ;
-
-: emit-fixnum*fast ( -- )
- $1 #1 emit-untag-fixnum
- ^1 $1 #2 %imul emit ;
-
-: emit-fixnum-shift-left-fast ( n -- )
- [ $1 ] dip %iconst emit
- ^1 #1 $1 %shl emit ;
-
-: emit-fixnum-shift-right-fast ( n -- )
- [ $1 ] dip %iconst emit
- $2 #1 $1 %sar emit
- ^1 $2 emit-untag ;
-
-: emit-fixnum-shift-fast ( n -- )
- dup 0 >=
- [ emit-fixnum-shift-left-fast ]
- [ neg emit-fixnum-shift-right-fast ] if ;
-
-: emit-fixnum-compare ( cc -- )
- $1 #1 #2 %icmp emit
- [ ^1 $1 ] dip %%iboolean emit ;
-
-: emit-fixnum<= ( -- )
- cc<= emit-fixnum-compare ;
-
-: emit-fixnum>= ( -- )
- cc>= emit-fixnum-compare ;
-
-: emit-fixnum< ( -- )
- cc< emit-fixnum-compare ;
-
-: emit-fixnum> ( -- )
- cc> emit-fixnum-compare ;
-
-: emit-eq? ( -- )
- cc= emit-fixnum-compare ;
-
-: emit-unbox-float ( out in -- )
- %%unbox-float emit ;
-
-: emit-box-float ( out in -- )
- %%box-float emit ;
-
-: emit-unbox-floats ( -- )
- $1 #1 emit-unbox-float
- $2 #2 emit-unbox-float ;
-
-: emit-float+ ( -- )
- emit-unbox-floats
- $3 $1 $2 %fadd emit
- ^1 $3 emit-box-float ;
-
-: emit-float- ( -- )
- emit-unbox-floats
- $3 $1 $2 %fsub emit
- ^1 $3 emit-box-float ;
-
-: emit-float* ( -- )
- emit-unbox-floats
- $3 $1 $2 %fmul emit
- ^1 $3 emit-box-float ;
-
-: emit-float/f ( -- )
- emit-unbox-floats
- $3 $1 $2 %fdiv emit
- ^1 $3 emit-box-float ;
-
-: emit-float-compare ( cc -- )
- emit-unbox-floats
- $3 $1 $2 %fcmp emit
- [ ^1 $3 ] dip %%fboolean emit ;
-
-: emit-float<= ( -- )
- cc<= emit-float-compare ;
-
-: emit-float>= ( -- )
- cc>= emit-float-compare ;
-
-: emit-float< ( -- )
- cc< emit-float-compare ;
-
-: emit-float> ( -- )
- cc> emit-float-compare ;
-
-: emit-float= ( -- )
- cc= emit-float-compare ;
-
-: emit-allot ( vreg size class -- )
- [ tag-number ] [ type-number ] bi %%allot emit ;
-
-: emit-(tuple) ( layout -- )
- [ [ ^1 ] dip size>> 2 + tuple emit-allot ]
- [ [ $1 ] dip emit-literal ] bi
- $2 1 emit-literal
- $1 ^1 $2 tuple tag-number %%set-slot emit ;
-
-: emit-(array) ( n -- )
- [ [ ^1 ] dip 2 + array emit-allot ]
- [ [ $1 ] dip emit-literal ] bi
- $2 1 emit-literal
- $1 ^1 $2 array tag-number %%set-slot emit ;
-
-: emit-(byte-array) ( n -- )
- [ [ ^1 ] dip bytes>cells 2 + byte-array emit-allot ]
- [ [ $1 ] dip emit-literal ] bi
- $2 1 emit-literal
- $1 ^1 $2 byte-array tag-number %%set-slot emit ;
-
-! fixnum>bignum
-! bignum>fixnum
-! fixnum+
-! fixnum-
-! getenv, setenv
-! alien accessors
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser prettyprint.backend kernel accessors math
-math.order sequences namespaces arrays assocs ;
-IN: compiler.vops
-
-TUPLE: vreg n ;
-
-: VREG: scan-word vreg boa parsed ; parsing
-
-M: vreg pprint* \ VREG: pprint-word n>> pprint* ;
-
-SYMBOL: vreg-counter
-
-: init-counter ( -- )
- { 0 } clone vreg-counter set ;
-
-: next-vreg ( -- n )
- 0 vreg-counter get [ dup 1+ ] change-nth vreg boa ;
-
-: emit ( ... class -- ) boa , ; inline
-
-! ! ! Instructions. Those prefixed with %% are high level
-! ! ! instructions eliminated during the elaboration phase.
-TUPLE: vop ;
-
-! Instruction which does not touch vregs.
-TUPLE: nullary-op < vop ;
-
-! Does nothing
-TUPLE: nop < nullary-op ;
-
-: nop ( -- vop ) T{ nop } ;
-
-: ?nop ( vop ? -- vop/nop ) [ drop nop ] unless ;
-
-! Instruction with no side effects; if 'out' is never read, we
-! can eliminate it.
-TUPLE: flushable-op < vop out ;
-
-! Instruction which is referentially transparent; we can replace
-! repeated computation with a reference to a previous value
-TUPLE: pure-op < flushable-op ;
-
-! Instruction only used for its side effect, produces no values
-TUPLE: effect-op < vop in ;
-
-TUPLE: binary-op < pure-op in1 in2 ;
-
-: inputs ( insn -- in1 in2 ) [ in1>> ] [ in2>> ] bi ; inline
-
-: in/out ( insn -- in out ) [ in>> ] [ out>> ] bi ; inline
-
-TUPLE: unary-op < pure-op in ;
-
-! Merge point; out is a sequence of vregs in a sequence of
-! sequences of vregs
-TUPLE: %phi < pure-op in ;
-
-! Integer, floating point, condition register copy
-TUPLE: %copy < unary-op ;
-
-! Constants
-TUPLE: constant-op < pure-op value ;
-
-TUPLE: %iconst < constant-op ; ! Integer
-TUPLE: %fconst < constant-op ; ! Float
-TUPLE: %cconst < constant-op ; ! Comparison result, +lt+ +eq+ +gt+
-
-! Load address of literal table into out
-TUPLE: %literal-table < pure-op ;
-
-! Load object literal from table.
-TUPLE: %literal < unary-op object ;
-
-! Read/write ops: candidates for alias analysis
-TUPLE: read-op < flushable-op ;
-TUPLE: write-op < effect-op ;
-
-! Stack shuffling
-SINGLETON: %data
-SINGLETON: %retain
-
-TUPLE: %peek < read-op n stack ;
-TUPLE: %replace < write-op n stack ;
-TUPLE: %height < nullary-op n stack ;
-
-: stack-loc ( insn -- pair ) [ n>> ] [ stack>> ] bi 2array ;
-
-TUPLE: commutative-op < binary-op ;
-
-! Integer arithmetic
-TUPLE: %iadd < commutative-op ;
-TUPLE: %isub < binary-op ;
-TUPLE: %imul < commutative-op ;
-TUPLE: %idiv < binary-op ;
-TUPLE: %imod < binary-op ;
-TUPLE: %icmp < binary-op ;
-
-! Bitwise ops
-TUPLE: %not < unary-op ;
-TUPLE: %and < commutative-op ;
-TUPLE: %or < commutative-op ;
-TUPLE: %xor < commutative-op ;
-TUPLE: %shl < binary-op ;
-TUPLE: %shr < binary-op ;
-TUPLE: %sar < binary-op ;
-
-! Float arithmetic
-TUPLE: %fadd < commutative-op ;
-TUPLE: %fsub < binary-op ;
-TUPLE: %fmul < commutative-op ;
-TUPLE: %fdiv < binary-op ;
-TUPLE: %fcmp < binary-op ;
-
-! Float/integer conversion
-TUPLE: %f>i < unary-op ;
-TUPLE: %i>f < unary-op ;
-
-! Float boxing/unboxing
-TUPLE: %%box-float < unary-op ;
-TUPLE: %%unbox-float < unary-op ;
-
-! High level slot accessors for alias analysis
-! tag is f; if its not f, we can generate a faster sequence
-TUPLE: %%slot < read-op obj slot tag ;
-TUPLE: %%set-slot < write-op obj slot tag ;
-
-TUPLE: %write-barrier < effect-op ;
-
-! Memory
-TUPLE: %load < unary-op ;
-TUPLE: %store < effect-op addr ;
-
-! Control flow; they jump to either the first or second successor
-! of the BB
-
-! Unconditional transfer to first successor
-TUPLE: %b < nullary-op ;
-
-SYMBOL: cc<
-SYMBOL: cc<=
-SYMBOL: cc=
-SYMBOL: cc>
-SYMBOL: cc>=
-SYMBOL: cc/=
-
-: evaluate-cc ( result cc -- ? )
- H{
- { cc< { +lt+ } }
- { cc<= { +lt+ +eq+ } }
- { cc= { +eq+ } }
- { cc>= { +eq+ +gt+ } }
- { cc> { +gt+ } }
- { cc/= { +lt+ +gt+ } }
- } at memq? ;
-
-TUPLE: cond-branch < effect-op code ;
-
-TUPLE: %bi < cond-branch ;
-TUPLE: %bf < cond-branch ;
-
-! Convert condition register to a boolean
-TUPLE: boolean-op < unary-op code ;
-
-TUPLE: %%iboolean < boolean-op ;
-TUPLE: %%fboolean < boolean-op ;
-
-! Dispatch table, jumps to successor 0..n-1 depending value of
-! in, which must be in the range [0,n)
-TUPLE: %dispatch < effect-op ;
-
-! Procedures
-TUPLE: %return < nullary-op ;
-TUPLE: %prolog < nullary-op ;
-TUPLE: %epilog < nullary-op ;
-TUPLE: %jump < nullary-op word ;
-TUPLE: %call < nullary-op word ;
-
-! Heap allocation
-TUPLE: %%allot < flushable-op size tag type ;
projects / factor.git / commitdiff