$(CC) -c $(CFLAGS) -o $@ $<
.S.o:
- $(CC) -c $(CFLAGS) -o $@ $<
+ $(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
.m.o:
$(CC) -c $(CFLAGS) -o $@ $<
[ >float ] >>unboxer-quot
"double" define-primitive-type
- os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
+ "long" "ptrdiff_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit
USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
-io.encodings.ascii alien ;
+io.encodings.ascii alien io.encodings.string ;
IN: alien.strings.tests
[ "\u0000ff" ]
] unit-test
[ f ] [ f utf8 alien>string ] unit-test
+
+[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
+
+[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test
growable namespaces.private assocs words command-line vocabs io
io.encodings.string prettyprint libc splitting math.parser
compiler.units math.order compiler.tree.builder
-compiler.tree.optimizer ;
+compiler.tree.optimizer compiler.cfg.optimizer ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
. malloc calloc free memcpy
} compile-uncompiled
+"." write flush
+
{ build-tree } compile-uncompiled
+"." write flush
+
{ optimize-tree } compile-uncompiled
+"." write flush
+
+{ optimize-cfg } compile-uncompiled
+
+"." write flush
+
+{ (compile) } compile-uncompiled
+
+"." write flush
+
vocabs [ words compile-uncompiled "." write flush ] each
" done" print flush
classes.tuple.private words.private io.binary io.files vocabs
vocabs.loader source-files definitions debugger
quotations.private sequences.private combinators
-io.encodings.binary math.order math.private accessors slots.private ;
+io.encodings.binary math.order math.private accessors
+slots.private compiler.units ;
IN: bootstrap.image
+: arch ( os cpu -- arch )
+ {
+ { "ppc" [ "-ppc" append ] }
+ { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
+ [ nip ]
+ } case ;
+
: my-arch ( -- arch )
- cpu name>>
- dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
+ os name>> cpu name>> arch ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
: images ( -- seq )
{
"x86.32"
- "x86.64"
+ "winnt-x86.64" "unix-x86.64"
"linux-ppc" "macosx-ppc"
} ;
M: tuple ' emit-tuple ;
-M: tuple-layout '
- [
- [
- {
- [ hashcode>> , ]
- [ class>> , ]
- [ size>> , ]
- [ superclasses>> , ]
- [ echelon>> , ]
- } cleave
- ] { } make [ ' ] map
- \ tuple-layout type-number
- object tag-number [ emit-seq ] emit-object
- ] cache-object ;
-
M: tombstone '
state>> "((tombstone))" "((empty))" ?
"hashtables.private" lookup def>> first
[ emit-tuple ] cache-object ;
! Arrays
-M: array '
+: emit-array ( array -- offset )
[ ' ] map array type-number object tag-number
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
+M: array ' emit-array ;
+
+! This is a hack. We need to detect arrays which are tuple
+! layout arrays so that they can be internalized, but making
+! them a built-in type is not worth it.
+PREDICATE: tuple-layout-array < array
+ dup length 5 >= [
+ [ first tuple-class? ]
+ [ second fixnum? ]
+ [ third fixnum? ]
+ tri and and
+ ] [ drop f ] if ;
+
+M: tuple-layout-array '
+ [
+ [ dup integer? [ <fake-bignum> ] when ] map
+ emit-array
+ ] cache-object ;
+
! Quotations
M: quotation '
800000 <vector> image set
20000 <hashtable> objects set
emit-header t, 0, 1, -1,
+ "Building generic words..." print flush
+ call-remake-generics-hook
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush
+++ /dev/null
-USING: vocabs.loader sequences system
-random random.mersenne-twister combinators init
-namespaces random ;
-IN: bootstrap.random
-
-"random.mersenne-twister" require
-
-{
- { [ os windows? ] [ "random.windows" require ] }
- { [ os unix? ] [ "random.unix" require ] }
-} cond
-
-[
- [ 32 random-bits ] with-system-random
- <mersenne-twister> random-generator set-global
-] "bootstrap.random" add-init-hook
math.parser generic sets debugger command-line ;
IN: bootstrap.stage2
+SYMBOL: core-bootstrap-time
+
SYMBOL: bootstrap-time
: default-image-name ( -- string )
: count-words ( pred -- )
all-words swap count number>string write ;
-: print-report ( time -- )
+: print-time ( time -- )
1000 /i
60 /mod swap
- "Bootstrap completed in " write number>string write
- " minutes and " write number>string write " seconds." print
+ number>string write
+ " minutes and " write number>string write " seconds." print ;
+
+: print-report ( -- )
+ "Core bootstrap completed in " write core-bootstrap-time get print-time
+ "Bootstrap completed in " write bootstrap-time get print-time
[ compiled>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[
! We time bootstrap
- millis >r
+ millis
default-image-name "output-image" set-global
- "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
+ "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global
parse-command-line
[
load-components
+ millis over - core-bootstrap-time set-global
+
run-bootstrap-init
] with-compiler-errors
:errors
] [ print-error 1 exit ] recover
] set-boot-quot
- millis r> - dup bootstrap-time set-global
+ millis swap - bootstrap-time set-global
print-report
"output-image" get save-image-and-exit
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
-combinators compiler kernel math namespaces make parser
-prettyprint prettyprint.sections quotations sequences strings
-words cocoa.runtime io macros memoize debugger fry
-io.encodings.ascii effects compiler.generator libc libc.private ;
+combinators compiler compiler.alien kernel math namespaces make
+parser prettyprint prettyprint.sections quotations sequences
+strings words cocoa.runtime io macros memoize debugger
+io.encodings.ascii effects libc libc.private parser lexer init
+core-foundation fry ;
IN: cocoa.messages
: make-sender ( method function -- quot )
--- /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 cpu.architecture ;
+IN: compiler.alien
+
+: large-struct? ( ctype -- ? )
+ dup c-struct? [ 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 ;
--- /dev/null
+USING: compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.alias-analysis cpu.architecture tools.test
+kernel ;
+IN: compiler.cfg.alias-analysis.tests
+
+[ ] [
+ {
+ T{ ##peek f V int-regs 2 D 1 f }
+ T{ ##box-alien f V int-regs 1 V int-regs 2 }
+ T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
+ } alias-analysis drop
+] unit-test
+
+[ ] [
+ {
+ T{ ##load-indirect f V int-regs 1 "hello" }
+ T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
+ } alias-analysis drop
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 1 D 1 f }
+ T{ ##peek f V int-regs 2 D 2 f }
+ T{ ##replace f V int-regs 1 D 0 f }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 1 D 1 f }
+ T{ ##peek f V int-regs 2 D 2 f }
+ T{ ##replace f V int-regs 2 D 0 f }
+ T{ ##replace f V int-regs 1 D 0 f }
+ } alias-analysis
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 1 D 1 f }
+ T{ ##peek f V int-regs 2 D 0 f }
+ T{ ##copy f V int-regs 3 V int-regs 2 f }
+ T{ ##copy f V int-regs 4 V int-regs 1 f }
+ T{ ##replace f V int-regs 3 D 0 f }
+ T{ ##replace f V int-regs 4 D 1 f }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 1 D 1 f }
+ T{ ##peek f V int-regs 2 D 0 f }
+ T{ ##replace f V int-regs 1 D 0 f }
+ T{ ##replace f V int-regs 2 D 1 f }
+ T{ ##peek f V int-regs 3 D 1 f }
+ T{ ##peek f V int-regs 4 D 0 f }
+ T{ ##replace f V int-regs 3 D 0 f }
+ T{ ##replace f V int-regs 4 D 1 f }
+ } alias-analysis
+] unit-test
--- /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 classes compiler.cfg
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.copy-prop ;
+IN: compiler.cfg.alias-analysis
+
+! Alias analysis -- assumes compiler.cfg.height has already run.
+!
+! 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: constants
+
+: constant ( vreg -- n/f )
+ #! Return a ##load-immediate value, or f if the vreg was not
+ #! assigned by an ##load-immediate.
+ 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# loc>> n>> ;
+M: ##replace insn-slot# loc>> n>> ;
+M: ##slot insn-slot# slot>> constant ;
+M: ##slot-imm insn-slot# slot>> ;
+M: ##set-slot insn-slot# slot>> constant ;
+M: ##set-slot-imm insn-slot# slot>> ;
+
+M: ##peek insn-object loc>> class ;
+M: ##replace insn-object loc>> class ;
+M: ##slot insn-object obj>> resolve ;
+M: ##slot-imm insn-object obj>> resolve ;
+M: ##set-slot insn-object obj>> resolve ;
+M: ##set-slot-imm 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
+
+ ds-loc next-ac set-ac
+ rs-loc next-ac set-ac ;
+
+GENERIC: analyze-aliases* ( insn -- insn' )
+
+M: ##load-immediate analyze-aliases*
+ dup [ val>> ] [ dst>> ] bi constants get set-at ;
+
+M: ##load-indirect analyze-aliases*
+ dup dst>> set-heap-ac ;
+
+M: ##allot analyze-aliases*
+ #! A freshly allocated object is distinct from any other
+ #! object.
+ dup dst>> set-new-ac ;
+
+M: ##box-float analyze-aliases*
+ #! A freshly allocated object is distinct from any other
+ #! object.
+ dup dst>> set-new-ac ;
+
+M: ##box-alien analyze-aliases*
+ #! A freshly allocated object is distinct from any other
+ #! object.
+ dup dst>> set-new-ac ;
+
+M: ##read analyze-aliases*
+ dup dst>> set-heap-ac
+ dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
+ 2dup live-slot dup [
+ 2nip f \ ##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 analyze-aliases*
+ dup
+ [ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
+ [ remember-set-slot drop ] [ load-slot ] 3bi ;
+
+M: ##copy analyze-aliases*
+ #! The output vreg gets the same alias class as the input
+ #! vreg, since they both contain the same value.
+ dup record-copy ;
+
+M: insn analyze-aliases* ;
+
+: analyze-aliases ( insns -- insns' )
+ [ insn# set analyze-aliases* ] map-index sift ;
+
+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-stores* ( insn -- insn' )
+
+: (eliminate-dead-stores) ( insn -- insn' )
+ dup insn-slot# [
+ insn# get live-stores get key? [
+ drop f
+ ] unless
+ ] when ;
+
+M: ##replace eliminate-dead-stores*
+ #! 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 loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ;
+
+M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
+
+M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
+
+M: insn eliminate-dead-stores* ;
+
+: eliminate-dead-stores ( insns -- insns' )
+ [ insn# set eliminate-dead-stores* ] map-index sift ;
+
+: alias-analysis ( insns -- insns' )
+ init-alias-analysis
+ analyze-aliases
+ compute-live-stores
+ eliminate-dead-stores ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: compiler.cfg.builder.tests
+USING: tools.test kernel sequences
+words sequences.private fry prettyprint alien alien.accessors
+math.private compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
+kernel.private math ;
+
+\ build-cfg must-infer
+
+! Just ensure that various CFGs build correctly.
+: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
+
+{
+ [ ]
+ [ dup ]
+ [ swap ]
+ [ >r r> ]
+ [ fixnum+ ]
+ [ fixnum+fast ]
+ [ 3 fixnum+fast ]
+ [ fixnum*fast ]
+ [ 3 fixnum*fast ]
+ [ fixnum-shift-fast ]
+ [ 10 fixnum-shift-fast ]
+ [ -10 fixnum-shift-fast ]
+ [ 0 fixnum-shift-fast ]
+ [ fixnum-bitnot ]
+ [ eq? ]
+ [ "hi" eq? ]
+ [ fixnum< ]
+ [ 5 fixnum< ]
+ [ float+ ]
+ [ 3.0 float+ ]
+ [ float<= ]
+ [ fixnum>bignum ]
+ [ bignum>fixnum ]
+ [ fixnum>float ]
+ [ float>fixnum ]
+ [ 3 f <array> ]
+ [ [ 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 ]
+} [
+ unit-test-cfg
+] each
+
+: test-1 ( -- ) test-1 ;
+: test-2 ( -- ) 3 . test-2 ;
+: test-3 ( a -- b ) dup [ test-3 ] when ;
+
+{
+ test-1
+ test-2
+ test-3
+} [ unit-test-cfg ] each
+
+{
+ byte-array
+ simple-alien
+ alien
+ POSTPONE: f
+} [| class |
+ {
+ alien-signed-1
+ alien-signed-2
+ alien-signed-4
+ alien-unsigned-1
+ alien-unsigned-2
+ alien-unsigned-4
+ alien-cell
+ alien-float
+ alien-double
+ } [| word |
+ { class } word '[ _ declare 10 _ execute ] unit-test-cfg
+ { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+ ] each
+
+ {
+ set-alien-signed-1
+ set-alien-signed-2
+ set-alien-signed-4
+ set-alien-unsigned-1
+ set-alien-unsigned-2
+ set-alien-unsigned-4
+ } [| word |
+ { fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
+ { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+ ] each
+
+ { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
+ { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
+
+ { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
+ { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
+
+ { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
+ { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
+] each
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators hashtables kernel
+math fry namespaces make sequences words byte-arrays
+layouts alien.c-types alien.structs
+stack-checker.inlining cpu.architecture
+compiler.tree
+compiler.tree.builder
+compiler.tree.combinators
+compiler.tree.propagation.info
+compiler.cfg
+compiler.cfg.hats
+compiler.cfg.stacks
+compiler.cfg.iterator
+compiler.cfg.utilities
+compiler.cfg.registers
+compiler.cfg.intrinsics
+compiler.cfg.instructions
+compiler.alien ;
+IN: compiler.cfg.builder
+
+! Convert tree SSA IR to CFG SSA IR.
+
+: stop-iterating ( -- next ) end-basic-block f ;
+
+SYMBOL: procedures
+SYMBOL: current-word
+SYMBOL: current-label
+SYMBOL: loops
+SYMBOL: first-basic-block
+
+! Basic block after prologue, makes recursion faster
+SYMBOL: current-label-start
+
+: add-procedure ( -- )
+ basic-block get current-word get current-label get
+ <cfg> procedures get push ;
+
+: begin-procedure ( word label -- )
+ end-basic-block
+ begin-basic-block
+ H{ } clone loops set
+ current-label set
+ current-word set
+ add-procedure ;
+
+: with-cfg-builder ( nodes word label quot -- )
+ '[ begin-procedure @ ] with-scope ; inline
+
+GENERIC: emit-node ( node -- next )
+
+: check-basic-block ( node -- node' )
+ basic-block get [ drop f ] unless ; inline
+
+: emit-nodes ( nodes -- )
+ [ current-node emit-node check-basic-block ] iterate-nodes ;
+
+: 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.
+ ##prologue
+ ##branch
+ begin-basic-block
+ basic-block get first-basic-block set ;
+
+: (build-cfg) ( nodes word label -- )
+ [
+ begin-word
+ V{ } clone node-stack set
+ emit-nodes
+ ] with-cfg-builder ;
+
+: build-cfg ( nodes word -- procedures )
+ V{ } clone [
+ procedures [
+ dup (build-cfg)
+ ] with-variable
+ ] keep ;
+
+: local-recursive-call ( basic-block -- next )
+ ##branch
+ basic-block get successors>> push
+ stop-iterating ;
+
+: emit-call ( word -- next )
+ {
+ { [ dup loops get key? ] [ loops get at local-recursive-call ] }
+ { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
+ { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
+ [ ##epilogue ##jump stop-iterating ]
+ } cond ;
+
+! #recursive
+: compile-recursive ( node -- next )
+ [ label>> id>> emit-call ]
+ [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
+
+: remember-loop ( label -- )
+ basic-block get swap loops get set-at ;
+
+: compile-loop ( node -- next )
+ ##loop-entry
+ begin-basic-block
+ [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
+ iterate-next ;
+
+M: #recursive emit-node
+ dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
+
+! #if
+: emit-branch ( obj -- final-bb )
+ [
+ begin-basic-block
+ emit-nodes
+ basic-block get dup [ ##branch ] when
+ ] with-scope ;
+
+: emit-if ( node -- )
+ children>> [ emit-branch ] map
+ end-basic-block
+ begin-basic-block
+ basic-block get '[ [ _ swap successors>> push ] when* ] each ;
+
+: ##branch-t ( vreg -- )
+ \ f tag-number cc/= ##compare-imm-branch ;
+
+: trivial-branch? ( nodes -- value ? )
+ dup length 1 = [
+ first dup #push? [ literal>> t ] [ drop f f ] if
+ ] [ drop f f ] if ;
+
+: trivial-if? ( #if -- ? )
+ children>> first2
+ [ trivial-branch? [ t eq? ] when ]
+ [ trivial-branch? [ f eq? ] when ] bi*
+ and ;
+
+: emit-trivial-if ( -- )
+ ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
+
+: trivial-not-if? ( #if -- ? )
+ children>> first2
+ [ trivial-branch? [ f eq? ] when ]
+ [ trivial-branch? [ t eq? ] when ] bi*
+ and ;
+
+: emit-trivial-not-if ( -- )
+ ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
+
+M: #if emit-node
+ {
+ { [ dup trivial-if? ] [ drop emit-trivial-if ] }
+ { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
+ [ ds-pop ##branch-t emit-if ]
+ } cond iterate-next ;
+
+! #dispatch
+: trivial-dispatch-branch? ( nodes -- ? )
+ dup length 1 = [
+ first dup #call? [
+ word>> "intrinsic" word-prop not
+ ] [ drop f ] if
+ ] [ drop f ] if ;
+
+: dispatch-branch ( nodes word -- label )
+ over trivial-dispatch-branch? [
+ drop first word>>
+ ] [
+ gensym [
+ [
+ V{ } clone node-stack set
+ ##prologue
+ begin-basic-block
+ emit-nodes
+ basic-block get [
+ ##epilogue
+ ##return
+ end-basic-block
+ ] when
+ ] with-cfg-builder
+ ] keep
+ ] if ;
+
+: dispatch-branches ( node -- )
+ children>> [
+ current-word get dispatch-branch
+ ##dispatch-label
+ ] each ;
+
+: emit-dispatch ( node -- )
+ ##epilogue
+ ds-pop ^^offset>slot i ##dispatch
+ dispatch-branches ;
+
+: <dispatch-block> ( -- word )
+ gensym dup t "inlined-block" set-word-prop ;
+
+M: #dispatch emit-node
+ tail-call? [
+ emit-dispatch stop-iterating
+ ] [
+ current-word get <dispatch-block> [
+ [
+ begin-word
+ emit-dispatch
+ ] with-cfg-builder
+ ] keep emit-call
+ ] if ;
+
+! #call
+M: #call emit-node
+ dup word>> dup "intrinsic" word-prop
+ [ emit-intrinsic iterate-next ] [ nip emit-call ] if ;
+
+! #call-recursive
+M: #call-recursive emit-node label>> id>> emit-call ;
+
+! #push
+M: #push emit-node
+ literal>> ^^load-literal ds-push iterate-next ;
+
+! #shuffle
+: emit-shuffle ( effect -- )
+ [ out>> ] [ in>> dup length ds-load zip ] bi
+ '[ _ at ] map ds-store ;
+
+M: #shuffle emit-node
+ shuffle-effect emit-shuffle iterate-next ;
+
+M: #>r emit-node
+ [ in-d>> length ] [ out-r>> empty? ] bi
+ [ neg ##inc-d ] [ ds-load rs-store ] if
+ iterate-next ;
+
+M: #r> emit-node
+ [ in-r>> length ] [ out-d>> empty? ] bi
+ [ neg ##inc-r ] [ rs-load ds-store ] if
+ iterate-next ;
+
+! #return
+M: #return emit-node
+ drop ##epilogue ##return stop-iterating ;
+
+M: #return-recursive emit-node
+ label>> id>> loops get key?
+ [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
+
+! #terminate
+M: #terminate emit-node drop stop-iterating ;
+
+! FFI
+: return-size ( ctype -- n )
+ #! Amount of space we reserve for a return value.
+ {
+ { [ dup c-struct? not ] [ drop 0 ] }
+ { [ dup large-struct? not ] [ drop 2 cells ] }
+ [ heap-size ]
+ } cond ;
+
+: <alien-stack-frame> ( params -- stack-frame )
+ stack-frame new
+ swap
+ [ return>> return-size >>return ]
+ [ alien-parameters parameter-sizes drop >>params ] bi ;
+
+: alien-stack-frame ( params -- )
+ <alien-stack-frame> ##stack-frame ;
+
+: emit-alien-node ( node quot -- next )
+ [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
+ begin-basic-block iterate-next ; inline
+
+M: #alien-invoke emit-node
+ [ ##alien-invoke ] emit-alien-node ;
+
+M: #alien-indirect emit-node
+ [ ##alien-indirect ] emit-alien-node ;
+
+M: #alien-callback emit-node
+ dup params>> xt>> dup
+ [
+ ##prologue
+ dup [ ##alien-callback ] emit-alien-node drop
+ ##epilogue
+ params>> ##callback-return
+ ] with-cfg-builder
+ iterate-next ;
+
+! No-op nodes
+M: #introduce emit-node drop iterate-next ;
+
+M: #copy emit-node drop iterate-next ;
+
+M: #enter-recursive emit-node drop iterate-next ;
+
+M: #phi emit-node drop iterate-next ;
--- /dev/null
+Final stage of compilation generates machine code from dataflow IR
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays vectors accessors namespaces ;
+IN: compiler.cfg
+
+TUPLE: basic-block < identity-tuple
+id
+number
+{ instructions vector }
+{ successors vector }
+{ predecessors vector } ;
+
+: <basic-block> ( -- basic-block )
+ basic-block new
+ V{ } clone >>instructions
+ V{ } clone >>successors
+ V{ } clone >>predecessors
+ \ basic-block counter >>id ;
+
+TUPLE: cfg { entry basic-block } word label ;
+
+C: <cfg> cfg
+
+TUPLE: mr { instructions array } word label spill-counts ;
+
+: <mr> ( instructions word label -- mr )
+ mr new
+ swap >>label
+ swap >>word
+ swap >>instructions ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors ;
+IN: compiler.cfg.copy-prop
+
+SYMBOL: copies
+
+: resolve ( vreg -- vreg )
+ dup copies get at swap or ;
+
+: record-copy ( insn -- )
+ [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
--- /dev/null
+USING: compiler.cfg.dead-code compiler.cfg.instructions
+compiler.cfg.registers cpu.architecture tools.test ;
+IN: compiler.cfg.dead-code.tests
+
+[ { } ] [
+ { T{ ##load-immediate f V int-regs 134 16 } }
+ eliminate-dead-code
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sets kernel namespaces sequences
+compiler.cfg.instructions compiler.cfg.def-use ;
+IN: compiler.cfg.dead-code
+
+! Dead code elimination -- assumes compiler.cfg.alias-analysis
+! has already run.
+
+! Maps vregs to sequences of vregs
+SYMBOL: liveness-graph
+
+! vregs which participate in side effects and thus are always live
+SYMBOL: live-vregs
+
+! mapping vregs to stack locations
+SYMBOL: vregs>locs
+
+: init-dead-code ( -- )
+ H{ } clone liveness-graph set
+ H{ } clone live-vregs set
+ H{ } clone vregs>locs set ;
+
+GENERIC: compute-liveness ( insn -- )
+
+M: ##flushable compute-liveness
+ [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
+
+M: ##peek compute-liveness
+ [ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ]
+ [ call-next-method ]
+ bi ;
+
+: live-replace? ( ##replace -- ? )
+ [ src>> vregs>locs get at ] [ loc>> ] bi = not ;
+
+M: ##replace compute-liveness
+ dup live-replace? [ call-next-method ] [ drop ] if ;
+
+: record-live ( vregs -- )
+ [
+ dup live-vregs get key? [ drop ] [
+ [ live-vregs get conjoin ]
+ [ liveness-graph get at record-live ]
+ bi
+ ] if
+ ] each ;
+
+M: insn compute-liveness uses-vregs record-live ;
+
+GENERIC: live-insn? ( insn -- ? )
+
+M: ##flushable live-insn? dst>> live-vregs get key? ;
+
+M: ##replace live-insn? live-replace? ;
+
+M: insn live-insn? drop t ;
+
+: eliminate-dead-code ( insns -- insns' )
+ init-dead-code
+ [ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel words sequences quotations namespaces io
+classes.tuple accessors prettyprint prettyprint.config
+compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.linearization
+compiler.cfg.stack-frame compiler.cfg.linear-scan
+compiler.cfg.two-operand compiler.cfg.optimizer ;
+IN: compiler.cfg.debugger
+
+GENERIC: test-cfg ( quot -- cfgs )
+
+M: callable test-cfg
+ build-tree optimize-tree gensym build-cfg ;
+
+M: word test-cfg
+ [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
+
+SYMBOL: allocate-registers?
+
+: test-mr ( quot -- mrs )
+ test-cfg [
+ optimize-cfg
+ build-mr
+ convert-two-operand
+ allocate-registers? get
+ [ linear-scan build-stack-frame ] when
+ ] map ;
+
+: insn. ( insn -- )
+ tuple>array allocate-registers? get [ but-last ] unless
+ [ pprint bl ] each nl ;
+
+: mr. ( mrs -- )
+ [
+ "=== word: " write
+ dup word>> pprint
+ ", label: " write
+ dup label>> pprint nl nl
+ instructions>> [ insn. ] each
+ nl
+ ] each ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel compiler.cfg.instructions ;
+IN: compiler.cfg.def-use
+
+GENERIC: defs-vregs ( insn -- seq )
+GENERIC: uses-vregs ( insn -- seq )
+
+: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
+M: ##flushable defs-vregs dst>> 1array ;
+M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
+M: ##unary/temp defs-vregs dst/tmp-vregs ;
+M: ##allot defs-vregs dst/tmp-vregs ;
+M: ##dispatch defs-vregs temp>> 1array ;
+M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
+M: ##set-slot defs-vregs temp>> 1array ;
+M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
+M: insn defs-vregs drop f ;
+
+M: ##unary uses-vregs src>> 1array ;
+M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: ##binary-imm uses-vregs src1>> 1array ;
+M: ##effect uses-vregs src>> 1array ;
+M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
+M: ##slot-imm uses-vregs obj>> 1array ;
+M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
+M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
+M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
+M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: ##compare-imm-branch uses-vregs src1>> 1array ;
+M: ##dispatch uses-vregs src>> 1array ;
+M: ##alien-getter uses-vregs src>> 1array ;
+M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
+M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: _compare-imm-branch uses-vregs src1>> 1array ;
+M: insn uses-vregs drop f ;
+
+UNION: vreg-insn
+##flushable
+##write-barrier
+##dispatch
+##effect
+##conditional-branch
+##compare-imm-branch
+_conditional-branch
+_compare-imm-branch ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays kernel layouts math namespaces
+sequences classes.tuple cpu.architecture compiler.cfg.registers
+compiler.cfg.instructions ;
+IN: compiler.cfg.hats
+
+: i int-regs next-vreg ; inline
+: ^^i i dup ; inline
+: ^^i1 [ ^^i ] dip ; inline
+: ^^i2 [ ^^i ] 2dip ; inline
+: ^^i3 [ ^^i ] 3dip ; inline
+
+: d double-float-regs next-vreg ; inline
+: ^^d d dup ; inline
+: ^^d1 [ ^^d ] dip ; inline
+: ^^d2 [ ^^d ] 2dip ; inline
+: ^^d3 [ ^^d ] 3dip ; inline
+
+: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
+: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
+: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
+: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
+: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
+: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
+: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
+: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
+: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
+: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
+: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
+: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
+: ^^and ( input mask -- output ) ^^i2 ##and ; inline
+: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline
+: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline
+: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
+: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
+: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
+: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
+: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
+: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
+: ^^not ( src -- dst ) ^^i1 ##not ; inline
+: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
+: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
+: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
+: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
+: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
+: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
+: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
+: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
+: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
+: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
+: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
+: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
+: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
+: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
+: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
+: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
+: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
+: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
+: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
+: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
+: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
+: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
+: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
+: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
+: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
+: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
+: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
+: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
+: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
+: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
+: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
+: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math namespaces sequences kernel fry
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions ;
+IN: compiler.cfg.height
+
+! Combine multiple stack height changes into one at the
+! start of the basic block.
+
+SYMBOL: ds-height
+SYMBOL: rs-height
+
+GENERIC: compute-heights ( insn -- )
+
+M: ##inc-d compute-heights n>> ds-height [ + ] change ;
+M: ##inc-r compute-heights n>> rs-height [ + ] change ;
+M: insn compute-heights drop ;
+
+GENERIC: normalize-height* ( insn -- insn' )
+
+: normalize-inc-d/r ( insn stack -- insn' )
+ swap n>> '[ _ - ] change f ; inline
+
+M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
+M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
+
+GENERIC: loc-stack ( loc -- stack )
+
+M: ds-loc loc-stack drop ds-height ;
+M: rs-loc loc-stack drop rs-height ;
+
+GENERIC: <loc> ( n stack -- loc )
+
+M: ds-loc <loc> drop <ds-loc> ;
+M: rs-loc <loc> drop <rs-loc> ;
+
+: normalize-peek/replace ( insn -- insn' )
+ [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
+
+M: ##peek normalize-height* normalize-peek/replace ;
+M: ##replace normalize-height* normalize-peek/replace ;
+
+M: insn normalize-height* ;
+
+: normalize-height ( insns -- insns' )
+ 0 ds-height set
+ 0 rs-height set
+ [ [ compute-heights ] each ]
+ [ [ [ normalize-height* ] map sift ] with-scope ] bi
+ ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if
+ rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors arrays kernel sequences namespaces words
+math math.order layouts classes.algebra alien byte-arrays
+compiler.constants combinators compiler.cfg.registers
+compiler.cfg.instructions.syntax ;
+IN: compiler.cfg.instructions
+
+! Virtual CPU instructions, used by CFG and machine IRs
+TUPLE: insn ;
+
+! Instruction with no side effects; if 'out' is never read, we
+! can eliminate it.
+TUPLE: ##flushable < insn { dst vreg } ;
+
+! Instruction which is referentially transparent; we can replace
+! repeated computation with a reference to a previous value
+TUPLE: ##pure < ##flushable ;
+
+TUPLE: ##unary < ##pure { src vreg } ;
+TUPLE: ##unary/temp < ##unary { temp vreg } ;
+TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ;
+TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ;
+TUPLE: ##commutative < ##binary ;
+TUPLE: ##commutative-imm < ##binary-imm ;
+
+! Instruction only used for its side effect, produces no values
+TUPLE: ##effect < insn { src vreg } ;
+
+! Read/write ops: candidates for alias analysis
+TUPLE: ##read < ##flushable ;
+TUPLE: ##write < ##effect ;
+
+TUPLE: ##alien-getter < ##flushable { src vreg } ;
+TUPLE: ##alien-setter < ##effect { value vreg } ;
+
+! Stack operations
+INSN: ##load-immediate < ##pure { val integer } ;
+INSN: ##load-indirect < ##pure obj ;
+
+GENERIC: ##load-literal ( dst value -- )
+
+M: fixnum ##load-literal tag-fixnum ##load-immediate ;
+M: f ##load-literal drop \ f tag-number ##load-immediate ;
+M: object ##load-literal ##load-indirect ;
+
+INSN: ##peek < ##read { loc loc } ;
+INSN: ##replace < ##write { loc loc } ;
+INSN: ##inc-d { n integer } ;
+INSN: ##inc-r { n integer } ;
+
+! Subroutine calls
+TUPLE: stack-frame
+{ params integer }
+{ return integer }
+{ total-size integer }
+spill-counts ;
+
+INSN: ##stack-frame stack-frame ;
+INSN: ##call word ;
+INSN: ##jump word ;
+INSN: ##return ;
+
+! Jump tables
+INSN: ##dispatch src temp ;
+INSN: ##dispatch-label label ;
+
+! Slot access
+INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
+INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
+INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
+INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
+
+! String element access
+INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
+
+! Integer arithmetic
+INSN: ##add < ##commutative ;
+INSN: ##add-imm < ##commutative-imm ;
+INSN: ##sub < ##binary ;
+INSN: ##sub-imm < ##binary-imm ;
+INSN: ##mul < ##commutative ;
+INSN: ##mul-imm < ##commutative-imm ;
+INSN: ##and < ##commutative ;
+INSN: ##and-imm < ##commutative-imm ;
+INSN: ##or < ##commutative ;
+INSN: ##or-imm < ##commutative-imm ;
+INSN: ##xor < ##commutative ;
+INSN: ##xor-imm < ##commutative-imm ;
+INSN: ##shl-imm < ##binary-imm ;
+INSN: ##shr-imm < ##binary-imm ;
+INSN: ##sar-imm < ##binary-imm ;
+INSN: ##not < ##unary ;
+
+: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
+: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
+
+! Bignum/integer conversion
+INSN: ##integer>bignum < ##unary/temp ;
+INSN: ##bignum>integer < ##unary/temp ;
+
+! Float arithmetic
+INSN: ##add-float < ##commutative ;
+INSN: ##sub-float < ##binary ;
+INSN: ##mul-float < ##commutative ;
+INSN: ##div-float < ##binary ;
+
+! Float/integer conversion
+INSN: ##float>integer < ##unary ;
+INSN: ##integer>float < ##unary ;
+
+! Boxing and unboxing
+INSN: ##copy < ##unary ;
+INSN: ##copy-float < ##unary ;
+INSN: ##unbox-float < ##unary ;
+INSN: ##unbox-any-c-ptr < ##unary/temp ;
+INSN: ##box-float < ##unary/temp ;
+INSN: ##box-alien < ##unary/temp ;
+
+: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
+: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
+: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ;
+
+: ##unbox-c-ptr ( dst src class temp -- )
+ {
+ { [ over \ f class<= ] [ 2drop ##unbox-f ] }
+ { [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
+ { [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
+ [ nip ##unbox-any-c-ptr ]
+ } cond ;
+
+! Alien accessors
+INSN: ##alien-unsigned-1 < ##alien-getter ;
+INSN: ##alien-unsigned-2 < ##alien-getter ;
+INSN: ##alien-unsigned-4 < ##alien-getter ;
+INSN: ##alien-signed-1 < ##alien-getter ;
+INSN: ##alien-signed-2 < ##alien-getter ;
+INSN: ##alien-signed-4 < ##alien-getter ;
+INSN: ##alien-cell < ##alien-getter ;
+INSN: ##alien-float < ##alien-getter ;
+INSN: ##alien-double < ##alien-getter ;
+
+INSN: ##set-alien-integer-1 < ##alien-setter ;
+INSN: ##set-alien-integer-2 < ##alien-setter ;
+INSN: ##set-alien-integer-4 < ##alien-setter ;
+INSN: ##set-alien-cell < ##alien-setter ;
+INSN: ##set-alien-float < ##alien-setter ;
+INSN: ##set-alien-double < ##alien-setter ;
+
+! Memory allocation
+INSN: ##allot < ##flushable size class { temp vreg } ;
+INSN: ##write-barrier < ##effect card# table ;
+
+! FFI
+INSN: ##alien-invoke params ;
+INSN: ##alien-indirect params ;
+INSN: ##alien-callback params ;
+INSN: ##callback-return params ;
+
+! Instructions used by CFG IR only.
+INSN: ##prologue ;
+INSN: ##epilogue ;
+
+INSN: ##branch ;
+
+INSN: ##loop-entry ;
+
+! Condition codes
+SYMBOL: cc<
+SYMBOL: cc<=
+SYMBOL: cc=
+SYMBOL: cc>
+SYMBOL: cc>=
+SYMBOL: cc/=
+
+: negate-cc ( cc -- cc' )
+ H{
+ { cc< cc>= }
+ { cc<= cc> }
+ { cc> cc<= }
+ { cc>= cc< }
+ { cc= cc/= }
+ { cc/= cc= }
+ } at ;
+
+: evaluate-cc ( result cc -- ? )
+ H{
+ { cc< { +lt+ } }
+ { cc<= { +lt+ +eq+ } }
+ { cc= { +eq+ } }
+ { cc>= { +eq+ +gt+ } }
+ { cc> { +gt+ } }
+ { cc/= { +lt+ +gt+ } }
+ } at memq? ;
+
+TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
+
+INSN: ##compare-branch < ##conditional-branch ;
+INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
+
+INSN: ##compare < ##binary cc ;
+INSN: ##compare-imm < ##binary-imm cc ;
+
+INSN: ##compare-float-branch < ##conditional-branch ;
+INSN: ##compare-float < ##binary cc ;
+
+! Instructions used by machine IR only.
+INSN: _prologue stack-frame ;
+INSN: _epilogue stack-frame ;
+
+INSN: _label id ;
+
+INSN: _gc ;
+
+INSN: _branch label ;
+
+TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
+
+INSN: _compare-branch < _conditional-branch ;
+INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
+
+INSN: _compare-float-branch < _conditional-branch ;
+
+! These instructions operate on machine registers and not
+! virtual registers
+INSN: _spill src class n ;
+INSN: _reload dst class n ;
+INSN: _spill-counts counts ;
--- /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 fry sequences parser ;
+IN: compiler.cfg.instructions.syntax
+
+: insn-word ( -- word )
+ #! We want to put the insn tuple in compiler.cfg.instructions,
+ #! but we cannot have circularity between that vocabulary and
+ #! this one.
+ "insn" "compiler.cfg.instructions" lookup ;
+
+: INSN:
+ parse-tuple-definition "regs" suffix
+ [ dup tuple eq? [ drop insn-word ] when ] dip
+ [ define-tuple-class ]
+ [ 2drop save-location ]
+ [ 2drop dup '[ f _ boa , ] define-inline ]
+ 3tri ; parsing
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences alien math classes.algebra
+fry locals combinators cpu.architecture
+compiler.tree.propagation.info
+compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
+compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.alien
+
+: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
+ ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
+
+: (prepare-alien-accessor) ( class -- offset-vreg )
+ [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+
+: prepare-alien-accessor ( infos -- offset-vreg )
+ <reversed> [ second class>> ] [ first ] bi
+ dup value-info-small-fixnum? [
+ literal>> (prepare-alien-accessor-imm)
+ ] [ drop (prepare-alien-accessor) ] if ;
+
+:: inline-alien ( node quot test -- )
+ [let | infos [ node node-input-infos ] |
+ infos test call
+ [ infos prepare-alien-accessor quot call ]
+ [ node emit-primitive ]
+ if
+ ] ; inline
+
+: inline-alien-getter? ( infos -- ? )
+ [ first class>> c-ptr class<= ]
+ [ second class>> fixnum class<= ]
+ bi and ;
+
+: inline-alien-getter ( node quot -- )
+ '[ @ ds-push ]
+ [ inline-alien-getter? ] inline-alien ; inline
+
+: inline-alien-setter? ( infos class -- ? )
+ '[ first class>> _ class<= ]
+ [ second class>> c-ptr class<= ]
+ [ third class>> fixnum class<= ]
+ tri and and ;
+
+: inline-alien-integer-setter ( node quot -- )
+ '[ ds-pop ^^untag-fixnum @ ]
+ [ fixnum inline-alien-setter? ]
+ inline-alien ; inline
+
+: inline-alien-cell-setter ( node quot -- )
+ [ dup node-input-infos first class>> ] dip
+ '[ ds-pop _ ^^unbox-c-ptr @ ]
+ [ pinned-c-ptr inline-alien-setter? ]
+ inline-alien ; inline
+
+: inline-alien-float-setter ( node quot -- )
+ '[ ds-pop ^^unbox-float @ ]
+ [ float inline-alien-setter? ]
+ inline-alien ; inline
+
+: emit-alien-unsigned-getter ( node n -- )
+ '[
+ _ {
+ { 1 [ ^^alien-unsigned-1 ] }
+ { 2 [ ^^alien-unsigned-2 ] }
+ { 4 [ ^^alien-unsigned-4 ] }
+ } case ^^tag-fixnum
+ ] inline-alien-getter ;
+
+: emit-alien-signed-getter ( node n -- )
+ '[
+ _ {
+ { 1 [ ^^alien-signed-1 ] }
+ { 2 [ ^^alien-signed-2 ] }
+ { 4 [ ^^alien-signed-4 ] }
+ } case ^^tag-fixnum
+ ] inline-alien-getter ;
+
+: emit-alien-integer-setter ( node n -- )
+ '[
+ _ {
+ { 1 [ ##set-alien-integer-1 ] }
+ { 2 [ ##set-alien-integer-2 ] }
+ { 4 [ ##set-alien-integer-4 ] }
+ } case
+ ] inline-alien-integer-setter ;
+
+: emit-alien-cell-getter ( node -- )
+ [ ^^alien-cell ^^box-alien ] inline-alien-getter ;
+
+: emit-alien-cell-setter ( node -- )
+ [ ##set-alien-cell ] inline-alien-cell-setter ;
+
+: emit-alien-float-getter ( node reg-class -- )
+ '[
+ _ {
+ { single-float-regs [ ^^alien-float ] }
+ { double-float-regs [ ^^alien-double ] }
+ } case ^^box-float
+ ] inline-alien-getter ;
+
+: emit-alien-float-setter ( node reg-class -- )
+ '[
+ _ {
+ { single-float-regs [ ##set-alien-float ] }
+ { double-float-regs [ ##set-alien-double ] }
+ } case
+ ] inline-alien-float-setter ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.order sequences accessors arrays
+byte-arrays layouts classes.tuple.private fry locals
+compiler.tree.propagation.info compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.stacks
+compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.allot
+
+: ##set-slots ( regs obj class -- )
+ '[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ;
+
+: emit-simple-allot ( node -- )
+ [ in-d>> length ] [ node-output-infos first class>> ] bi
+ [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
+ [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
+
+: tuple-slot-regs ( layout -- vregs )
+ [ second ds-load ] [ ^^load-literal ] bi prefix ;
+
+: emit-<tuple-boa> ( node -- )
+ dup node-input-infos peek literal>>
+ dup array? [
+ nip
+ ds-drop
+ [ tuple-slot-regs ] [ second ^^allot-tuple ] bi
+ [ tuple ##set-slots ] [ ds-push drop ] 2bi
+ ] [ drop emit-primitive ] if ;
+
+: store-length ( len reg -- )
+ [ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
+
+: store-initial-element ( elt reg len -- )
+ [ 2 + object tag-number ##set-slot-imm ] with with each ;
+
+: expand-<array>? ( obj -- ? )
+ dup integer? [ 0 8 between? ] [ drop f ] if ;
+
+:: emit-<array> ( node -- )
+ [let | len [ node node-input-infos first literal>> ] |
+ len expand-<array>? [
+ [let | elt [ ds-pop ]
+ reg [ len ^^allot-array ] |
+ ds-drop
+ len reg store-length
+ elt reg len store-initial-element
+ reg ds-push
+ ]
+ ] [ node emit-primitive ] if
+ ] ;
+
+: expand-<byte-array>? ( obj -- ? )
+ dup integer? [ 0 32 between? ] [ drop f ] if ;
+
+: bytes>cells ( m -- n ) cell align cell /i ;
+
+:: emit-<byte-array> ( node -- )
+ [let | len [ node node-input-infos first literal>> ] |
+ len expand-<byte-array>? [
+ [let | elt [ 0 ^^load-literal ]
+ reg [ len ^^allot-byte-array ] |
+ ds-drop
+ len reg store-length
+ elt reg len bytes>cells store-initial-element
+ reg ds-push
+ ]
+ ] [ node emit-primitive ] if
+ ] ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences accessors layouts kernel math namespaces
+combinators fry locals
+compiler.tree.propagation.info
+compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.fixnum
+
+: (emit-fixnum-imm-op) ( infos insn -- dst )
+ ds-drop
+ [ ds-pop ]
+ [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
+ [ ]
+ tri*
+ call ; inline
+
+: (emit-fixnum-op) ( insn -- dst )
+ [ 2inputs ] dip call ; inline
+
+:: emit-fixnum-op ( node insn imm-insn -- )
+ [let | infos [ node node-input-infos ] |
+ infos second value-info-small-tagged?
+ [ infos imm-insn (emit-fixnum-imm-op) ]
+ [ insn (emit-fixnum-op) ]
+ if
+ ds-push
+ ] ; inline
+
+: emit-fixnum-shift-fast ( node -- )
+ dup node-input-infos dup second value-info-small-fixnum? [
+ nip
+ [ ds-drop ds-pop ] dip
+ second literal>> dup sgn {
+ { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
+ { 0 [ drop ] }
+ { 1 [ ^^shl-imm ] }
+ } case
+ ds-push
+ ] [ drop emit-primitive ] if ;
+
+: emit-fixnum-bitnot ( -- )
+ ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
+
+: (emit-fixnum*fast) ( -- dst )
+ 2inputs ^^untag-fixnum ^^mul ;
+
+: (emit-fixnum*fast-imm) ( infos -- dst )
+ ds-drop
+ [ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
+
+: emit-fixnum*fast ( node -- )
+ node-input-infos
+ dup second value-info-small-fixnum?
+ [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
+ ds-push ;
+
+: emit-fixnum-comparison ( node cc -- )
+ [ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
+ emit-fixnum-op ;
+
+: emit-bignum>fixnum ( -- )
+ ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
+
+: emit-fixnum>bignum ( -- )
+ ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.float
+
+: emit-float-op ( insn -- )
+ [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
+ ds-push ; inline
+
+: emit-float-comparison ( cc -- )
+ [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
+ ds-push ; inline
+
+: emit-float>fixnum ( -- )
+ ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
+
+: emit-fixnum>float ( -- )
+ ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: qualified words sequences kernel combinators
+cpu.architecture
+compiler.cfg.hats
+compiler.cfg.instructions
+compiler.cfg.intrinsics.alien
+compiler.cfg.intrinsics.allot
+compiler.cfg.intrinsics.fixnum
+compiler.cfg.intrinsics.float
+compiler.cfg.intrinsics.slots ;
+QUALIFIED: kernel
+QUALIFIED: arrays
+QUALIFIED: byte-arrays
+QUALIFIED: kernel.private
+QUALIFIED: slots.private
+QUALIFIED: strings.private
+QUALIFIED: classes.tuple.private
+QUALIFIED: math.private
+QUALIFIED: alien.accessors
+IN: compiler.cfg.intrinsics
+
+{
+ kernel.private:tag
+ math.private:fixnum+fast
+ math.private:fixnum-fast
+ math.private:fixnum-bitand
+ math.private:fixnum-bitor
+ math.private:fixnum-bitxor
+ math.private:fixnum-shift-fast
+ math.private:fixnum-bitnot
+ math.private:fixnum*fast
+ math.private:fixnum<
+ math.private:fixnum<=
+ math.private:fixnum>=
+ math.private:fixnum>
+ math.private:bignum>fixnum
+ math.private:fixnum>bignum
+ kernel:eq?
+ slots.private:slot
+ slots.private:set-slot
+ strings.private:string-nth
+ classes.tuple.private:<tuple-boa>
+ arrays:<array>
+ byte-arrays:<byte-array>
+ math.private:<complex>
+ math.private:<ratio>
+ kernel:<wrapper>
+ alien.accessors:alien-unsigned-1
+ alien.accessors:set-alien-unsigned-1
+ alien.accessors:alien-signed-1
+ alien.accessors:set-alien-signed-1
+ alien.accessors:alien-unsigned-2
+ alien.accessors:set-alien-unsigned-2
+ alien.accessors:alien-signed-2
+ alien.accessors:set-alien-signed-2
+ alien.accessors:alien-cell
+ alien.accessors:set-alien-cell
+} [ t "intrinsic" set-word-prop ] each
+
+: enable-alien-4-intrinsics ( -- )
+ {
+ alien.accessors:alien-unsigned-4
+ alien.accessors:set-alien-unsigned-4
+ alien.accessors:alien-signed-4
+ alien.accessors:set-alien-signed-4
+ } [ t "intrinsic" set-word-prop ] each ;
+
+: enable-float-intrinsics ( -- )
+ {
+ math.private:float+
+ math.private:float-
+ math.private:float*
+ math.private:float/f
+ math.private:fixnum>float
+ math.private:float>fixnum
+ math.private:float<
+ math.private:float<=
+ math.private:float>
+ math.private:float>=
+ math.private:float=
+ alien.accessors:alien-float
+ alien.accessors:set-alien-float
+ alien.accessors:alien-double
+ alien.accessors:set-alien-double
+ } [ t "intrinsic" set-word-prop ] each ;
+
+: emit-intrinsic ( node word -- )
+ {
+ { \ kernel.private:tag [ drop emit-tag ] }
+ { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
+ { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
+ { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
+ { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
+ { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
+ { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
+ { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+ { \ math.private:fixnum*fast [ emit-fixnum*fast ] }
+ { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
+ { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
+ { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
+ { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
+ { \ kernel:eq? [ cc= emit-fixnum-comparison ] }
+ { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
+ { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
+ { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+ { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+ { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+ { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+ { \ math.private:float< [ drop cc< emit-float-comparison ] }
+ { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
+ { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
+ { \ math.private:float> [ drop cc> emit-float-comparison ] }
+ { \ math.private:float= [ drop cc= emit-float-comparison ] }
+ { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
+ { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
+ { \ slots.private:slot [ emit-slot ] }
+ { \ slots.private:set-slot [ emit-set-slot ] }
+ { \ strings.private:string-nth [ drop emit-string-nth ] }
+ { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
+ { \ arrays:<array> [ emit-<array> ] }
+ { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
+ { \ math.private:<complex> [ emit-simple-allot ] }
+ { \ math.private:<ratio> [ emit-simple-allot ] }
+ { \ kernel:<wrapper> [ emit-simple-allot ] }
+ { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+ { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+ { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
+ { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
+ } case ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: layouts namespaces kernel accessors sequences
+classes.algebra compiler.tree.propagation.info
+compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.slots
+
+: emit-tag ( -- )
+ ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
+
+: value-tag ( info -- n ) class>> class-tag ; inline
+
+: (emit-slot) ( infos -- dst )
+ [ 2inputs ^^offset>slot ] [ first value-tag ] bi*
+ ^^slot ;
+
+: (emit-slot-imm) ( infos -- dst )
+ ds-drop
+ [ ds-pop ]
+ [ [ second literal>> ] [ first value-tag ] bi ] bi*
+ ^^slot-imm ;
+
+: emit-slot ( node -- )
+ dup node-input-infos
+ dup first value-tag [
+ nip
+ dup second value-info-small-fixnum?
+ [ (emit-slot-imm) ] [ (emit-slot) ] if
+ ds-push
+ ] [ drop emit-primitive ] if ;
+
+: (emit-set-slot) ( infos -- obj-reg )
+ [ 3inputs [ tuck ] dip ^^offset>slot ]
+ [ second value-tag ]
+ bi* ^^set-slot ;
+
+: (emit-set-slot-imm) ( infos -- obj-reg )
+ ds-drop
+ [ 2inputs tuck ]
+ [ [ third literal>> ] [ second value-tag ] bi ] bi*
+ ##set-slot-imm ;
+
+: emit-set-slot ( node -- )
+ dup node-input-infos
+ dup second value-tag [
+ nip
+ [
+ dup third value-info-small-fixnum?
+ [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
+ ] [ first class>> immediate class<= ] bi
+ [ drop ] [ i i ##write-barrier ] if
+ ] [ drop emit-primitive ] if ;
+
+: emit-string-nth ( -- )
+ 2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
--- /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
+
+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: namespaces sequences math math.order kernel assocs
+accessors vectors fry heaps cpu.architecture combinators
+compiler.cfg.registers
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.allocation
+
+! Mapping from register classes to sequences of machine registers
+SYMBOL: free-registers
+
+: free-registers-for ( vreg -- seq )
+ reg-class>> free-registers get at ;
+
+: deallocate-register ( live-interval -- )
+ [ reg>> ] [ vreg>> ] bi free-registers-for push ;
+
+! Vector of active live intervals
+SYMBOL: active-intervals
+
+: active-intervals-for ( vreg -- seq )
+ reg-class>> active-intervals get at ;
+
+: add-active ( live-interval -- )
+ dup vreg>> active-intervals-for push ;
+
+: delete-active ( live-interval -- )
+ dup vreg>> active-intervals-for delq ;
+
+: expire-old-intervals ( n -- )
+ active-intervals swap '[
+ [
+ [ end>> _ < ] partition
+ [ [ deallocate-register ] each ] dip
+ ] assoc-map
+ ] change ;
+
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
+
+! Start index of current live interval. We ensure that all
+! live intervals added to the unhandled set have a start index
+! strictly greater than ths one. This ensures that we can catch
+! infinite loop situations.
+SYMBOL: progress
+
+: check-progress ( live-interval -- )
+ start>> progress get <= [ "No progress" throw ] when ; inline
+
+: add-unhandled ( live-interval -- )
+ [ check-progress ]
+ [ dup start>> unhandled-intervals get heap-push ]
+ bi ;
+
+: init-unhandled ( live-intervals -- )
+ [ [ start>> ] keep ] { } map>assoc
+ unhandled-intervals get heap-push-all ;
+
+! Coalescing
+: active-interval ( vreg -- live-interval )
+ dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
+
+: coalesce? ( live-interval -- ? )
+ [ start>> ] [ copy-from>> active-interval ] bi
+ dup [ end>> = ] [ 2drop f ] if ;
+
+: coalesce ( live-interval -- )
+ dup copy-from>> active-interval
+ [ [ add-active ] [ delete-active ] bi* ]
+ [ reg>> >>reg drop ]
+ 2bi ;
+
+! Splitting
+: find-use ( live-interval n quot -- i elt )
+ [ uses>> ] 2dip curry find ; inline
+
+: split-before ( live-interval i -- before )
+ [ clone dup uses>> ] dip
+ [ head >>uses ] [ 1- swap nth >>end ] 2bi ;
+
+: split-after ( live-interval i -- after )
+ [ clone dup uses>> ] dip
+ [ tail >>uses ] [ swap nth >>start ] 2bi
+ f >>reg f >>copy-from ;
+
+: split-interval ( live-interval n -- before after )
+ [ drop ] [ [ > ] find-use drop ] 2bi
+ [ split-before ] [ split-after ] 2bi ;
+
+: record-split ( live-interval before after -- )
+ [ >>split-before ] [ >>split-after ] bi* drop ;
+
+! Spilling
+SYMBOL: spill-counts
+
+: next-spill-location ( reg-class -- n )
+ spill-counts get [ dup 1+ ] change-at ;
+
+: interval-to-spill ( active-intervals current -- live-interval )
+ #! We spill the interval with the most distant use location.
+ start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
+ unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
+
+: assign-spill ( before after -- before after )
+ #! If it has been spilled already, reuse spill location.
+ over reload-from>>
+ [ over vreg>> reg-class>> next-spill-location ] unless*
+ tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
+
+: split-and-spill ( new existing -- before after )
+ dup rot start>> split-interval
+ [ record-split ] [ assign-spill ] 2bi ;
+
+: reuse-register ( new existing -- )
+ reg>> >>reg add-active ;
+
+: spill-existing ( new existing -- )
+ #! Our new interval will be used before the active interval
+ #! with the most distant use location. Spill the existing
+ #! interval, then process the new interval and the tail end
+ #! of the existing interval again.
+ [ reuse-register ]
+ [ nip delete-active ]
+ [ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
+
+: spill-new ( new existing -- )
+ #! Our new interval will be used after the active interval
+ #! with the most distant use location. Split the new
+ #! interval, then process both parts of the new interval
+ #! again.
+ [ dup split-and-spill add-unhandled ] dip spill-existing ;
+
+: spill-existing? ( new existing -- ? )
+ #! Test if 'new' will be used before 'existing'.
+ over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
+
+: assign-blocked-register ( new -- )
+ [ dup vreg>> active-intervals-for ] keep interval-to-spill
+ 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
+
+: assign-free-register ( new registers -- )
+ pop >>reg add-active ;
+
+: assign-register ( new -- )
+ dup coalesce? [
+ coalesce
+ ] [
+ dup vreg>> free-registers-for
+ [ assign-blocked-register ]
+ [ assign-free-register ]
+ if-empty
+ ] if ;
+
+! Main loop
+: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
+
+: init-allocator ( registers -- )
+ <min-heap> unhandled-intervals set
+ [ reverse >vector ] assoc-map free-registers set
+ reg-classes [ 0 ] { } map>assoc spill-counts set
+ reg-classes [ V{ } clone ] { } map>assoc active-intervals set
+ -1 progress set ;
+
+: handle-interval ( live-interval -- )
+ [ start>> progress set ]
+ [ start>> expire-old-intervals ]
+ [ assign-register ]
+ tri ;
+
+: (allocate-registers) ( -- )
+ unhandled-intervals get [ handle-interval ] slurp-heap ;
+
+: allocate-registers ( live-intervals machine-registers -- live-intervals )
+ #! This modifies the input live-intervals.
+ init-allocator
+ dup init-unhandled
+ (allocate-registers) ;
--- /dev/null
+USING: compiler.cfg.linear-scan.assignment tools.test ;
+IN: compiler.cfg.linear-scan.assignment.tests
+
+\ assign-registers must-infer
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math assocs namespaces sequences heaps
+fry make combinators
+cpu.architecture
+compiler.cfg.def-use
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.assignment
+
+! A vector of live intervals. There is linear searching involved
+! but since we never have too many machine registers (around 30
+! at most) and we probably won't have that many live at any one
+! time anyway, it is not a problem to check each element.
+SYMBOL: active-intervals
+
+: add-active ( live-interval -- )
+ active-intervals get push ;
+
+: lookup-register ( vreg -- reg )
+ active-intervals get [ vreg>> = ] with find nip reg>> ;
+
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
+
+: add-unhandled ( live-interval -- )
+ dup split-before>> [
+ [ split-before>> ] [ split-after>> ] bi
+ [ add-unhandled ] bi@
+ ] [
+ dup start>> unhandled-intervals get heap-push
+ ] if ;
+
+: init-unhandled ( live-intervals -- )
+ [ add-unhandled ] each ;
+
+: insert-spill ( live-interval -- )
+ [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri
+ dup [ _spill ] [ 3drop ] if ;
+
+: expire-old-intervals ( n -- )
+ active-intervals get
+ swap '[ end>> _ = ] partition
+ active-intervals set
+ [ insert-spill ] each ;
+
+: insert-reload ( live-interval -- )
+ [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri
+ dup [ _reload ] [ 3drop ] if ;
+
+: activate-new-intervals ( n -- )
+ #! Any live intervals which start on the current instruction
+ #! are added to the active set.
+ unhandled-intervals get dup heap-empty? [ 2drop ] [
+ 2dup heap-peek drop start>> = [
+ heap-pop drop [ add-active ] [ insert-reload ] bi
+ activate-new-intervals
+ ] [ 2drop ] if
+ ] if ;
+
+GENERIC: (assign-registers) ( insn -- )
+
+M: vreg-insn (assign-registers)
+ dup
+ [ defs-vregs ] [ uses-vregs ] bi append
+ active-intervals get swap '[ vreg>> _ member? ] filter
+ [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
+ >>regs drop ;
+
+M: insn (assign-registers) drop ;
+
+: init-assignment ( live-intervals -- )
+ V{ } clone active-intervals set
+ <min-heap> unhandled-intervals set
+ init-unhandled ;
+
+: assign-registers ( insns live-intervals -- insns' )
+ [
+ init-assignment
+ [
+ [ activate-new-intervals ]
+ [ drop [ (assign-registers) ] [ , ] bi ]
+ [ expire-old-intervals ]
+ tri
+ ] each-index
+ ] { } make ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences sets arrays math strings fry
+prettyprint compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation ;
+IN: compiler.cfg.linear-scan.debugger
+
+: check-assigned ( live-intervals -- )
+ [
+ reg>>
+ [ "Not all intervals have registers" throw ] unless
+ ] each ;
+
+: split-children ( live-interval -- seq )
+ dup split-before>> [
+ [ split-before>> ] [ split-after>> ] bi
+ [ split-children ] bi@
+ append
+ ] [ 1array ] if ;
+
+: check-linear-scan ( live-intervals machine-registers -- )
+ [ [ clone ] map ] dip allocate-registers
+ [ split-children ] map concat check-assigned ;
+
+: picture ( uses -- str )
+ dup peek 1 + CHAR: space <string>
+ [ '[ CHAR: * swap _ set-nth ] each ] keep ;
+
+: interval-picture ( interval -- str )
+ [ uses>> picture ]
+ [ copy-from>> unparse ]
+ [ vreg>> unparse ]
+ tri 3array ;
+
+: live-intervals. ( seq -- )
+ [ interval-picture ] map simple-table. ;
--- /dev/null
+IN: compiler.cfg.linear-scan.tests
+USING: tools.test random sorting sequences sets hashtables assocs
+kernel fry arrays splitting namespaces math accessors vectors
+math.order
+cpu.architecture
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.linear-scan
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.debugger ;
+
+[ 7 ] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { start 0 }
+ { end 10 }
+ { uses V{ 0 1 3 7 10 } }
+ }
+ 4 [ >= ] find-use nip
+] unit-test
+
+[ 4 ] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { start 0 }
+ { end 10 }
+ { uses V{ 0 1 3 4 10 } }
+ }
+ 4 [ >= ] find-use nip
+] unit-test
+
+[ f ] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { start 0 }
+ { end 10 }
+ { uses V{ 0 1 3 4 10 } }
+ }
+ 100 [ >= ] find-use nip
+] unit-test
+
+[
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 1 }
+ { uses V{ 0 1 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 5 }
+ { end 5 }
+ { uses V{ 5 } }
+ }
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 5 }
+ { uses V{ 0 1 5 } }
+ } 2 split-interval
+] unit-test
+
+[
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 0 }
+ { uses V{ 0 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 1 }
+ { end 5 }
+ { uses V{ 1 5 } }
+ }
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 5 }
+ { uses V{ 0 1 5 } }
+ } 0 split-interval
+] unit-test
+
+[
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 3 }
+ { end 10 }
+ { uses V{ 3 10 } }
+ }
+] [
+ {
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 1 }
+ { end 15 }
+ { uses V{ 1 3 7 10 15 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 3 }
+ { end 8 }
+ { uses V{ 3 4 8 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 3 }
+ { end 10 }
+ { uses V{ 3 10 } }
+ }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 5 }
+ { end 5 }
+ { uses V{ 5 } }
+ }
+ interval-to-spill
+] unit-test
+
+[ t ] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 5 }
+ { end 15 }
+ { uses V{ 5 10 15 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 1 }
+ { end 20 }
+ { uses V{ 1 20 } }
+ }
+ spill-existing?
+] unit-test
+
+[ f ] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 5 }
+ { end 15 }
+ { uses V{ 5 10 15 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 1 }
+ { end 20 }
+ { uses V{ 1 7 20 } }
+ }
+ spill-existing?
+] unit-test
+
+[ t ] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 5 }
+ { end 5 }
+ { uses V{ 5 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 1 }
+ { end 20 }
+ { uses V{ 1 7 20 } }
+ }
+ spill-existing?
+] unit-test
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+ }
+ H{ { int-regs { "A" } } }
+ check-linear-scan
+] unit-test
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
+ }
+ H{ { int-regs { "A" } } }
+ check-linear-scan
+] unit-test
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
+ }
+ H{ { int-regs { "A" } } }
+ check-linear-scan
+] unit-test
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
+ }
+ H{ { int-regs { "A" } } }
+ check-linear-scan
+] unit-test
+
+[
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } }
+ }
+ H{ { int-regs { "A" } } }
+ check-linear-scan
+] must-fail
+
+SYMBOL: available
+
+SYMBOL: taken
+
+SYMBOL: max-registers
+
+SYMBOL: max-insns
+
+SYMBOL: max-uses
+
+: not-taken ( -- n )
+ available get keys dup empty? [ "Oops" throw ] when
+ random
+ dup taken get nth 1 + max-registers get = [
+ dup available get delete-at
+ ] [
+ dup taken get [ 1 + ] change-nth
+ ] if ;
+
+: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq )
+ [
+ max-insns set
+ max-registers set
+ max-uses set
+ max-insns get [ 0 ] replicate taken set
+ max-insns get [ dup ] H{ } map>assoc available set
+ [
+ live-interval new
+ swap int-regs swap vreg boa >>vreg
+ max-uses get random 2 max [ not-taken ] replicate natural-sort
+ [ >>uses ] [ first >>start ] bi
+ dup uses>> peek >>end
+ ] map
+ ] with-scope ;
+
+: random-test ( num-intervals max-uses max-registers max-insns -- )
+ over >r random-live-intervals r> int-regs associate check-linear-scan ;
+
+[ ] [ 30 2 1 60 random-test ] unit-test
+[ ] [ 60 2 2 60 random-test ] unit-test
+[ ] [ 80 2 3 200 random-test ] unit-test
+[ ] [ 70 2 5 30 random-test ] unit-test
+[ ] [ 60 2 6 30 random-test ] unit-test
+[ ] [ 1 2 10 10 random-test ] unit-test
+
+[ ] [ 10 4 2 60 random-test ] unit-test
+[ ] [ 10 20 2 400 random-test ] unit-test
+[ ] [ 10 20 4 300 random-test ] unit-test
+
+USING: math.private compiler.cfg.debugger ;
+
+[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
+
+[ f ] [
+ T{ ##allot
+ f
+ T{ vreg f int-regs 1 }
+ 40
+ array
+ T{ vreg f int-regs 2 }
+ f
+ } clone
+ 1array (linear-scan) first regs>> values all-equal?
+] unit-test
+
+[ 0 1 ] [
+ {
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 5 }
+ { uses V{ 0 1 5 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { start 3 }
+ { end 4 }
+ { uses V{ 3 4 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { start 2 }
+ { end 6 }
+ { uses V{ 2 4 6 } }
+ }
+ } [ clone ] map
+ H{ { int-regs { "A" "B" } } }
+ allocate-registers
+ first split-before>> [ start>> ] [ end>> ] bi
+] unit-test
+
+! Coalescing interacted badly with splitting
+[ ] [
+ {
+ T{ live-interval
+ { vreg V int-regs 70 }
+ { start 14 }
+ { end 17 }
+ { uses V{ 14 15 16 17 } }
+ { copy-from V int-regs 67 }
+ }
+ T{ live-interval
+ { vreg V int-regs 67 }
+ { start 13 }
+ { end 14 }
+ { uses V{ 13 14 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 30 }
+ { start 4 }
+ { end 18 }
+ { uses V{ 4 12 16 17 18 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 27 }
+ { start 3 }
+ { end 13 }
+ { uses V{ 3 7 13 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 59 }
+ { start 10 }
+ { end 18 }
+ { uses V{ 10 11 12 18 } }
+ { copy-from V int-regs 56 }
+ }
+ T{ live-interval
+ { vreg V int-regs 60 }
+ { start 12 }
+ { end 17 }
+ { uses V{ 12 17 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 56 }
+ { start 9 }
+ { end 10 }
+ { uses V{ 9 10 } }
+ }
+ }
+ { { int-regs { 0 1 2 3 } } }
+ allocate-registers drop
+] unit-test
+
+[ ] [
+ {
+ T{ live-interval
+ { vreg V int-regs 3687168 }
+ { start 106 }
+ { end 112 }
+ { uses V{ 106 112 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687169 }
+ { start 107 }
+ { end 113 }
+ { uses V{ 107 113 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687727 }
+ { start 190 }
+ { end 198 }
+ { uses V{ 190 195 198 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686445 }
+ { start 43 }
+ { end 44 }
+ { uses V{ 43 44 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686195 }
+ { start 5 }
+ { end 11 }
+ { uses V{ 5 11 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686449 }
+ { start 44 }
+ { end 56 }
+ { uses V{ 44 45 45 46 56 } }
+ { copy-from V int-regs 3686445 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686198 }
+ { start 8 }
+ { end 10 }
+ { uses V{ 8 9 10 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686454 }
+ { start 46 }
+ { end 49 }
+ { uses V{ 46 47 47 49 } }
+ { copy-from V int-regs 3686449 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686196 }
+ { start 6 }
+ { end 12 }
+ { uses V{ 6 12 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686197 }
+ { start 7 }
+ { end 14 }
+ { uses V{ 7 13 14 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686455 }
+ { start 48 }
+ { end 51 }
+ { uses V{ 48 51 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686463 }
+ { start 52 }
+ { end 53 }
+ { uses V{ 52 53 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686460 }
+ { start 49 }
+ { end 52 }
+ { uses V{ 49 50 50 52 } }
+ { copy-from V int-regs 3686454 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686461 }
+ { start 51 }
+ { end 71 }
+ { uses V{ 51 52 64 68 71 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686464 }
+ { start 53 }
+ { end 54 }
+ { uses V{ 53 54 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686465 }
+ { start 54 }
+ { end 76 }
+ { uses V{ 54 55 55 76 } }
+ { copy-from V int-regs 3686464 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686470 }
+ { start 58 }
+ { end 60 }
+ { uses V{ 58 59 59 60 } }
+ { copy-from V int-regs 3686469 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686469 }
+ { start 56 }
+ { end 58 }
+ { uses V{ 56 57 57 58 } }
+ { copy-from V int-regs 3686449 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686473 }
+ { start 60 }
+ { end 62 }
+ { uses V{ 60 61 61 62 } }
+ { copy-from V int-regs 3686470 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686479 }
+ { start 62 }
+ { end 64 }
+ { uses V{ 62 63 63 64 } }
+ { copy-from V int-regs 3686473 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686735 }
+ { start 78 }
+ { end 96 }
+ { uses V{ 78 79 79 96 } }
+ { copy-from V int-regs 3686372 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686482 }
+ { start 64 }
+ { end 65 }
+ { uses V{ 64 65 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686483 }
+ { start 65 }
+ { end 66 }
+ { uses V{ 65 66 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687510 }
+ { start 168 }
+ { end 171 }
+ { uses V{ 168 171 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687511 }
+ { start 169 }
+ { end 176 }
+ { uses V{ 169 176 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686484 }
+ { start 66 }
+ { end 75 }
+ { uses V{ 66 67 67 75 } }
+ { copy-from V int-regs 3686483 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687509 }
+ { start 162 }
+ { end 163 }
+ { uses V{ 162 163 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686491 }
+ { start 68 }
+ { end 69 }
+ { uses V{ 68 69 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687512 }
+ { start 170 }
+ { end 178 }
+ { uses V{ 170 177 178 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687515 }
+ { start 172 }
+ { end 173 }
+ { uses V{ 172 173 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686492 }
+ { start 69 }
+ { end 74 }
+ { uses V{ 69 70 70 74 } }
+ { copy-from V int-regs 3686491 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687778 }
+ { start 202 }
+ { end 208 }
+ { uses V{ 202 208 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686499 }
+ { start 71 }
+ { end 72 }
+ { uses V{ 71 72 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687520 }
+ { start 174 }
+ { end 175 }
+ { uses V{ 174 175 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687779 }
+ { start 203 }
+ { end 209 }
+ { uses V{ 203 209 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687782 }
+ { start 206 }
+ { end 207 }
+ { uses V{ 206 207 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686503 }
+ { start 74 }
+ { end 75 }
+ { uses V{ 74 75 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686500 }
+ { start 72 }
+ { end 74 }
+ { uses V{ 72 73 73 74 } }
+ { copy-from V int-regs 3686499 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687780 }
+ { start 204 }
+ { end 210 }
+ { uses V{ 204 210 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686506 }
+ { start 75 }
+ { end 76 }
+ { uses V{ 75 76 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687530 }
+ { start 185 }
+ { end 192 }
+ { uses V{ 185 192 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687528 }
+ { start 183 }
+ { end 198 }
+ { uses V{ 183 198 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687529 }
+ { start 184 }
+ { end 197 }
+ { uses V{ 184 197 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687781 }
+ { start 205 }
+ { end 211 }
+ { uses V{ 205 211 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687535 }
+ { start 187 }
+ { end 194 }
+ { uses V{ 187 194 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686252 }
+ { start 9 }
+ { end 17 }
+ { uses V{ 9 15 17 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686509 }
+ { start 76 }
+ { end 90 }
+ { uses V{ 76 87 90 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687532 }
+ { start 186 }
+ { end 196 }
+ { uses V{ 186 196 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687538 }
+ { start 188 }
+ { end 193 }
+ { uses V{ 188 193 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687827 }
+ { start 217 }
+ { end 219 }
+ { uses V{ 217 219 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687825 }
+ { start 215 }
+ { end 218 }
+ { uses V{ 215 216 218 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687831 }
+ { start 218 }
+ { end 219 }
+ { uses V{ 218 219 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686296 }
+ { start 16 }
+ { end 18 }
+ { uses V{ 16 18 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686302 }
+ { start 29 }
+ { end 31 }
+ { uses V{ 29 31 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687838 }
+ { start 231 }
+ { end 232 }
+ { uses V{ 231 232 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686300 }
+ { start 26 }
+ { end 27 }
+ { uses V{ 26 27 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686301 }
+ { start 27 }
+ { end 30 }
+ { uses V{ 27 28 28 30 } }
+ { copy-from V int-regs 3686300 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686306 }
+ { start 37 }
+ { end 93 }
+ { uses V{ 37 82 93 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686307 }
+ { start 38 }
+ { end 88 }
+ { uses V{ 38 85 88 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687837 }
+ { start 222 }
+ { end 223 }
+ { uses V{ 222 223 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686305 }
+ { start 36 }
+ { end 81 }
+ { uses V{ 36 42 77 81 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686310 }
+ { start 39 }
+ { end 95 }
+ { uses V{ 39 84 95 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687836 }
+ { start 227 }
+ { end 228 }
+ { uses V{ 227 228 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687839 }
+ { start 239 }
+ { end 246 }
+ { uses V{ 239 245 246 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687841 }
+ { start 240 }
+ { end 241 }
+ { uses V{ 240 241 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687845 }
+ { start 241 }
+ { end 243 }
+ { uses V{ 241 243 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686315 }
+ { start 40 }
+ { end 94 }
+ { uses V{ 40 83 94 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687846 }
+ { start 242 }
+ { end 245 }
+ { uses V{ 242 245 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687849 }
+ { start 243 }
+ { end 245 }
+ { uses V{ 243 244 244 245 } }
+ { copy-from V int-regs 3687845 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687850 }
+ { start 245 }
+ { end 245 }
+ { uses V{ 245 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687851 }
+ { start 246 }
+ { end 246 }
+ { uses V{ 246 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687852 }
+ { start 246 }
+ { end 246 }
+ { uses V{ 246 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687853 }
+ { start 247 }
+ { end 248 }
+ { uses V{ 247 248 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687854 }
+ { start 249 }
+ { end 250 }
+ { uses V{ 249 250 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687855 }
+ { start 258 }
+ { end 259 }
+ { uses V{ 258 259 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687080 }
+ { start 280 }
+ { end 285 }
+ { uses V{ 280 285 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687081 }
+ { start 281 }
+ { end 286 }
+ { uses V{ 281 286 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687082 }
+ { start 282 }
+ { end 287 }
+ { uses V{ 282 287 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687083 }
+ { start 283 }
+ { end 288 }
+ { uses V{ 283 288 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687085 }
+ { start 284 }
+ { end 299 }
+ { uses V{ 284 285 286 287 288 296 299 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687086 }
+ { start 284 }
+ { end 284 }
+ { uses V{ 284 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687087 }
+ { start 289 }
+ { end 293 }
+ { uses V{ 289 293 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687088 }
+ { start 290 }
+ { end 294 }
+ { uses V{ 290 294 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687089 }
+ { start 291 }
+ { end 297 }
+ { uses V{ 291 297 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687090 }
+ { start 292 }
+ { end 298 }
+ { uses V{ 292 298 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687363 }
+ { start 118 }
+ { end 119 }
+ { uses V{ 118 119 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686599 }
+ { start 77 }
+ { end 89 }
+ { uses V{ 77 86 89 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687370 }
+ { start 131 }
+ { end 132 }
+ { uses V{ 131 132 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687371 }
+ { start 138 }
+ { end 143 }
+ { uses V{ 138 143 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687368 }
+ { start 127 }
+ { end 128 }
+ { uses V{ 127 128 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687369 }
+ { start 122 }
+ { end 123 }
+ { uses V{ 122 123 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687373 }
+ { start 139 }
+ { end 140 }
+ { uses V{ 139 140 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686352 }
+ { start 41 }
+ { end 91 }
+ { uses V{ 41 43 79 91 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687377 }
+ { start 140 }
+ { end 141 }
+ { uses V{ 140 141 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687382 }
+ { start 143 }
+ { end 143 }
+ { uses V{ 143 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687383 }
+ { start 144 }
+ { end 161 }
+ { uses V{ 144 159 161 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687380 }
+ { start 141 }
+ { end 143 }
+ { uses V{ 141 142 142 143 } }
+ { copy-from V int-regs 3687377 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687381 }
+ { start 143 }
+ { end 160 }
+ { uses V{ 143 160 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687384 }
+ { start 145 }
+ { end 158 }
+ { uses V{ 145 158 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687385 }
+ { start 146 }
+ { end 157 }
+ { uses V{ 146 157 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687640 }
+ { start 189 }
+ { end 191 }
+ { uses V{ 189 191 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687388 }
+ { start 147 }
+ { end 152 }
+ { uses V{ 147 152 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687393 }
+ { start 148 }
+ { end 153 }
+ { uses V{ 148 153 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687398 }
+ { start 149 }
+ { end 154 }
+ { uses V{ 149 154 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686372 }
+ { start 42 }
+ { end 92 }
+ { uses V{ 42 45 78 80 92 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687140 }
+ { start 293 }
+ { end 295 }
+ { uses V{ 293 294 294 295 } }
+ { copy-from V int-regs 3687087 }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687403 }
+ { start 150 }
+ { end 155 }
+ { uses V{ 150 155 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687150 }
+ { start 304 }
+ { end 306 }
+ { uses V{ 304 306 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687151 }
+ { start 305 }
+ { end 307 }
+ { uses V{ 305 307 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687408 }
+ { start 151 }
+ { end 156 }
+ { uses V{ 151 156 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687153 }
+ { start 312 }
+ { end 313 }
+ { uses V{ 312 313 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686902 }
+ { start 267 }
+ { end 272 }
+ { uses V{ 267 272 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686903 }
+ { start 268 }
+ { end 273 }
+ { uses V{ 268 273 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686900 }
+ { start 265 }
+ { end 270 }
+ { uses V{ 265 270 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686901 }
+ { start 266 }
+ { end 271 }
+ { uses V{ 266 271 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687162 }
+ { start 100 }
+ { end 119 }
+ { uses V{ 100 114 117 119 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687163 }
+ { start 101 }
+ { end 118 }
+ { uses V{ 101 115 116 118 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3686904 }
+ { start 269 }
+ { end 274 }
+ { uses V{ 269 274 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687166 }
+ { start 104 }
+ { end 110 }
+ { uses V{ 104 110 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687167 }
+ { start 105 }
+ { end 111 }
+ { uses V{ 105 111 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687164 }
+ { start 102 }
+ { end 108 }
+ { uses V{ 102 108 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 3687165 }
+ { start 103 }
+ { end 109 }
+ { uses V{ 103 109 } }
+ }
+ }
+ { { int-regs { 0 1 2 3 4 } } }
+ allocate-registers drop
+] unit-test
+
+! A reduction of the above
+[ ] [
+ {
+ T{ live-interval
+ { vreg V int-regs 6449 }
+ { start 44 }
+ { end 56 }
+ { uses V{ 44 45 46 56 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 6454 }
+ { start 46 }
+ { end 49 }
+ { uses V{ 46 47 49 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 6455 }
+ { start 48 }
+ { end 51 }
+ { uses V{ 48 51 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 6460 }
+ { start 49 }
+ { end 52 }
+ { uses V{ 49 50 52 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 6461 }
+ { start 51 }
+ { end 71 }
+ { uses V{ 51 52 64 68 71 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 6464 }
+ { start 53 }
+ { end 54 }
+ { uses V{ 53 54 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 6470 }
+ { start 58 }
+ { end 60 }
+ { uses V{ 58 59 60 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 6469 }
+ { start 56 }
+ { end 58 }
+ { uses V{ 56 57 58 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 6473 }
+ { start 60 }
+ { end 62 }
+ { uses V{ 60 61 62 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 6479 }
+ { start 62 }
+ { end 64 }
+ { uses V{ 62 63 64 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 6735 }
+ { start 78 }
+ { end 96 }
+ { uses V{ 78 79 96 } }
+ { copy-from V int-regs 6372 }
+ }
+ T{ live-interval
+ { vreg V int-regs 6483 }
+ { start 65 }
+ { end 66 }
+ { uses V{ 65 66 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 7845 }
+ { start 91 }
+ { end 93 }
+ { uses V{ 91 93 } }
+ }
+ T{ live-interval
+ { vreg V int-regs 6372 }
+ { start 42 }
+ { end 92 }
+ { uses V{ 42 45 78 80 92 } }
+ }
+ }
+ { { int-regs { 0 1 2 3 } } }
+ allocate-registers drop
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces make
+cpu.architecture
+compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.assignment ;
+IN: compiler.cfg.linear-scan
+
+! References:
+
+! Linear Scan Register Allocation
+! by Massimiliano Poletto and Vivek Sarkar
+! http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
+
+! Linear Scan Register Allocation for the Java HotSpot Client Compiler
+! by Christian Wimmer
+! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
+
+! Quality and Speed in Linear-scan Register Allocation
+! by Omri Traub, Glenn Holloway, Michael D. Smith
+! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
+
+: (linear-scan) ( insns -- insns' )
+ dup compute-live-intervals
+ machine-registers allocate-registers assign-registers ;
+
+: linear-scan ( mr -- mr' )
+ [
+ [
+ [
+ (linear-scan) %
+ spill-counts get _spill-counts
+ ] { } make
+ ] change-instructions
+ ] with-scope ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel assocs accessors sequences math fry
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.def-use ;
+IN: compiler.cfg.linear-scan.live-intervals
+
+TUPLE: live-interval
+vreg
+reg spill-to reload-from split-before split-after
+start end uses
+copy-from ;
+
+: add-use ( n live-interval -- )
+ dup live-interval? [ "No def" throw ] unless
+ [ (>>end) ] [ uses>> push ] 2bi ;
+
+: <live-interval> ( start vreg -- live-interval )
+ live-interval new
+ V{ } clone >>uses
+ swap >>vreg
+ over >>start
+ [ add-use ] keep ;
+
+M: live-interval hashcode*
+ nip [ start>> ] [ end>> 1000 * ] bi + ;
+
+M: live-interval clone
+ call-next-method [ clone ] change-uses ;
+
+! Mapping from vreg to live-interval
+SYMBOL: live-intervals
+
+: new-live-interval ( n vreg live-intervals -- )
+ 2dup key? [
+ at add-use
+ ] [
+ [ [ <live-interval> ] keep ] dip set-at
+ ] if ;
+
+GENERIC# compute-live-intervals* 1 ( insn n -- )
+
+M: insn compute-live-intervals* 2drop ;
+
+M: vreg-insn compute-live-intervals*
+ live-intervals get
+ [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
+ [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+ 3bi ;
+
+: record-copy ( insn -- )
+ [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
+
+M: ##copy compute-live-intervals*
+ [ call-next-method ] [ drop record-copy ] 2bi ;
+
+M: ##copy-float compute-live-intervals*
+ [ call-next-method ] [ drop record-copy ] 2bi ;
+
+: compute-live-intervals ( instructions -- live-intervals )
+ H{ } clone [
+ live-intervals set
+ [ compute-live-intervals* ] each-index
+ ] keep values ;
--- /dev/null
+IN: compiler.cfg.linearization.tests
+USING: compiler.cfg.linearization tools.test ;
+
+\ build-mr must-infer
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math accessors sequences namespaces make
+combinators classes
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.instructions ;
+IN: compiler.cfg.linearization
+
+! Convert CFG IR to machine IR.
+GENERIC: linearize-insn ( basic-block insn -- )
+
+: linearize-insns ( basic-block -- )
+ dup instructions>> [ linearize-insn ] with each ; inline
+
+M: insn linearize-insn , drop ;
+
+: useless-branch? ( basic-block successor -- ? )
+ #! If our successor immediately follows us in RPO, then we
+ #! don't need to branch.
+ [ number>> ] bi@ 1- = ; inline
+
+: branch-to-branch? ( successor -- ? )
+ #! A branch to a block containing just a jump return is cloned.
+ instructions>> dup length 2 = [
+ [ first ##epilogue? ]
+ [ second [ ##return? ] [ ##jump? ] bi or ] bi and
+ ] [ drop f ] if ;
+
+: emit-branch ( basic-block successor -- )
+ {
+ { [ 2dup useless-branch? ] [ 2drop ] }
+ { [ dup branch-to-branch? ] [ nip linearize-insns ] }
+ [ nip number>> _branch ]
+ } cond ;
+
+M: ##branch linearize-insn
+ drop dup successors>> first emit-branch ;
+
+: (binary-conditional)
+ [ dup successors>> first2 ]
+ [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
+
+: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
+ [ (binary-conditional) ]
+ [ drop dup successors>> first useless-branch? ] 2bi
+ [ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
+
+M: ##compare-branch linearize-insn
+ binary-conditional _compare-branch emit-branch ;
+
+M: ##compare-imm-branch linearize-insn
+ binary-conditional _compare-imm-branch emit-branch ;
+
+M: ##compare-float-branch linearize-insn
+ binary-conditional _compare-float-branch emit-branch ;
+
+: gc? ( bb -- ? )
+ instructions>> [
+ class {
+ ##allot
+ ##integer>bignum
+ ##box-float
+ ##box-alien
+ } memq?
+ ] contains? ;
+
+: linearize-basic-block ( bb -- )
+ [ number>> _label ]
+ [ gc? [ _gc ] when ]
+ [ linearize-insns ]
+ tri ;
+
+: linearize-basic-blocks ( rpo -- insns )
+ [ [ linearize-basic-block ] each ] { } make ;
+
+: build-mr ( cfg -- mr )
+ [ entry>> reverse-post-order linearize-basic-blocks ]
+ [ word>> ] [ label>> ]
+ tri <mr> ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences compiler.cfg.rpo
+compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.useless-blocks
+compiler.cfg.height
+compiler.cfg.alias-analysis
+compiler.cfg.value-numbering
+compiler.cfg.dead-code
+compiler.cfg.write-barrier ;
+IN: compiler.cfg.optimizer
+
+: trivial? ( insns -- ? )
+ dup length 2 = [ first ##call? ] [ drop f ] if ;
+
+: optimize-cfg ( cfg -- cfg' )
+ compute-predecessors
+ delete-useless-blocks
+ delete-useless-conditionals
+ [
+ dup trivial? [
+ normalize-height
+ alias-analysis
+ value-numbering
+ eliminate-dead-code
+ eliminate-write-barriers
+ ] unless
+ ] change-basic-blocks ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences compiler.cfg.rpo ;
+IN: compiler.cfg.predecessors
+
+: (compute-predecessors) ( bb -- )
+ dup successors>> [ predecessors>> push ] with each ;
+
+: compute-predecessors ( cfg -- cfg' )
+ dup [ (compute-predecessors) ] each-basic-block ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces kernel arrays
+parser prettyprint.backend prettyprint.sections ;
+IN: compiler.cfg.registers
+
+! Virtual registers, used by CFG and machine IRs
+TUPLE: vreg { reg-class read-only } { n read-only } ;
+SYMBOL: vreg-counter
+: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
+
+! Stack locations
+TUPLE: loc { n read-only } ;
+
+TUPLE: ds-loc < loc ;
+C: <ds-loc> ds-loc
+
+TUPLE: rs-loc < loc ;
+C: <rs-loc> rs-loc
+
+! Prettyprinting
+: V scan-word scan-word vreg boa parsed ; parsing
+
+M: vreg pprint*
+ <block
+ \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
+ block> ;
+
+: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
+
+: D scan-word <ds-loc> parsed ; parsing
+
+M: ds-loc pprint* \ D pprint-loc ;
+
+: R scan-word <rs-loc> parsed ; parsing
+
+M: rs-loc pprint* \ R pprint-loc ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces make math sequences sets
+assocs fry compiler.cfg.instructions ;
+IN: compiler.cfg.rpo
+
+SYMBOL: visited
+
+: post-order-traversal ( bb -- )
+ dup id>> visited get key? [ drop ] [
+ dup id>> visited get conjoin
+ [ successors>> [ post-order-traversal ] each ] [ , ] bi
+ ] if ;
+
+: post-order ( bb -- blocks )
+ [ post-order-traversal ] { } make ;
+
+: number-blocks ( blocks -- )
+ [ >>number drop ] each-index ;
+
+: reverse-post-order ( bb -- blocks )
+ H{ } clone visited [
+ post-order <reversed> dup number-blocks
+ ] with-variable ; inline
+
+: each-basic-block ( cfg quot -- )
+ [ entry>> reverse-post-order ] dip each ; inline
+
+: change-basic-blocks ( cfg quot -- cfg' )
+ [ '[ _ change-instructions drop ] each-basic-block ]
+ [ drop ]
+ 2bi ; inline
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces accessors math.order assocs kernel sequences
+combinators make classes words cpu.architecture
+compiler.cfg.instructions compiler.cfg.registers ;
+IN: compiler.cfg.stack-frame
+
+SYMBOL: frame-required?
+
+SYMBOL: spill-counts
+
+GENERIC: compute-stack-frame* ( insn -- )
+
+: max-stack-frame ( frame1 frame2 -- frame3 )
+ [ stack-frame new ] 2dip
+ [ [ params>> ] bi@ max >>params ]
+ [ [ return>> ] bi@ max >>return ]
+ 2bi ;
+
+M: ##stack-frame compute-stack-frame*
+ frame-required? on
+ stack-frame>> stack-frame [ max-stack-frame ] change ;
+
+M: ##call compute-stack-frame*
+ word>> sub-primitive>> [ frame-required? on ] unless ;
+
+M: _spill-counts compute-stack-frame*
+ counts>> stack-frame get (>>spill-counts) ;
+
+M: insn compute-stack-frame*
+ class frame-required? word-prop [
+ frame-required? on
+ ] when ;
+
+\ _gc t frame-required? set-word-prop
+\ _spill t frame-required? set-word-prop
+
+: compute-stack-frame ( insns -- )
+ frame-required? off
+ T{ stack-frame } clone stack-frame set
+ [ compute-stack-frame* ] each
+ stack-frame get dup stack-frame-size >>total-size drop ;
+
+GENERIC: insert-pro/epilogues* ( insn -- )
+
+M: ##stack-frame insert-pro/epilogues* drop ;
+
+M: ##prologue insert-pro/epilogues*
+ drop frame-required? get [ stack-frame get _prologue ] when ;
+
+M: ##epilogue insert-pro/epilogues*
+ drop frame-required? get [ stack-frame get _epilogue ] when ;
+
+M: insn insert-pro/epilogues* , ;
+
+: insert-pro/epilogues ( insns -- insns )
+ [ [ insert-pro/epilogues* ] each ] { } make ;
+
+: build-stack-frame ( mr -- mr )
+ [
+ [
+ [ compute-stack-frame ]
+ [ insert-pro/epilogues ]
+ bi
+ ] change-instructions
+ ] with-scope ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math sequences kernel cpu.architecture
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.hats ;
+IN: compiler.cfg.stacks
+
+: ds-drop ( -- )
+ -1 ##inc-d ;
+
+: ds-pop ( -- vreg )
+ D 0 ^^peek -1 ##inc-d ;
+
+: ds-push ( vreg -- )
+ 1 ##inc-d D 0 ##replace ;
+
+: ds-load ( n -- vregs )
+ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
+
+: ds-store ( vregs -- )
+ <reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
+
+: rs-load ( n -- vregs )
+ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
+
+: rs-store ( vregs -- )
+ <reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
+
+: 2inputs ( -- vreg1 vreg2 )
+ D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
+
+: 3inputs ( -- vreg1 vreg2 vreg3 )
+ D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel sequences sequences.deep
+compiler.cfg.instructions cpu.architecture ;
+IN: compiler.cfg.two-operand
+
+! On x86, instructions take the form x = x op y
+! Our SSA IR is x = y op z
+
+! We don't bother with ##add, ##add-imm or ##sub-imm since x86
+! has a LEA instruction which is effectively a three-operand
+! addition
+
+: make-copy ( dst src -- insn ) f \ ##copy boa ; inline
+
+: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline
+
+: convert-two-operand/integer ( insn -- insns )
+ [ [ dst>> ] [ src1>> ] bi make-copy ]
+ [ dup dst>> >>src1 ]
+ bi 2array ; inline
+
+: convert-two-operand/float ( insn -- insns )
+ [ [ dst>> ] [ src1>> ] bi make-copy/float ]
+ [ dup dst>> >>src1 ]
+ bi 2array ; inline
+
+GENERIC: convert-two-operand* ( insn -- insns )
+
+M: ##not convert-two-operand*
+ [ [ dst>> ] [ src>> ] bi make-copy ]
+ [ dup dst>> >>src ]
+ bi 2array ;
+
+M: ##sub convert-two-operand* convert-two-operand/integer ;
+M: ##mul convert-two-operand* convert-two-operand/integer ;
+M: ##mul-imm convert-two-operand* convert-two-operand/integer ;
+M: ##and convert-two-operand* convert-two-operand/integer ;
+M: ##and-imm convert-two-operand* convert-two-operand/integer ;
+M: ##or convert-two-operand* convert-two-operand/integer ;
+M: ##or-imm convert-two-operand* convert-two-operand/integer ;
+M: ##xor convert-two-operand* convert-two-operand/integer ;
+M: ##xor-imm convert-two-operand* convert-two-operand/integer ;
+M: ##shl-imm convert-two-operand* convert-two-operand/integer ;
+M: ##shr-imm convert-two-operand* convert-two-operand/integer ;
+M: ##sar-imm convert-two-operand* convert-two-operand/integer ;
+
+M: ##add-float convert-two-operand* convert-two-operand/float ;
+M: ##sub-float convert-two-operand* convert-two-operand/float ;
+M: ##mul-float convert-two-operand* convert-two-operand/float ;
+M: ##div-float convert-two-operand* convert-two-operand/float ;
+
+M: insn convert-two-operand* ;
+
+: convert-two-operand ( mr -- mr' )
+ [
+ two-operand? [
+ [ convert-two-operand* ] map flatten
+ ] when
+ ] change-instructions ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences combinators classes vectors
+compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
+IN: compiler.cfg.useless-blocks
+
+: update-predecessor-for-delete ( bb -- )
+ dup predecessors>> first [
+ [
+ 2dup eq? [ drop successors>> first ] [ nip ] if
+ ] with map
+ ] change-successors drop ;
+
+: update-successor-for-delete ( bb -- )
+ [ predecessors>> first ]
+ [ successors>> first predecessors>> ]
+ bi set-first ;
+
+: delete-basic-block ( bb -- )
+ [ update-predecessor-for-delete ]
+ [ update-successor-for-delete ]
+ bi ;
+
+: delete-basic-block? ( bb -- ? )
+ {
+ { [ dup instructions>> length 1 = not ] [ f ] }
+ { [ dup predecessors>> length 1 = not ] [ f ] }
+ { [ dup successors>> length 1 = not ] [ f ] }
+ { [ dup instructions>> first ##branch? not ] [ f ] }
+ [ t ]
+ } cond nip ;
+
+: delete-useless-blocks ( cfg -- cfg' )
+ dup [
+ dup delete-basic-block? [ delete-basic-block ] [ drop ] if
+ ] each-basic-block ;
+
+: delete-conditional? ( bb -- ? )
+ dup instructions>> [ drop f ] [
+ peek class {
+ ##compare-branch
+ ##compare-imm-branch
+ ##compare-float-branch
+ } memq? [ successors>> first2 eq? ] [ drop f ] if
+ ] if-empty ;
+
+: delete-conditional ( bb -- )
+ dup successors>> first 1vector >>successors
+ [ but-last f \ ##branch boa suffix ] change-instructions
+ drop ;
+
+: delete-useless-conditionals ( cfg -- cfg' )
+ dup [
+ dup delete-conditional? [ delete-conditional ] [ drop ] if
+ ] each-basic-block ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math layouts make sequences combinators
+cpu.architecture namespaces compiler.cfg
+compiler.cfg.instructions ;
+IN: compiler.cfg.utilities
+
+: value-info-small-fixnum? ( value-info -- ? )
+ literal>> {
+ { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+ [ drop f ]
+ } cond ;
+
+: value-info-small-tagged? ( value-info -- ? )
+ dup literal?>> [
+ literal>> {
+ { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+ { [ dup not ] [ drop t ] }
+ [ drop f ]
+ } cond
+ ] [ drop f ] if ;
+
+: set-basic-block ( basic-block -- )
+ [ basic-block set ] [ instructions>> building set ] bi ;
+
+: begin-basic-block ( -- )
+ <basic-block> basic-block get [
+ dupd successors>> push
+ ] when*
+ set-basic-block ;
+
+: end-basic-block ( -- )
+ building off
+ basic-block off ;
+
+: emit-primitive ( node -- )
+ word>> ##call ##branch begin-basic-block ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes kernel math namespaces combinators
+compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
+IN: compiler.cfg.value-numbering.expressions
+
+! Referentially-transparent expressions
+TUPLE: expr op ;
+TUPLE: unary-expr < expr in ;
+TUPLE: binary-expr < expr in1 in2 ;
+TUPLE: commutative-expr < binary-expr ;
+TUPLE: compare-expr < binary-expr cc ;
+TUPLE: constant-expr < expr value ;
+
+: <constant> ( constant -- expr )
+ f swap constant-expr boa ; inline
+
+M: constant-expr equal?
+ over constant-expr? [
+ [ [ value>> ] bi@ = ]
+ [ [ value>> class ] bi@ = ] 2bi
+ and
+ ] [ 2drop f ] if ;
+
+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 ;
+
+: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
+
+GENERIC: >expr ( insn -- expr )
+
+M: ##load-immediate >expr val>> <constant> ;
+
+M: ##load-indirect >expr obj>> <constant> ;
+
+M: ##unary >expr
+ [ class ] [ src>> vreg>vn ] bi unary-expr boa ;
+
+M: ##binary >expr
+ [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
+ binary-expr boa ;
+
+M: ##binary-imm >expr
+ [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
+ binary-expr boa ;
+
+M: ##commutative >expr
+ [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
+ commutative-expr boa ;
+
+M: ##commutative-imm >expr
+ [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
+ commutative-expr boa ;
+
+: compare>expr ( insn -- expr )
+ {
+ [ class ]
+ [ src1>> vreg>vn ]
+ [ src2>> vreg>vn ]
+ [ cc>> ]
+ } cleave compare-expr boa ; inline
+
+M: ##compare >expr compare>expr ;
+
+: compare-imm>expr ( insn -- expr )
+ {
+ [ class ]
+ [ src1>> vreg>vn ]
+ [ src2>> constant>vn ]
+ [ cc>> ]
+ } cleave compare-expr boa ; inline
+
+M: ##compare-imm >expr compare-imm>expr ;
+
+M: ##compare-float >expr compare>expr ;
+
+M: ##flushable >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: accessors kernel math namespaces assocs biassocs ;
+IN: compiler.cfg.value-numbering.graph
+
+SYMBOL: vn-counter
+
+: next-vn ( -- vn ) vn-counter [ dup 1 + ] change ;
+
+! 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 ;
+
+: vreg>expr ( vreg -- expr ) vreg>vn vn>expr ; inline
+
+: vn>constant ( vn -- constant ) vn>expr value>> ; inline
+
+: 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 assocs sequences kernel accessors
+compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
+IN: compiler.cfg.value-numbering.propagate
+
+! If two vregs compute the same value, replace references to
+! the latter with the former.
+
+: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline
+
+GENERIC: propagate ( insn -- insn )
+
+M: ##effect propagate
+ [ resolve ] change-src ;
+
+M: ##unary propagate
+ [ resolve ] change-src ;
+
+M: ##binary propagate
+ [ resolve ] change-src1
+ [ resolve ] change-src2 ;
+
+M: ##binary-imm propagate
+ [ resolve ] change-src1 ;
+
+M: ##slot propagate
+ [ resolve ] change-obj
+ [ resolve ] change-slot ;
+
+M: ##slot-imm propagate
+ [ resolve ] change-obj ;
+
+M: ##set-slot propagate
+ call-next-method
+ [ resolve ] change-obj
+ [ resolve ] change-slot ;
+
+M: ##string-nth propagate
+ [ resolve ] change-obj
+ [ resolve ] change-index ;
+
+M: ##set-slot-imm propagate
+ call-next-method
+ [ resolve ] change-obj ;
+
+M: ##alien-getter propagate
+ call-next-method
+ [ resolve ] change-src ;
+
+M: ##alien-setter propagate
+ call-next-method
+ [ resolve ] change-value ;
+
+M: ##conditional-branch propagate
+ [ resolve ] change-src1
+ [ resolve ] change-src2 ;
+
+M: ##compare-imm-branch propagate
+ [ resolve ] change-src1 ;
+
+M: ##dispatch propagate
+ [ resolve ] change-src ;
+
+M: insn propagate ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences layouts accessors combinators namespaces
+math
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.simplify
+compiler.cfg.value-numbering.expressions ;
+IN: compiler.cfg.value-numbering.rewrite
+
+GENERIC: rewrite ( insn -- insn' )
+
+M: ##mul-imm rewrite
+ dup src2>> dup power-of-2? [
+ [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa
+ dup number-values
+ ] [ drop ] if ;
+
+: ##branch-t? ( insn -- ? )
+ dup ##compare-imm-branch? [
+ [ cc>> cc/= eq? ]
+ [ src2>> \ f tag-number eq? ] bi and
+ ] [ drop f ] if ; inline
+
+: rewrite-boolean-comparison? ( insn -- ? )
+ dup ##branch-t? [
+ src1>> vreg>expr compare-expr?
+ ] [ drop f ] if ; inline
+
+: >compare-expr< ( expr -- in1 in2 cc )
+ [ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
+
+: >compare-imm-expr< ( expr -- in1 in2 cc )
+ [ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
+
+: rewrite-boolean-comparison ( expr -- insn )
+ src1>> vreg>expr dup op>> {
+ { \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
+ { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
+ { \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
+ } case ;
+
+: tag-fixnum-expr? ( expr -- ? )
+ dup op>> \ ##shl-imm eq?
+ [ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
+
+: rewrite-tagged-comparison? ( insn -- ? )
+ #! Are we comparing two tagged fixnums? Then untag them.
+ [ src1>> vreg>expr tag-fixnum-expr? ]
+ [ src2>> tag-mask get bitand 0 = ]
+ bi and ; inline
+
+: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
+ [ src1>> vreg>expr in1>> vn>vreg ]
+ [ src2>> tag-bits get neg shift ]
+ [ cc>> ]
+ tri ; inline
+
+GENERIC: rewrite-tagged-comparison ( insn -- insn' )
+
+M: ##compare-imm-branch rewrite-tagged-comparison
+ (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
+
+M: ##compare-imm rewrite-tagged-comparison
+ [ dst>> ] [ (rewrite-tagged-comparison) ] bi
+ f \ ##compare-imm boa ;
+
+M: ##compare-imm-branch rewrite
+ dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
+ dup ##compare-imm-branch? [
+ dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
+ ] when ;
+
+: flip-comparison? ( insn -- ? )
+ dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
+
+: flip-comparison ( insn -- insn' )
+ [ dst>> ]
+ [ src2>> ]
+ [ src1>> vreg>vn vn>constant ] tri
+ cc= f \ ##compare-imm boa ;
+
+M: ##compare rewrite
+ dup flip-comparison? [
+ flip-comparison
+ dup number-values
+ rewrite
+ ] when ;
+
+: rewrite-redundant-comparison? ( insn -- ? )
+ [ src1>> vreg>expr compare-expr? ]
+ [ src2>> \ f tag-number = ]
+ [ cc>> { cc= cc/= } memq? ]
+ tri and and ; inline
+
+: rewrite-redundant-comparison ( insn -- insn' )
+ [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
+ { \ ##compare [ >compare-expr< f \ ##compare boa ] }
+ { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
+ { \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
+ } case
+ swap cc= eq? [ [ negate-cc ] change-cc ] when ;
+
+M: ##compare-imm rewrite
+ dup rewrite-redundant-comparison? [
+ rewrite-redundant-comparison
+ dup number-values rewrite
+ ] when
+ dup ##compare-imm? [
+ dup rewrite-tagged-comparison? [
+ rewrite-tagged-comparison
+ dup number-values rewrite
+ ] when
+ ] when ;
+
+M: insn rewrite ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators classes math layouts
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.expressions ;
+IN: compiler.cfg.value-numbering.simplify
+
+! Return value of f means we didn't simplify.
+GENERIC: simplify* ( expr -- vn/expr/f )
+
+: simplify-unbox ( in boxer -- vn/expr/f )
+ over op>> eq? [ in>> ] [ drop f ] if ; inline
+
+: simplify-unbox-float ( in -- vn/expr/f )
+ \ ##box-float simplify-unbox ; inline
+
+: simplify-unbox-alien ( in -- vn/expr/f )
+ \ ##box-alien simplify-unbox ; inline
+
+M: unary-expr simplify*
+ #! Note the copy propagation: a copy always simplifies to
+ #! its source VN.
+ [ in>> vn>expr ] [ op>> ] bi {
+ { \ ##copy [ ] }
+ { \ ##copy-float [ ] }
+ { \ ##unbox-float [ simplify-unbox-float ] }
+ { \ ##unbox-alien [ simplify-unbox-alien ] }
+ { \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
+ [ 2drop f ]
+ } case ;
+
+: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
+
+: >binary-expr< ( expr -- in1 in2 )
+ [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
+
+: simplify-add ( expr -- vn/expr/f )
+ >binary-expr< {
+ { [ over expr-zero? ] [ nip ] }
+ { [ dup expr-zero? ] [ drop ] }
+ [ 2drop f ]
+ } cond ; inline
+
+: useless-shift? ( in1 in2 -- ? )
+ over op>> \ ##shl-imm eq?
+ [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
+
+: simplify-shift ( expr -- vn/expr/f )
+ >binary-expr<
+ 2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline
+
+M: binary-expr simplify*
+ dup op>> {
+ { \ ##add [ simplify-add ] }
+ { \ ##add-imm [ simplify-add ] }
+ { \ ##shr-imm [ simplify-shift ] }
+ { \ ##sar-imm [ simplify-shift ] }
+ [ 2drop f ]
+ } case ;
+
+M: expr simplify* drop f ;
+
+: simplify ( expr -- vn )
+ dup simplify* {
+ { [ dup not ] [ drop expr>vn ] }
+ { [ dup expr? ] [ expr>vn nip ] }
+ { [ dup integer? ] [ nip ] }
+ } cond ;
+
+GENERIC: number-values ( insn -- )
+
+M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ;
+M: insn number-values drop ;
--- /dev/null
+IN: compiler.cfg.value-numbering.tests
+USING: compiler.cfg.value-numbering compiler.cfg.instructions
+compiler.cfg.registers cpu.architecture tools.test kernel math ;
+[
+ {
+ T{ ##peek f V int-regs 45 D 1 }
+ T{ ##copy f V int-regs 48 V int-regs 45 }
+ T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 45 D 1 }
+ T{ ##copy f V int-regs 48 V int-regs 45 }
+ T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
+ } value-numbering
+] unit-test
+
+[
+ {
+ T{ ##load-immediate f V int-regs 2 8 }
+ T{ ##peek f V int-regs 3 D 0 }
+ T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
+ T{ ##replace f V int-regs 4 D 0 }
+ }
+] [
+ {
+ T{ ##load-immediate f V int-regs 2 8 }
+ T{ ##peek f V int-regs 3 D 0 }
+ T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
+ T{ ##replace f V int-regs 4 D 0 }
+ } value-numbering
+] unit-test
+
+[ t ] [
+ {
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##dispatch f V int-regs 1 V int-regs 2 }
+ } dup value-numbering =
+] unit-test
+
+[ t ] [
+ {
+ T{ ##peek f V int-regs 16 D 0 }
+ T{ ##peek f V int-regs 17 D -1 }
+ T{ ##sar-imm f V int-regs 18 V int-regs 17 3 }
+ T{ ##add-imm f V int-regs 19 V int-regs 16 13 }
+ T{ ##add f V int-regs 21 V int-regs 18 V int-regs 19 }
+ T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
+ T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
+ T{ ##replace f V int-regs 23 D 0 }
+ } dup value-numbering =
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##shl-imm f V int-regs 2 V int-regs 1 3 }
+ T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
+ T{ ##replace f V int-regs 1 D 0 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
+ T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
+ T{ ##replace f V int-regs 3 D 0 }
+ } value-numbering
+] unit-test
+
+[
+ {
+ T{ ##load-indirect f V int-regs 1 + }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
+ T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
+ T{ ##replace f V int-regs 4 D 0 }
+ }
+] [
+ {
+ T{ ##load-indirect f V int-regs 1 + }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
+ T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
+ T{ ##replace f V int-regs 6 D 0 }
+ } value-numbering
+] unit-test
+
+[
+ {
+ T{ ##load-indirect f V int-regs 1 + }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
+ T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
+ T{ ##replace f V int-regs 6 D 0 }
+ }
+] [
+ {
+ T{ ##load-indirect f V int-regs 1 + }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
+ T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
+ T{ ##replace f V int-regs 6 D 0 }
+ } value-numbering
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 8 D 0 }
+ T{ ##peek f V int-regs 9 D -1 }
+ T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
+ T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
+ T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
+ T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= }
+ T{ ##replace f V int-regs 14 D 0 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 8 D 0 }
+ T{ ##peek f V int-regs 9 D -1 }
+ T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
+ T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
+ T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
+ T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
+ T{ ##replace f V int-regs 14 D 0 }
+ } value-numbering
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 29 D -1 }
+ T{ ##peek f V int-regs 30 D -2 }
+ T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
+ T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 29 D -1 }
+ T{ ##peek f V int-regs 30 D -2 }
+ T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
+ T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
+ } value-numbering
+] unit-test
--- /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.cfg.value-numbering.graph
+compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.propagate
+compiler.cfg.value-numbering.simplify
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering
+
+: value-numbering ( insns -- insns' )
+ init-value-graph
+ init-expressions
+ [ [ number-values ] [ rewrite propagate ] bi ] map ;
--- /dev/null
+USING: compiler.cfg.write-barrier compiler.cfg.instructions
+compiler.cfg.registers cpu.architecture arrays tools.test ;
+IN: compiler.cfg.write-barrier.tests
+
+[
+ {
+ T{ ##peek f V int-regs 4 D 0 f }
+ T{ ##copy f V int-regs 6 V int-regs 4 f }
+ T{ ##allot f V int-regs 7 24 array V int-regs 8 f }
+ T{ ##load-immediate f V int-regs 9 8 f }
+ T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f }
+ T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f }
+ T{ ##replace f V int-regs 7 D 0 f }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 4 D 0 }
+ T{ ##copy f V int-regs 6 V int-regs 4 }
+ T{ ##allot f V int-regs 7 24 array V int-regs 8 }
+ T{ ##load-immediate f V int-regs 9 8 }
+ T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 }
+ T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 }
+ T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
+ T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
+ T{ ##replace f V int-regs 7 D 0 }
+ } eliminate-write-barriers
+] unit-test
+
+[
+ {
+ T{ ##load-immediate f V int-regs 4 24 }
+ T{ ##peek f V int-regs 5 D -1 }
+ T{ ##peek f V int-regs 6 D -2 }
+ T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
+ T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+ }
+] [
+ {
+ T{ ##load-immediate f V int-regs 4 24 }
+ T{ ##peek f V int-regs 5 D -1 }
+ T{ ##peek f V int-regs 6 D -2 }
+ T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
+ T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+ } eliminate-write-barriers
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 19 D -3 }
+ T{ ##peek f V int-regs 22 D -2 }
+ T{ ##copy f V int-regs 23 V int-regs 19 }
+ T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
+ T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
+ T{ ##copy f V int-regs 26 V int-regs 19 }
+ T{ ##peek f V int-regs 28 D -1 }
+ T{ ##copy f V int-regs 29 V int-regs 19 }
+ T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 19 D -3 }
+ T{ ##peek f V int-regs 22 D -2 }
+ T{ ##copy f V int-regs 23 V int-regs 19 }
+ T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
+ T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
+ T{ ##copy f V int-regs 26 V int-regs 19 }
+ T{ ##peek f V int-regs 28 D -1 }
+ T{ ##copy f V int-regs 29 V int-regs 19 }
+ T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
+ T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
+ } eliminate-write-barriers
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sets sequences locals
+compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ;
+IN: compiler.cfg.write-barrier
+
+! Eliminate redundant write barrier hits.
+
+! Objects which have already been marked, as well as
+! freshly-allocated objects
+SYMBOL: safe
+
+! Objects which have been mutated
+SYMBOL: mutated
+
+GENERIC: eliminate-write-barrier ( insn -- insn' )
+
+M: ##allot eliminate-write-barrier
+ dup dst>> safe get conjoin ;
+
+M: ##write-barrier eliminate-write-barrier
+ dup src>> resolve dup
+ [ safe get key? not ]
+ [ mutated get key? ] bi and
+ [ safe get conjoin ] [ 2drop f ] if ;
+
+M: ##copy eliminate-write-barrier
+ dup record-copy ;
+
+M: ##set-slot eliminate-write-barrier
+ dup obj>> resolve mutated get conjoin ;
+
+M: ##set-slot-imm eliminate-write-barrier
+ dup obj>> resolve mutated get conjoin ;
+
+M: insn eliminate-write-barrier ;
+
+: eliminate-write-barriers ( insns -- insns' )
+ H{ } clone safe set
+ H{ } clone mutated set
+ H{ } clone copies set
+ [ eliminate-write-barrier ] map sift ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces make math math.order math.parser sequences accessors
+kernel kernel.private layouts assocs words summary arrays
+combinators classes.algebra alien alien.c-types alien.structs
+alien.strings alien.arrays sets threads libc continuations.private
+fry cpu.architecture
+compiler.errors
+compiler.alien
+compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.builder
+compiler.codegen.fixup ;
+IN: compiler.codegen
+
+GENERIC: generate-insn ( insn -- )
+
+SYMBOL: registers
+
+: register ( vreg -- operand )
+ registers get at [ "Bad value" throw ] unless* ;
+
+: ?register ( obj -- operand )
+ dup vreg? [ register ] when ;
+
+: generate-insns ( insns -- code )
+ [
+ [
+ dup regs>> registers set
+ generate-insn
+ ] each
+ ] { } make fixup ;
+
+TUPLE: asm label code calls ;
+
+SYMBOL: calls
+
+: add-call ( word -- )
+ #! Compile this word later.
+ calls get push ;
+
+SYMBOL: compiling-word
+
+: compiled-stack-traces? ( -- ? ) 59 getenv ;
+
+! Mapping _label IDs to label instances
+SYMBOL: labels
+
+: init-generator ( word -- )
+ H{ } clone labels set
+ V{ } clone literal-table set
+ V{ } clone calls set
+ compiling-word set
+ compiled-stack-traces? compiling-word get f ? add-literal drop ;
+
+: generate ( mr -- asm )
+ [
+ [ label>> ]
+ [ word>> init-generator ]
+ [ instructions>> generate-insns ] tri
+ calls get
+ asm boa
+ ] with-scope ;
+
+: lookup-label ( id -- label )
+ labels get [ drop <label> ] cache ;
+
+M: ##load-immediate generate-insn
+ [ dst>> register ] [ val>> ] bi %load-immediate ;
+
+M: ##load-indirect generate-insn
+ [ dst>> register ] [ obj>> ] bi %load-indirect ;
+
+M: ##peek generate-insn
+ [ dst>> register ] [ loc>> ] bi %peek ;
+
+M: ##replace generate-insn
+ [ src>> register ] [ loc>> ] bi %replace ;
+
+M: ##inc-d generate-insn n>> %inc-d ;
+
+M: ##inc-r generate-insn n>> %inc-r ;
+
+M: ##call generate-insn
+ word>> dup sub-primitive>>
+ [ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
+
+M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
+
+M: ##return generate-insn drop %return ;
+
+M: ##dispatch-label generate-insn label>> %dispatch-label ;
+
+M: ##dispatch generate-insn
+ [ src>> register ] [ temp>> register ] bi %dispatch ;
+
+: >slot<
+ {
+ [ dst>> register ]
+ [ obj>> register ]
+ [ slot>> ?register ]
+ [ tag>> ]
+ } cleave ; inline
+
+M: ##slot generate-insn
+ [ >slot< ] [ temp>> register ] bi %slot ;
+
+M: ##slot-imm generate-insn
+ >slot< %slot-imm ;
+
+: >set-slot<
+ {
+ [ src>> register ]
+ [ obj>> register ]
+ [ slot>> ?register ]
+ [ tag>> ]
+ } cleave ; inline
+
+M: ##set-slot generate-insn
+ [ >set-slot< ] [ temp>> register ] bi %set-slot ;
+
+M: ##set-slot-imm generate-insn
+ >set-slot< %set-slot-imm ;
+
+M: ##string-nth generate-insn
+ {
+ [ dst>> register ]
+ [ obj>> register ]
+ [ index>> register ]
+ [ temp>> register ]
+ } cleave %string-nth ;
+
+: dst/src ( insn -- dst src )
+ [ dst>> register ] [ src>> register ] bi ; inline
+
+: dst/src1/src2 ( insn -- dst src1 src2 )
+ [ dst>> register ]
+ [ src1>> register ]
+ [ src2>> ?register ] tri ; inline
+
+M: ##add generate-insn dst/src1/src2 %add ;
+M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
+M: ##sub generate-insn dst/src1/src2 %sub ;
+M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
+M: ##mul generate-insn dst/src1/src2 %mul ;
+M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
+M: ##and generate-insn dst/src1/src2 %and ;
+M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
+M: ##or generate-insn dst/src1/src2 %or ;
+M: ##or-imm generate-insn dst/src1/src2 %or-imm ;
+M: ##xor generate-insn dst/src1/src2 %xor ;
+M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
+M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
+M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
+M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
+M: ##not generate-insn dst/src %not ;
+
+: dst/src/temp ( insn -- dst src temp )
+ [ dst/src ] [ temp>> register ] bi ; inline
+
+M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
+M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
+
+M: ##add-float generate-insn dst/src1/src2 %add-float ;
+M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
+M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
+M: ##div-float generate-insn dst/src1/src2 %div-float ;
+
+M: ##integer>float generate-insn dst/src %integer>float ;
+M: ##float>integer generate-insn dst/src %float>integer ;
+
+M: ##copy generate-insn dst/src %copy ;
+M: ##copy-float generate-insn dst/src %copy-float ;
+M: ##unbox-float generate-insn dst/src %unbox-float ;
+M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
+M: ##box-float generate-insn dst/src/temp %box-float ;
+M: ##box-alien generate-insn dst/src/temp %box-alien ;
+
+M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
+M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
+M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
+M: ##alien-signed-1 generate-insn dst/src %alien-signed-1 ;
+M: ##alien-signed-2 generate-insn dst/src %alien-signed-2 ;
+M: ##alien-signed-4 generate-insn dst/src %alien-signed-4 ;
+M: ##alien-cell generate-insn dst/src %alien-cell ;
+M: ##alien-float generate-insn dst/src %alien-float ;
+M: ##alien-double generate-insn dst/src %alien-double ;
+
+: >alien-setter< [ src>> register ] [ value>> register ] bi ; inline
+
+M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
+M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
+M: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
+M: ##set-alien-cell generate-insn >alien-setter< %set-alien-cell ;
+M: ##set-alien-float generate-insn >alien-setter< %set-alien-float ;
+M: ##set-alien-double generate-insn >alien-setter< %set-alien-double ;
+
+M: ##allot generate-insn
+ {
+ [ dst>> register ]
+ [ size>> ]
+ [ class>> ]
+ [ temp>> register ]
+ } cleave
+ %allot ;
+
+M: ##write-barrier generate-insn
+ [ src>> register ]
+ [ card#>> register ]
+ [ table>> register ]
+ tri %write-barrier ;
+
+M: _gc generate-insn drop %gc ;
+
+M: ##loop-entry generate-insn drop %loop-entry ;
+
+! ##alien-invoke
+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 ;
+
+M: stack-params reg-size drop "void*" heap-size ;
+
+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 -- )
+
+: ?dummy-stack-params ( reg-class -- )
+ dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
+
+: ?dummy-int-params ( reg-class -- )
+ dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
+
+: ?dummy-fp-params ( reg-class -- )
+ drop dummy-fp-params? [ float-regs inc ] when ;
+
+M: int-regs inc-reg-class
+ [ reg-class-variable inc ]
+ [ ?dummy-stack-params ]
+ [ ?dummy-fp-params ]
+ tri ;
+
+M: float-regs inc-reg-class
+ [ reg-class-variable inc ]
+ [ ?dummy-stack-params ]
+ [ ?dummy-int-params ]
+ tri ;
+
+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 -- seq )
+ cell /i "void*" c-type <repetition> ;
+
+GENERIC: flatten-value-type ( type -- types )
+
+M: object flatten-value-type 1array ;
+
+M: struct-type flatten-value-type ( type -- types )
+ stack-size cell align (flatten-int-type) ;
+
+M: long-long-type flatten-value-type ( type -- types )
+ 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> '[ alloc-parameter _ execute ] 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>> large-struct?
+ [ %prepare-box-struct cell ] [ 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 ] 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-insn
+ params>>
+ ! Save registers for GC
+ %prepare-alien-invoke
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Call function
+ dup alien-invoke-dlsym %alien-invoke
+ ! Box return value
+ dup %cleanup
+ box-return* ;
+
+! ##alien-indirect
+M: ##alien-indirect generate-insn
+ params>>
+ ! Save registers for GC
+ %prepare-alien-invoke
+ ! Save alien at top of stack to temporary storage
+ %prepare-alien-indirect
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Call alien in temporary storage
+ %alien-indirect
+ ! Box return value
+ dup %cleanup
+ box-return* ;
+
+! ##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 ] ] }
+ [ 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 ;
+
+M: ##callback-return generate-insn
+ #! All the extra book-keeping for %unwind is only for x86.
+ #! On other platforms its an alias for %return.
+ params>> %callback-return ;
+
+M: ##alien-callback generate-insn
+ params>>
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
+ tri ;
+
+M: _prologue generate-insn
+ stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
+
+M: _epilogue generate-insn
+ stack-frame>> total-size>> %epilogue ;
+
+M: _label generate-insn
+ id>> lookup-label , ;
+
+M: _branch generate-insn
+ label>> lookup-label %jump-label ;
+
+: >compare< ( insn -- label cc src1 src2 )
+ {
+ [ dst>> register ]
+ [ cc>> ]
+ [ src1>> register ]
+ [ src2>> ?register ]
+ } cleave ; inline
+
+M: ##compare generate-insn >compare< %compare ;
+M: ##compare-imm generate-insn >compare< %compare-imm ;
+M: ##compare-float generate-insn >compare< %compare-float ;
+
+: >binary-branch< ( insn -- label cc src1 src2 )
+ {
+ [ label>> lookup-label ]
+ [ cc>> ]
+ [ src1>> register ]
+ [ src2>> ?register ]
+ } cleave ; inline
+
+M: _compare-branch generate-insn
+ >binary-branch< %compare-branch ;
+
+M: _compare-imm-branch generate-insn
+ >binary-branch< %compare-imm-branch ;
+
+M: _compare-float-branch generate-insn
+ >binary-branch< %compare-float-branch ;
+
+M: _spill generate-insn
+ [ src>> ] [ n>> ] [ class>> ] tri {
+ { int-regs [ %spill-integer ] }
+ { double-float-regs [ %spill-float ] }
+ } case ;
+
+M: _reload generate-insn
+ [ dst>> ] [ n>> ] [ class>> ] tri {
+ { int-regs [ %reload-integer ] }
+ { double-float-regs [ %reload-float ] }
+ } case ;
+
+M: _spill-counts generate-insn drop ;
--- /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 math.order accessors
+growable cpu.architecture compiler.constants ;
+IN: compiler.codegen.fixup
+
+GENERIC: fixup* ( obj -- )
+
+: code-format 22 getenv ;
+
+: compiled-offset ( -- n ) building get length code-format * ;
+
+SYMBOL: relocation-table
+SYMBOL: label-table
+
+M: label fixup* compiled-offset >>offset drop ;
+
+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
+ [ label>> ] [ class>> ] bi 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: integer fixup* , ;
+
+: indq ( elt seq -- n ) [ eq? ] with find drop ;
+
+: adjoin* ( obj table -- n )
+ 2dup indq [ 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 ( fixup-directives -- code )
+ [
+ init-fixup
+ [ fixup* ] each
+ literal-table get >array
+ relocation-table get >byte-array
+ label-table get resolve-labels
+ ] { } make 4array ;
--- /dev/null
+Support for generation of relocatable code
-USING: compiler.generator help.markup help.syntax words io parser
+USING: help.markup help.syntax words io parser
assocs words.private sequences compiler.units ;
IN: compiler
"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
{ $subsection "compiler-usage" }
{ $subsection "compiler-errors" }
-{ $subsection "hints" }
-{ $subsection "generator" } ;
+{ $subsection "hints" } ;
ABOUT: "compiler"
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces arrays sequences io debugger words fry
-compiler.units continuations vocabs assocs dlists definitions
-math threads graphs generic combinators deques search-deques
-stack-checker stack-checker.state compiler.generator
-compiler.errors compiler.tree.builder compiler.tree.optimizer ;
+USING: accessors kernel namespaces arrays sequences io debugger
+words fry continuations vocabs assocs dlists definitions math
+threads graphs generic combinators deques search-deques
+prettyprint io stack-checker stack-checker.state
+stack-checker.inlining compiler.errors compiler.units
+compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.optimizer
+compiler.cfg.linearization compiler.cfg.two-operand
+compiler.cfg.linear-scan compiler.cfg.stack-frame
+compiler.codegen ;
IN: compiler
+SYMBOL: compile-queue
+SYMBOL: compiled
+
+: queue-compile ( word -- )
+ {
+ { [ dup "forgotten" word-prop ] [ ] }
+ { [ dup compiled get key? ] [ ] }
+ { [ dup inlined-block? ] [ ] }
+ { [ dup primitive? ] [ ] }
+ [ dup compile-queue get push-front ]
+ } cond drop ;
+
+: maybe-compile ( word -- )
+ dup compiled>> [ drop ] [ queue-compile ] if ;
+
SYMBOL: +failed+
: ripple-up ( words -- )
[ "compiled-effect" set-word-prop ]
2bi ;
-: compile-begins ( word -- )
+: start ( word -- )
+ "trace-compilation" get [ dup . flush ] when
+ H{ } clone dependencies set
+ H{ } clone generic-dependencies set
f swap compiler-error ;
-: compile-failed ( word error -- )
+: fail ( word error -- )
[ swap compiler-error ]
[
drop
[ f swap compiled get set-at ]
[ +failed+ save-effect ]
tri
- ] 2bi ;
+ ] 2bi
+ return ;
+
+: frontend ( word -- effect nodes )
+ [ build-tree-from-word ] [ fail ] recover optimize-tree ;
+
+! Only switch this off for debugging.
+SYMBOL: compile-dependencies?
-: compile-succeeded ( effect word -- )
+t compile-dependencies? set-global
+
+: save-asm ( asm -- )
+ [ [ code>> ] [ label>> ] bi compiled get set-at ]
+ [ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
+ bi ;
+
+: backend ( nodes word -- )
+ build-cfg [
+ optimize-cfg
+ build-mr
+ convert-two-operand
+ linear-scan
+ build-stack-frame
+ generate
+ save-asm
+ ] each ;
+
+: finish ( effect word -- )
[ swap save-effect ]
[ compiled-unxref ]
[
: (compile) ( word -- )
'[
- H{ } clone dependencies set
- H{ } clone generic-dependencies set
-
_ {
- [ compile-begins ]
- [
- [ build-tree-from-word ] [ compile-failed return ] recover
- optimize-tree
- ]
- [ dup generate ]
- [ compile-succeeded ]
+ [ start ]
+ [ frontend ]
+ [ backend ]
+ [ finish ]
} cleave
] with-return ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel layouts system ;
+USING: math kernel layouts system strings ;
IN: compiler.constants
! These constants must match vm/memory.h
-: card-bits 8 ;
-: deck-bits 18 ;
-: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
+: card-bits 8 ; inline
+: deck-bits 18 ; inline
+: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
! These constants must match vm/layouts.h
-: header-offset ( -- n ) object tag-number neg ;
-: float-offset ( -- n ) 8 float tag-number - ;
-: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
-: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
-: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
-: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
-: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
-: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
-: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
-: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
-: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
-: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
-: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
-: compiled-header-size ( -- n ) 4 bootstrap-cells ;
+: header-offset ( -- n ) object tag-number neg ; inline
+: float-offset ( -- n ) 8 float tag-number - ; inline
+: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
+: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
+: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
+: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
+: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
+: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
+: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
+: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
+: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! 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-cell 0 ; inline
+: rc-absolute 1 ; inline
+: rc-relative 2 ; inline
+: rc-absolute-ppc-2/2 3 ; inline
+: rc-relative-ppc-2 4 ; inline
+: rc-relative-ppc-3 5 ; inline
+: rc-relative-arm-3 6 ; inline
+: rc-indirect-arm 7 ; inline
+: rc-indirect-arm-pc 8 ; inline
! 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 ;
+: rt-primitive 0 ; inline
+: rt-dlsym 1 ; inline
+: rt-literal 2 ; inline
+: rt-dispatch 3 ; inline
+: rt-xt 4 ; inline
+: rt-here 5 ; inline
+: rt-label 6 ; inline
+: rt-immediate 7 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.syntax help.markup math kernel
-words strings alien compiler.generator ;
-IN: compiler.generator.fixup
-
-HELP: frame-required
-{ $values { "n" "a non-negative integer" } }
-{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
-
-HELP: add-literal
-{ $values { "obj" object } { "n" integer } }
-{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
-
-HELP: rel-dlsym
-{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
-{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
-} ;
-
-HELP: literal-table
-{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
+++ /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.generator.fixup
-
-: no-stack-frame -1 ; inline
-
-TUPLE: frame-required n ;
-
-: frame-required ( n -- ) \ frame-required boa , ;
-
-: compute-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-size 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 compute-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
-USING: help.markup help.syntax words debugger
-compiler.generator.fixup compiler.generator.registers quotations
-kernel vectors arrays effects sequences ;
-IN: compiler.generator
-
-ARTICLE: "generator" "Compiled code generator"
-"Most of the words in the " { $vocab-link "compiler.generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
-$nl
-"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
-{ $subsection compiled-stack-traces? }
-"Assembler intrinsics can be defined for low-level optimization:"
-{ $subsection define-intrinsic }
-{ $subsection define-intrinsics }
-{ $subsection define-if-intrinsic }
-{ $subsection define-if-intrinsics }
-"The main entry point into the code generator:"
-{ $subsection generate } ;
-
-ABOUT: "generator"
-
-HELP: compiled
-{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
-
-HELP: compiling-word
-{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
-
-HELP: compiling-label
-{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
-
-HELP: compiled-stack-traces?
-{ $values { "?" "a boolean" } }
-{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
-
-HELP: begin-compiling
-{ $values { "word" word } { "label" word } }
-{ $description "Prepares to generate machine code for a word." } ;
-
-HELP: with-generator
-{ $values { "nodes" "a sequence of nodes" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
-{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the sequence of nodes." } ;
-
-HELP: generate-node
-{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
-{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
-
-HELP: generate-nodes
-{ $values { "nodes" "a sequence of nodes" } }
-{ $description "Recursively generate machine code for a dataflow graph." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
-
-HELP: generate
-{ $values { "word" word } { "label" word } { "nodes" "a sequence of nodes" } }
-{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "nodes" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
-
-HELP: define-intrinsics
-{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
-{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
-$nl
-"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
-
-HELP: define-intrinsic
-{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
-{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
-$nl
-"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
-
-HELP: if>boolean-intrinsic
-{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
-{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
-
-HELP: define-if-intrinsics
-{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
-{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
-$nl
-"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
-$nl
-"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
-{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
-
-HELP: define-if-intrinsic
-{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
-{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
-$nl
-"See " { $link define-if-intrinsics } " for a description of the parameters." } ;
+++ /dev/null
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes combinators
-cpu.architecture effects generic hashtables io kernel
-kernel.private layouts math math.parser namespaces make
-prettyprint quotations sequences system threads words vectors
-sets deques continuations.private summary alien alien.c-types
-alien.structs alien.strings alien.arrays libc compiler.errors
-stack-checker.inlining compiler.tree compiler.tree.builder
-compiler.tree.combinators compiler.tree.propagation.info
-compiler.generator.fixup compiler.generator.registers
-compiler.generator.iterator ;
-IN: compiler.generator
-
-SYMBOL: compile-queue
-SYMBOL: compiled
-
-: queue-compile ( word -- )
- {
- { [ dup "forgotten" word-prop ] [ ] }
- { [ dup compiled get key? ] [ ] }
- { [ dup inlined-block? ] [ ] }
- { [ dup primitive? ] [ ] }
- [ dup compile-queue get push-front ]
- } cond drop ;
-
-: maybe-compile ( word -- )
- dup compiled>> [ drop ] [ queue-compile ] if ;
-
-SYMBOL: compiling-word
-
-SYMBOL: compiling-label
-
-SYMBOL: compiling-loops
-
-! Label of current word, after prologue, makes recursion faster
-SYMBOL: current-label-start
-
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
-
-: begin-compiling ( word label -- )
- H{ } clone compiling-loops set
- compiling-label set
- compiling-word set
- compiled-stack-traces?
- compiling-word get f ?
- 1vector literal-table set
- f compiling-label get compiled get set-at ;
-
-: save-machine-code ( literals relocation labels code -- )
- 4array compiling-label get compiled get set-at ;
-
-: with-generator ( nodes word label quot -- )
- [
- >r begin-compiling r>
- { } make fixup
- save-machine-code
- ] with-scope ; inline
-
-GENERIC: generate-node ( node -- next )
-
-: generate-nodes ( nodes -- )
- [ current-node generate-node ] iterate-nodes
- end-basic-block ;
-
-: init-generate-nodes ( -- )
- init-templates
- %save-word-xt
- %prologue-later
- current-label-start define-label
- current-label-start resolve-label ;
-
-: generate ( nodes word label -- )
- [
- init-generate-nodes
- [ generate-nodes ] with-node-iterator
- ] with-generator ;
-
-: intrinsics ( #call -- quot )
- word>> "intrinsics" word-prop ;
-
-: if-intrinsics ( #call -- quot )
- word>> "if-intrinsics" word-prop ;
-
-! node
-M: node generate-node drop iterate-next ;
-
-: %jump ( word -- )
- dup compiling-label get eq?
- [ drop current-label-start get ] [ %epilogue-later ] if
- %jump-label ;
-
-: generate-call ( label -- next )
- dup maybe-compile
- end-basic-block
- dup compiling-loops get at [
- %jump-label f
- ] [
- tail-call? [
- %jump f
- ] [
- 0 frame-required
- %call
- iterate-next
- ] if
- ] ?if ;
-
-! #recursive
-: compile-recursive ( node -- next )
- dup label>> id>> generate-call >r
- [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
- r> ;
-
-: compiling-loop ( word -- )
- <label> dup resolve-label swap compiling-loops get set-at ;
-
-: compile-loop ( node -- next )
- end-basic-block
- [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
- iterate-next ;
-
-M: #recursive generate-node
- dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
-
-! #if
-: end-false-branch ( label -- )
- tail-call? [ %return drop ] [ %jump-label ] if ;
-
-: generate-branch ( nodes -- )
- [ copy-templates generate-nodes ] with-scope ;
-
-: generate-if ( node label -- next )
- <label> [
- >r >r children>> first2 swap generate-branch
- r> r> end-false-branch resolve-label
- generate-branch
- init-templates
- ] keep resolve-label iterate-next ;
-
-M: #if generate-node
- [ <label> dup %jump-f ]
- H{ { +input+ { { f "flag" } } } }
- with-template
- generate-if ;
-
-! #dispatch
-: dispatch-branch ( nodes word -- label )
- gensym [
- [
- copy-templates
- %save-dispatch-xt
- %prologue-later
- [ generate-nodes ] with-node-iterator
- %return
- ] with-generator
- ] keep ;
-
-: dispatch-branches ( node -- )
- children>> [
- compiling-word get dispatch-branch
- %dispatch-label
- ] each ;
-
-: generate-dispatch ( node -- )
- %dispatch dispatch-branches init-templates ;
-
-M: #dispatch generate-node
- #! The order here is important, dispatch-branches must
- #! run after %dispatch, so that each branch gets the
- #! correct register state
- tail-call? [
- generate-dispatch iterate-next
- ] [
- compiling-word get gensym [
- [
- init-generate-nodes
- generate-dispatch
- ] with-generator
- ] keep generate-call
- ] if ;
-
-! #call
-: define-intrinsics ( word intrinsics -- )
- "intrinsics" set-word-prop ;
-
-: define-intrinsic ( word quot assoc -- )
- 2array 1array define-intrinsics ;
-
-: define-if>branch-intrinsics ( word intrinsics -- )
- "if-intrinsics" set-word-prop ;
-
-: if>boolean-intrinsic ( quot -- )
- "false" define-label
- "end" define-label
- "false" get swap call
- t "if-scratch" get load-literal
- "end" get %jump-label
- "false" resolve-label
- f "if-scratch" get load-literal
- "end" resolve-label
- "if-scratch" get phantom-push ; inline
-
-: define-if>boolean-intrinsics ( word intrinsics -- )
- [
- >r [ if>boolean-intrinsic ] curry r>
- { { f "if-scratch" } } +scratch+ associate assoc-union
- ] assoc-map "intrinsics" set-word-prop ;
-
-: define-if-intrinsics ( word intrinsics -- )
- [ +input+ associate ] assoc-map
- 2dup define-if>branch-intrinsics
- define-if>boolean-intrinsics ;
-
-: define-if-intrinsic ( word quot inputs -- )
- 2array 1array define-if-intrinsics ;
-
-: do-if-intrinsic ( pair -- next )
- <label> [ swap do-template skip-next ] keep generate-if ;
-
-: find-intrinsic ( #call -- pair/f )
- intrinsics find-template ;
-
-: find-if-intrinsic ( #call -- pair/f )
- node@ {
- { [ dup length 2 < ] [ 2drop f ] }
- { [ dup second #if? ] [ drop if-intrinsics find-template ] }
- [ 2drop f ]
- } cond ;
-
-M: #call generate-node
- dup node-input-infos [ class>> ] map set-operand-classes
- dup find-if-intrinsic [
- do-if-intrinsic
- ] [
- dup find-intrinsic [
- do-template iterate-next
- ] [
- word>> generate-call
- ] ?if
- ] ?if ;
-
-! #call-recursive
-M: #call-recursive generate-node label>> id>> generate-call ;
-
-! #push
-M: #push generate-node
- literal>> <constant> phantom-push iterate-next ;
-
-! #shuffle
-M: #shuffle generate-node
- shuffle-effect phantom-shuffle iterate-next ;
-
-M: #>r generate-node
- [ in-d>> length ] [ out-r>> empty? ] bi
- [ phantom-drop ] [ phantom->r ] if
- iterate-next ;
-
-M: #r> generate-node
- [ in-r>> length ] [ out-d>> empty? ] bi
- [ phantom-rdrop ] [ phantom-r> ] if
- iterate-next ;
-
-! #return
-M: #return generate-node
- drop end-basic-block %return f ;
-
-M: #return-recursive generate-node
- end-basic-block
- label>> id>> compiling-loops get key?
- [ %return ] unless f ;
-
-! #alien-invoke
-: large-struct? ( ctype -- ? )
- dup c-struct? [ 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 2 cells ] if ;
-
-: alien-stack-frame ( params -- n )
- stack-frame new
- swap
- [ return>> return-size >>return ]
- [ alien-parameters parameter-sizes drop >>params ] bi
- dup [ params>> ] [ return>> ] bi + >>size
- dup size>> stack-frame-size >>total-size ;
-
-: with-stack-frame ( params quot -- )
- swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
- call
- stack-frame off ; 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 ;
-
-M: stack-params reg-size drop "void*" heap-size ;
-
-GENERIC: reg-class-variable ( register-class -- symbol )
-
-M: reg-class reg-class-variable ;
-
-M: float-regs reg-class-variable drop float-regs ;
-
-M: stack-params reg-class-variable drop stack-params ;
-
-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 ;
-
-: reg-class-full? ( class -- ? )
- [ 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 -- types )
- cell /i "void*" c-type <repetition> ;
-
-GENERIC: flatten-value-type ( type -- types )
-
-M: object flatten-value-type 1array ;
-
-M: struct-type flatten-value-type ( type -- types )
- stack-size cell align (flatten-int-type) ;
-
-M: long-long-type flatten-value-type ( type -- types )
- 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>> large-struct?
- [ %prepare-box-struct cell ] [ 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 [
- 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 [
- ! 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" = ] [ drop stack-frame get params>> ] }
- { [ 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-later
- dup [
- [ registers>objects ]
- [ wrap-callback-quot %alien-callback ]
- [ %callback-return ]
- tri
- ] with-stack-frame
- ] with-generator ;
-
-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: namespaces sequences kernel compiler.tree ;
-IN: compiler.generator.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? ] [ #terminate? ] bi 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
-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 namespaces make
-quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order cpu.architecture
-compiler.generator.fixup ;
-IN: compiler.generator.registers
-
-SYMBOL: +input+
-SYMBOL: +output+
-SYMBOL: +scratch+
-SYMBOL: +clobber+
-SYMBOL: known-tag
-
-<PRIVATE
-
-! Value protocol
-GENERIC: set-operand-class ( class obj -- )
-GENERIC: operand-class* ( operand -- class )
-GENERIC: move-spec ( obj -- spec )
-GENERIC: live-vregs* ( obj -- )
-GENERIC: live-loc? ( actual current -- ? )
-GENERIC# (lazy-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
-
-MIXIN: value
-
-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-vregs* drop ;
-M: value live-loc? 2drop f ;
-M: value minimal-ds-loc* drop ;
-M: value lazy-store 2drop ;
-
-! A scratch register for computations
-TUPLE: vreg n reg-class ;
-
-C: <vreg> vreg ( n reg-class -- vreg )
-
-M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
-M: vreg live-vregs* , ;
-
-M: vreg move-spec
- reg-class>> {
- { [ dup int-regs? ] [ f ] }
- { [ dup float-regs? ] [ float ] }
- } cond nip ;
-
-M: vreg operand-class*
- reg-class>> {
- { [ dup int-regs? ] [ f ] }
- { [ dup float-regs? ] [ float ] }
- } cond nip ;
-
-INSTANCE: vreg value
-
-! Temporary register for stack shuffling
-SINGLETON: temp-reg
-
-M: temp-reg move-spec drop f ;
-
-INSTANCE: temp-reg value
-
-! A data stack location.
-TUPLE: ds-loc n class ;
-
-: <ds-loc> ( n -- loc ) f ds-loc boa ;
-
-M: ds-loc minimal-ds-loc* n>> min ;
-M: ds-loc live-loc?
- over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-! A retain stack location.
-TUPLE: rs-loc n class ;
-
-: <rs-loc> ( n -- loc ) f rs-loc boa ;
-M: rs-loc live-loc?
- over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-UNION: loc ds-loc rs-loc ;
-
-M: loc operand-class* class>> ;
-M: loc set-operand-class (>>class) ;
-M: loc move-spec drop loc ;
-
-INSTANCE: loc value
-
-M: f move-spec drop loc ;
-M: f operand-class* ;
-
-! 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 set-operand-class vreg>> set-operand-class ;
-M: cached operand-class* vreg>> operand-class* ;
-M: cached move-spec drop cached ;
-M: cached live-vregs* vreg>> live-vregs* ;
-M: cached live-loc? loc>> live-loc? ;
-M: cached (lazy-load) >r vreg>> r> (lazy-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* ;
-
-INSTANCE: cached value
-
-! A tagged pointer
-TUPLE: tagged vreg class ;
-
-: <tagged> ( vreg -- tagged )
- f tagged boa ;
-
-M: tagged v>operand vreg>> v>operand ;
-M: tagged set-operand-class (>>class) ;
-M: tagged operand-class* class>> ;
-M: tagged move-spec drop f ;
-M: tagged live-vregs* vreg>> , ;
-
-INSTANCE: tagged value
-
-! Unboxed alien pointers
-TUPLE: unboxed-alien vreg ;
-C: <unboxed-alien> unboxed-alien
-M: unboxed-alien v>operand vreg>> v>operand ;
-M: unboxed-alien operand-class* drop simple-alien ;
-M: unboxed-alien move-spec class ;
-M: unboxed-alien live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-alien value
-
-TUPLE: unboxed-byte-array vreg ;
-C: <unboxed-byte-array> unboxed-byte-array
-M: unboxed-byte-array v>operand vreg>> v>operand ;
-M: unboxed-byte-array operand-class* drop c-ptr ;
-M: unboxed-byte-array move-spec class ;
-M: unboxed-byte-array live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-byte-array value
-
-TUPLE: unboxed-f vreg ;
-C: <unboxed-f> unboxed-f
-M: unboxed-f v>operand vreg>> v>operand ;
-M: unboxed-f operand-class* drop \ f ;
-M: unboxed-f move-spec class ;
-M: unboxed-f live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-f value
-
-TUPLE: unboxed-c-ptr vreg ;
-C: <unboxed-c-ptr> unboxed-c-ptr
-M: unboxed-c-ptr v>operand vreg>> v>operand ;
-M: unboxed-c-ptr operand-class* drop c-ptr ;
-M: unboxed-c-ptr move-spec class ;
-M: unboxed-c-ptr live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-c-ptr value
-
-! A constant value
-TUPLE: constant value ;
-C: <constant> constant
-M: constant operand-class* value>> class ;
-M: constant move-spec class ;
-
-INSTANCE: constant value
-
-<PRIVATE
-
-! 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.
- temp-reg over %move
- operand-class temp-reg
- tagged new
- swap >>vreg
- swap >>class
- %move ;
-
-: %move ( dst src -- )
- 2dup [ move-spec ] bi@ 2array {
- { { f f } [ %move-bug ] }
- { { 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.
- [
- over zero? [ 2drop ] [ execute ] if 0
- ] curry 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> ] curry 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) ] curry each ; inline
-
-: adjust-phantom ( n phantom -- )
- swap [ + ] curry change-height drop ;
-
-: cut-phantom ( n phantom -- seq )
- swap [ cut* swap ] curry 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-vregs ( -- seq )
- [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
-
-: (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
-
-! Computing free registers and initializing allocator
-: reg-spec>class ( spec -- class )
- float eq? double-float-regs int-regs ? ;
-
-: free-vregs ( reg-class -- seq )
- #! Free vregs in a given register class
- \ free-vregs get at ;
-
-: alloc-vreg ( spec -- reg )
- [ reg-spec>class free-vregs pop ] 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 ;
-
-: allocation ( value spec -- reg-class )
- {
- { [ dup quotation? ] [ 2drop f ] }
- { [ 2dup compatible? ] [ 2drop f ] }
- [ nip reg-spec>class ]
- } cond ;
-
-: alloc-vreg-for ( value spec -- vreg )
- alloc-vreg swap operand-class
- over tagged? [ >>class ] [ drop ] if ;
-
-M: value (lazy-load)
- 2dup allocation [
- dupd alloc-vreg-for dup rot %move
- ] [
- drop
- ] if ;
-
-: (compute-free-vregs) ( used class -- vector )
- #! Find all vregs in 'class' which are not in 'used'.
- [ vregs length reverse ] keep
- [ <vreg> ] curry map swap diff
- >vector ;
-
-: compute-free-vregs ( -- )
- #! Create a new hashtable for thee free-vregs variable.
- live-vregs
- { int-regs double-float-regs }
- [ 2dup (compute-free-vregs) ] H{ } map>assoc
- \ free-vregs set
- drop ;
-
-M: loc lazy-store
- 2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
-
-: do-shuffle ( hash -- )
- dup assoc-empty? [
- drop
- ] [
- "live-locs" set
- [ lazy-store ] each-loc
- ] if ;
-
-: fast-shuffle ( locs -- )
- #! We have enough free registers to load all shuffle inputs
- #! at once
- [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
-
-: minimal-ds-loc ( phantom -- n )
- #! When shuffling more values than can fit in registers, we
- #! need to find an area on the data stack which isn't in
- #! use.
- [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
-
-: find-tmp-loc ( -- n )
- #! Find an area of the data stack which is not referenced
- #! from the phantom stacks. We can clobber there all we want
- [ minimal-ds-loc ] each-phantom min 1- ;
-
-: slow-shuffle-mapping ( locs tmp -- pairs )
- >r dup length r>
- [ swap - <ds-loc> ] curry map zip ;
-
-: slow-shuffle ( locs -- )
- #! We don't have enough free registers to load all shuffle
- #! inputs, so we use a single temporary register, together
- #! with the area of the data stack above the stack pointer
- find-tmp-loc slow-shuffle-mapping [
- [
- swap dup cached? [ vreg>> ] when %move
- ] assoc-each
- ] keep >hashtable do-shuffle ;
-
-: fast-shuffle? ( live-locs -- ? )
- #! Test if we have enough free registers to load all
- #! shuffle inputs at once.
- int-regs free-vregs [ length ] bi@ <= ;
-
-: finalize-locs ( -- )
- #! Perform any deferred stack shuffling.
- [
- \ free-vregs [ [ clone ] assoc-map ] change
- live-locs dup fast-shuffle?
- [ fast-shuffle ] [ slow-shuffle ] if
- ] with-scope ;
-
-: 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
-: free-vregs? ( int# float# -- ? )
- double-float-regs free-vregs length <=
- >r int-regs free-vregs length <= r> and ;
-
-: phantom&spec ( phantom spec -- phantom' spec' )
- >r stack>> r>
- [ length f pad-left ] keep
- [ <reversed> ] bi@ ; inline
-
-: phantom&spec-agree? ( phantom spec quot -- ? )
- >r phantom&spec r> 2all? ; inline
-
-: 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
- [ >r stack>> r> substitute-here ] curry each-phantom ;
-
-: set-operand ( value var -- )
- >r dup constant? [ value>> ] when r> set ;
-
-: lazy-load ( values template -- )
- #! Set operand vars here.
- 2dup [ first (lazy-load) ] 2map
- dup rot [ second set-operand ] 2each
- substitute-vregs ;
-
-: load-inputs ( -- )
- +input+ get
- [ length phantom-datastack get phantom-input ] keep
- lazy-load ;
-
-: output-vregs ( -- seq seq )
- +output+ +clobber+ [ get [ get ] map ] bi@ ;
-
-: clash? ( seq -- ? )
- phantoms [ stack>> ] bi@ append [
- dup cached? [ vreg>> ] when swap member?
- ] with contains? ;
-
-: outputs-clash? ( -- ? )
- output-vregs append clash? ;
-
-: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
-
-: count-input-vregs ( phantom spec -- )
- phantom&spec [
- >r dup cached? [ vreg>> ] when r> first allocation
- ] 2map count-vregs ;
-
-: count-scratch-regs ( spec -- )
- [ first reg-spec>class ] map count-vregs ;
-
-: guess-vregs ( dinput rinput scratch -- int# float# )
- [
- 0 int-regs set
- 0 double-float-regs set
- count-scratch-regs
- phantom-retainstack get swap count-input-vregs
- phantom-datastack get swap count-input-vregs
- int-regs get double-float-regs get
- ] with-scope ;
-
-: alloc-scratch ( -- )
- +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
-
-: guess-template-vregs ( -- int# float# )
- +input+ get { } +scratch+ get guess-vregs ;
-
-: template-inputs ( -- )
- ! Load input values into registers
- load-inputs
- ! Allocate scratch registers
- alloc-scratch
- ! If outputs clash, we write values back to the stack
- outputs-clash? [ finalize-contents ] when ;
-
-: template-outputs ( -- )
- +output+ get [ get ] map phantom-datastack get phantom-append ;
-
-: 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> call ] [ 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? ( spec -- ? )
- phantom-datastack get +input+ rot at
- [ spec-matches? ] phantom&spec-agree? ;
-
-: ensure-template-vregs ( -- )
- guess-template-vregs free-vregs? [
- finalize-contents compute-free-vregs
- ] unless ;
-
-: clear-phantoms ( -- )
- [ stack>> delete-all ] each-phantom ;
-
-PRIVATE>
-
-: set-operand-classes ( classes -- )
- phantom-datastack get
- over length over add-locs
- stack>> [ set-operand-class ] 2reverse-each ;
-
-: end-basic-block ( -- )
- #! 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 ;
-
-: with-template ( quot hash -- )
- clone [
- ensure-template-vregs
- template-inputs call template-outputs
- ] bind
- compute-free-vregs ; inline
-
-: do-template ( pair -- )
- #! Use with return value from find-template
- first2 with-template ;
-
-: fresh-object ( obj -- ) fresh-objects get push ;
-
-: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
-
-: init-templates ( -- )
- #! Initialize register allocator.
- V{ } clone fresh-objects set
- <phantom-datastack> phantom-datastack set
- <phantom-retainstack> phantom-retainstack set
- compute-free-vregs ;
-
-: copy-templates ( -- )
- #! Copies register allocator state, used when compiling
- #! branches.
- fresh-objects [ clone ] change
- phantom-datastack [ clone ] change
- phantom-retainstack [ clone ] change
- compute-free-vregs ;
-
-: find-template ( templates -- pair/f )
- #! Pair has shape { quot hash }
- [ second template-matches? ] find nip ;
-
-: 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
-Register allocation and intrinsic selection
+++ /dev/null
-Final stage of compilation generates machine code from dataflow IR
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes.tuple classes.tuple.private math arrays
-byte-arrays words stack-checker.known-words ;
-IN: compiler.intrinsics
-
-ERROR: missing-intrinsic ;
-
-: (tuple) ( n -- tuple ) missing-intrinsic ;
-
-\ (tuple) { tuple-layout } { tuple } define-primitive
-\ (tuple) make-flushable
-
-: (array) ( n -- array ) missing-intrinsic ;
-
-\ (array) { integer } { array } define-primitive
-\ (array) make-flushable
-
-: (byte-array) ( n -- byte-array ) missing-intrinsic ;
-
-\ (byte-array) { integer } { byte-array } define-primitive
-\ (byte-array) make-flushable
-
-: (ratio) ( -- ratio ) missing-intrinsic ;
-
-\ (ratio) { } { ratio } define-primitive
-\ (ratio) make-flushable
-
-: (complex) ( -- complex ) missing-intrinsic ;
-
-\ (complex) { } { complex } define-primitive
-\ (complex) make-flushable
-
-: (wrapper) ( -- wrapper ) missing-intrinsic ;
-
-\ (wrapper) { } { wrapper } define-primitive
-\ (wrapper) make-flushable
-
-: (set-slot) ( val obj n -- ) missing-intrinsic ;
-
-\ (set-slot) { object object fixnum } { } define-primitive
-
-: (write-barrier) ( obj -- ) missing-intrinsic ;
-
-\ (write-barrier) { object } { } define-primitive
{ "float" "h" }
;
-: <rect>
+: <rect> ( x y w h -- rect )
"rect" <c-object>
[ set-rect-h ] keep
[ set-rect-w ] keep
strings.private system random layouts vectors
sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
-namespaces libc sequences.private io.encodings.ascii ;
+namespaces libc sequences.private io.encodings.ascii
+classes ;
IN: compiler.tests
! Make sure that intrinsic ops compile to correct code.
[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
-[ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-call first ] unit-test
+
+[ { f f } ] [ 2 f <array> ] unit-test
+
+[ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test
! Write barrier hits on the wrong value were causing segfaults
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
-! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
-! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
-! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
-!
-! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
+[ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
+[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
+[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
+[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
+[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
+[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
+
+[ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
[ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
+[ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
+[ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
+[ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
+
[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
[ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
! Some randomized tests
: compiled-fixnum* fixnum* ;
-: test-fixnum* ( -- )
- 32 random-bits >fixnum 32 random-bits >fixnum
- 2dup
- [ fixnum* ] 2keep compiled-fixnum* =
- [ 2drop ] [ "Oops" throw ] if ;
-
-[ ] [ 10000 [ test-fixnum* ] times ] unit-test
+[ ] [
+ 10000 [
+ 32 random-bits >fixnum 32 random-bits >fixnum
+ 2dup
+ [ fixnum* ] 2keep compiled-fixnum* =
+ [ 2drop ] [ "Oops" throw ] if
+ ] times
+] unit-test
: compiled-fixnum>bignum fixnum>bignum ;
-: test-fixnum>bignum ( -- )
- 32 random-bits >fixnum
- dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
- [ drop ] [ "Oops" throw ] if ;
+[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
-[ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test
+[ ] [
+ 10000 [
+ 32 random-bits >fixnum
+ dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
+ [ drop ] [ "Oops" throw ] if
+ ] times
+] unit-test
: compiled-bignum>fixnum bignum>fixnum ;
-: test-bignum>fixnum ( -- )
- 5 random [ drop 32 random-bits ] map product >bignum
- dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
- [ drop ] [ "Oops" throw ] if ;
-
-[ ] [ 10000 [ test-bignum>fixnum ] times ] unit-test
+[ ] [
+ 10000 [
+ 5 random [ drop 32 random-bits ] map product >bignum
+ dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
+ [ drop ] [ "Oops" throw ] if
+ ] times
+] unit-test
! Test overflow check removal
[ t ] [
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
-: xword-def ( word -- def ) def>> [ { fixnum } declare ] prepend ;
-
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
-[ -100 ] [ -100 \ <char> xword-def compile-call *char ] unit-test
-[ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] unit-test
+[ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test
+[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test
[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
-[ -1000 ] [ -1000 \ <short> xword-def compile-call *short ] unit-test
-[ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] unit-test
+[ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test
+[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test
[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
-[ -100000 ] [ -100000 \ <int> xword-def compile-call *int ] unit-test
-[ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] unit-test
+[ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test
+[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
[ t ] [ pi pi <double> *double = ] unit-test
] compile-call
b>>
] unit-test
+
+: mutable-value-bug-1 ( a b -- c )
+ swap [
+ { tuple } declare 1 slot
+ ] [
+ 0 slot
+ ] if ;
+
+[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
+
+: mutable-value-bug-2 ( a b -- c )
+ swap [
+ 0 slot
+ ] [
+ { tuple } declare 1 slot
+ ] if ;
+
+[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test
--- /dev/null
+! Calling the compiler at parse time and having it compile
+! generic words defined in the current compilation unit would
+! fail. This is a regression from the 'remake-generic'
+! optimization, which would batch generic word updates at the
+! end of a compilation unit.
+
+USING: kernel accessors peg.ebnf ;
+IN: compiler.tests
+
+TUPLE: pipeline-expr background ;
+
+GENERIC: blah ( a -- b )
+
+M: pipeline-expr blah ;
+
+: ast>pipeline-expr ( -- obj )
+ pipeline-expr new blah ;
+
+EBNF: expr
+pipeline = "hello" => [[ ast>pipeline-expr ]]
+;EBNF
+
+USE: tools.test
+
+[ t ] [ \ expr compiled>> ] unit-test
+[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test
--- /dev/null
+USING: kernel tools.test eval ;
+IN: compiler.tests.redefine12
+
+! A regression that came about when fixing the
+! 'no method on classes-intersect?' bug
+
+GENERIC: g ( a -- b )
+
+M: object g drop t ;
+
+: h ( a -- b ) dup [ g ] when ;
+
+[ f ] [ f h ] unit-test
+[ t ] [ "hi" h ] unit-test
+
+TUPLE: jeah ;
+
+[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
+
+[ f ] [ T{ jeah } h ] unit-test
sequences sequences.private classes.mixin generic definitions
arrays words assocs eval ;
-DEFER: blah
+DEFER: redefine2-test
-[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: blah ; M: blah nth 2drop 3 ; INSTANCE: blah sequence" eval ] unit-test
+[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
-[ t ] [ blah new sequence? ] unit-test
+[ t ] [ redefine2-test new sequence? ] unit-test
-[ 3 ] [ 0 blah new nth-unsafe ] unit-test
+[ 3 ] [ 0 redefine2-test new nth-unsafe ] unit-test
-[ ] [ [ blah sequence remove-mixin-instance ] with-compilation-unit ] unit-test
+[ ] [ [ redefine2-test sequence remove-mixin-instance ] with-compilation-unit ] unit-test
-[ f ] [ blah new sequence? ] unit-test
+[ f ] [ redefine2-test new sequence? ] unit-test
-[ 0 blah new nth-unsafe ] must-fail
+[ 0 redefine2-test new nth-unsafe ] must-fail
-USING: compiler.units tools.test kernel kernel.private
-sequences.private math.private math combinators strings
-alien arrays memory vocabs parser eval ;
+USING: compiler compiler.units tools.test kernel kernel.private
+sequences.private math.private math combinators strings alien
+arrays memory vocabs parser eval ;
IN: compiler.tests
+\ (compile) must-infer
+
! Test empty word
[ ] [ [ ] compile-call ] unit-test
! Labels
-: recursive ( ? -- ) [ f recursive ] when ; inline
+: recursive-test ( ? -- ) [ f recursive-test ] when ; inline
-[ ] [ t [ recursive ] compile-call ] unit-test
+[ ] [ t [ recursive-test ] compile-call ] unit-test
-[ ] [ t recursive ] unit-test
+[ ] [ t recursive-test ] unit-test
! Make sure error reporting works
--- /dev/null
+USING: math.private kernel combinators accessors arrays
+generalizations float-arrays tools.test ;
+IN: compiler.tests
+
+: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
+ {
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ } cleave ;
+
+[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
+[ 1.0 float-spill-bug ] unit-test
+
+[ t ] [ \ float-spill-bug compiled>> ] unit-test
+
+: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
+ {
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ } cleave ;
+
+[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
+[ 1.0 float-fixnum-spill-bug ] unit-test
+
+[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
+
+: resolve-spill-bug ( a b -- c )
+ [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
+ nip 2 fixnum+fast
+ ] [
+ drop {
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ } cleave
+ 16 narray
+ ] if ;
+
+[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+
+[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
+
+! The above don't really test spilling...
+: spill-test-1 ( a -- b )
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast fixnum>float
+ 3array
+ 3array [ 8 narray ] dip 2array
+ [ 8 narray [ 8 narray ] dip 2array ] dip 2array
+ 2array ;
+
+[
+ {
+ 1
+ {
+ { { 2 3 4 5 6 7 8 9 } { 10 11 12 13 14 15 16 17 } }
+ {
+ { 18 19 20 21 22 23 24 25 }
+ { 26 27 { 28 29 30.0 } }
+ }
+ }
+ }
+] [ 1 spill-test-1 ] unit-test
+
+: spill-test-2 ( a -- b )
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float* ;
+
+[ t ] [ 1.0 spill-test-2 1.0 \ spill-test-2 def>> call = ] unit-test
+++ /dev/null
-! Testing templates machinery without compiling anything
-IN: compiler.tests
-USING: compiler compiler.generator compiler.generator.registers
-compiler.generator.registers.private tools.test namespaces
-sequences words kernel math effects definitions compiler.units
-accessors cpu.architecture make ;
-
-: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
-
-[
- [ ] [ init-templates ] unit-test
-
- [ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test
-
- [ ] [ 0 <int-vreg> phantom-push ] unit-test
-
- [ ] [ compute-free-vregs ] unit-test
-
- [ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
-
- [ f ] [
- [
- copy-templates
- 1 <int-vreg> phantom-push
- compute-free-vregs
- 1 <int-vreg> int-regs free-vregs member?
- ] with-scope
- ] unit-test
-
- [ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
-] with-scope
-
-[
- [ ] [ init-templates ] unit-test
-
- [ ] [ T{ effect f 3 { 1 2 0 } f } phantom-shuffle ] unit-test
-
- [ 3 ] [ live-locs length ] unit-test
-
- [ ] [ T{ effect f 2 { 1 0 } f } phantom-shuffle ] unit-test
-
- [ 2 ] [ live-locs length ] unit-test
-] with-scope
-
-[
- [ ] [ init-templates ] unit-test
-
- H{ } clone compiled set
-
- [ ] [ gensym gensym begin-compiling ] unit-test
-
- [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-
- 3 fresh-object
-
- [ f ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-[
- [ ] [ init-templates ] unit-test
-
- H{
- { +input+ { { f "x" } } }
- } clone [
- [ 1 0 ] [ +input+ get { } { } guess-vregs ] unit-test
- [ ] [ finalize-contents ] unit-test
- [ ] [ [ template-inputs ] { } make drop ] unit-test
- ] bind
-] with-scope
-
-! Test template picking strategy
-SYMBOL: template-chosen
-
-: template-test ( a b -- c d ) ;
-
-\ template-test {
- {
- [
- 1 template-chosen get push
- ] H{
- { +input+ { { f "obj" } { [ ] "n" } } }
- { +output+ { "obj" "obj" } }
- }
- }
- {
- [
- 2 template-chosen get push
- ] H{
- { +input+ { { f "obj" } { f "n" } } }
- { +output+ { "obj" "n" } }
- }
- }
-} define-intrinsics
-
-[ V{ 2 } ] [
- V{ } clone template-chosen set
- 0 0 [ template-test ] compile-call 2drop
- template-chosen get
-] unit-test
-
-[ V{ 1 } ] [
- V{ } clone template-chosen set
- 1 [ dup 0 template-test ] compile-call 3drop
- template-chosen get
-] unit-test
-
-[ V{ 1 } ] [
- V{ } clone template-chosen set
- 1 [ 0 template-test ] compile-call 2drop
- template-chosen get
-] unit-test
-
-! Regression
-[
- [ ] [ init-templates ] unit-test
-
- ! dup dup
- [ ] [
- T{ effect f { "x" } { "x" "x" } } phantom-shuffle
- T{ effect f { "x" } { "x" "x" } } phantom-shuffle
- ] unit-test
-
- ! This is not empty since a load instruction is emitted
- [ f ] [
- [ { { f "x" } } +input+ set load-inputs ] { } make
- empty?
- ] unit-test
-
- ! This is empty since we already loaded the value
- [ t ] [
- [ { { f "x" } } +input+ set load-inputs ] { } make
- empty?
- ] unit-test
-
- ! This is empty since we didn't change the stack
- [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-! Regression
-[
- [ ] [ init-templates ] unit-test
-
- ! >r r>
- [ ] [
- 1 phantom->r
- 1 phantom-r>
- ] unit-test
-
- ! This is empty since we didn't change the stack
- [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-
- ! >r r>
- [ ] [
- 1 phantom->r
- 1 phantom-r>
- ] unit-test
-
- [ ] [ { object } set-operand-classes ] unit-test
-
- ! This is empty since we didn't change the stack
- [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-! Regression
-[
- [ ] [ init-templates ] unit-test
-
- [ ] [ { object object } set-operand-classes ] unit-test
-
- ! 2dup
- [ ] [
- T{ effect f { "x" "y" } { "x" "y" "x" "y" } }
- phantom-shuffle
- ] unit-test
-
- [ ] [
- 2 phantom-datastack get phantom-input
- [ { { f "a" } { f "b" } } lazy-load ] { } make drop
- ] unit-test
-
- [ t ] [
- phantom-datastack get stack>> [ cached? ] all?
- ] unit-test
-
- ! >r
- [ ] [
- 1 phantom->r
- ] unit-test
-
- ! This should not fail
- [ ] [ [ end-basic-block ] { } make drop ] unit-test
-] with-scope
-
-! Regression
-SYMBOL: templates-chosen
-
-V{ } clone templates-chosen set
-
-: template-choice-1 ;
-
-\ template-choice-1
-[ "template-choice-1" templates-chosen get push ]
-H{
- { +input+ { { f "obj" } { [ ] "n" } } }
- { +output+ { "obj" } }
-} define-intrinsic
-
-: template-choice-2 ;
-
-\ template-choice-2
-[ "template-choice-2" templates-chosen get push drop ]
-{ { f "x" } { f "y" } } define-if-intrinsic
-
-[ ] [
- [ 2 template-choice-1 template-choice-2 ]
- [ define-temp ] with-compilation-unit drop
-] unit-test
-
-[ V{ "template-choice-1" "template-choice-2" } ]
-[ templates-chosen get ] unit-test
-! Black box testing of templating optimization
-USING: accessors arrays compiler kernel kernel.private math
-hashtables.private math.private namespaces sequences
-sequences.private tools.test namespaces.private slots.private
-sequences.private byte-arrays alien alien.accessors layouts
-words definitions compiler.units io combinators vectors ;
+USING: generalizations accessors arrays compiler kernel
+kernel.private math hashtables.private math.private namespaces
+sequences sequences.private tools.test namespaces.private
+slots.private sequences.private byte-arrays alien
+alien.accessors layouts words definitions compiler.units io
+combinators vectors float-arrays ;
IN: compiler.tests
+! Originally, this file did black box testing of templating
+! optimization. We now have a different codegen, but the tests
+! in here are still useful.
+
! Oops!
[ 5000 ] [ [ 5000 ] compile-call ] unit-test
[ "hi" ] [ [ "hi" ] compile-call ] unit-test
] [ define-temp ] with-compilation-unit drop
] unit-test
-
! Test how dispatch handles the end of a basic block
-: try-breaking-dispatch ( n a b -- a b str )
+: try-breaking-dispatch ( n a b -- x str )
float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
: try-breaking-dispatch-2 ( -- ? )
] unit-test
! Regression
-: hellish-bug-1 2drop ;
+: hellish-bug-1 ( a b -- ) 2drop ;
: hellish-bug-2 ( i array x -- x )
2dup 1 slot eq? [ 2drop ] [
pick 2dup hellish-bug-1 3drop
] 2keep
] unless >r 2 fixnum+fast r> hellish-bug-2
- ] if ; inline
+ ] if ; inline recursive
: hellish-bug-3 ( hash array -- )
0 swap hellish-bug-2 drop ;
] unit-test
! Regression
-: a-dummy ( -- ) drop "hi" print ;
+: a-dummy ( a -- ) drop "hi" print ;
[ ] [
1 [
] compile-call
] unit-test
-: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
- {
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- } cleave ;
-
-[ t ] [ \ float-spill-bug compiled>> ] unit-test
-
! Regression
: dispatch-alignment-regression ( -- c )
{ tuple vector } 3 slot { word } declare
[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test
+
+! Regression
+: bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
+
+[ { f f f } ] [ t bad-value-bug ] unit-test
+
+! PowerPC regression
+TUPLE: id obj ;
+
+: (gc-check-bug) ( a b -- c )
+ { [ id boa ] [ id boa ] } dispatch ;
+
+: gc-check-bug ( -- )
+ 10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
+
+[ ] [ gc-check-bug ] unit-test
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
- [ V{ } clone stack-visitor set ] prepose
+ '[ V{ } clone stack-visitor set @ ]
with-infer ; inline
: build-tree ( quot -- nodes )
definitions system layouts vectors math.partial-dispatch
math.order math.functions accessors hashtables classes assocs
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
-sorting.private
+sorting.private combinators.short-circuit grouping prettyprint
compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
+compiler.tree.propagation.info
compiler.tree.checker
compiler.tree.debugger ;
[ t ] [
[ hashtable new ] \ new inlined?
] unit-test
+
+[ t ] [
+ [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
+ [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
+] unit-test
+
+[ ] [
+ [ { null } declare [ 1 ] [ 2 ] if ]
+ build-tree normalize propagate cleanup check-nodes
+] unit-test
+
+[ t ] [
+ [ { array } declare 2 <groups> [ . . ] assoc-each ]
+ \ nth-unsafe inlined?
+] unit-test
math.partial-dispatch math.intervals classes classes.tuple
classes.tuple.private layouts definitions stack-checker.state
stack-checker.branches
-compiler.intrinsics
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
} cond ;
: remove-overflow-check ( #call -- #call )
- [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
+ [ no-overflow-variant ] change-word cleanup* ;
M: #call cleanup*
{
#! If only one branch is live we don't need to branch at
#! all; just drop the condition value.
dup live-children sift dup length {
- { 0 [ 2drop f ] }
+ { 0 [ drop in-d>> #drop ] }
{ 1 [ first swap in-d>> #drop prefix ] }
[ 2drop ]
} case ;
: sift-children ( seq flags -- seq' )
zip [ nip ] assoc-filter keys ;
-: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
+: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
GENERIC: node>quot ( node -- )
MACRO: match-choose ( alist -- )
- [ [ ] curry ] assoc-map [ match-cond ] curry ;
+ [ '[ _ ] ] assoc-map '[ _ match-cond ] ;
MATCH-VARS: ?a ?b ?c ;
compiler.tree.combinators compiler.tree sequences math
math.private kernel tools.test accessors slots.private
quotations.private prettyprint classes.tuple.private classes
-classes.tuple compiler.intrinsics namespaces
+classes.tuple namespaces
compiler.tree.propagation.info stack-checker.errors
+compiler.tree.checker
kernel.private ;
\ escape-analysis must-infer
propagate
cleanup
escape-analysis
+ dup check-nodes
0 swap [ count-unboxed-allocations* ] each-node ;
[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
-[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
+[ 3 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
[ 0 ] [
[ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
classes.tuple.private arrays math math.private slots.private
combinators deques search-deques namespaces fry classes
classes.algebra stack-checker.state
-compiler.intrinsics
compiler.tree
compiler.tree.propagation.info
compiler.tree.escape-analysis.nodes
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays accessors sequences sequences.private words
-fry namespaces make math math.order memoize classes.builtin
-classes.tuple.private slots.private combinators layouts
-byte-arrays alien.accessors
-compiler.intrinsics
+USING: kernel accessors sequences words memoize classes.builtin
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
! See the comment in compiler.tree.late-optimizations.
! This pass runs after propagation, so that it can expand
-! built-in type predicates and memory allocation; these cannot
-! be expanded before propagation since we need to see 'fixnum?'
-! instead of 'tag 0 eq?' and so on, for semantic reasoning.
+! built-in type predicates; these cannot be expanded before
+! propagation since we need to see 'fixnum?' instead of
+! 'tag 0 eq?' and so on, for semantic reasoning.
+
! We also delete empty stack shuffles and copies to facilitate
! tail call optimization in the code generator.
GENERIC: finalize* ( node -- nodes )
+: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
+
+: splice-final ( quot -- nodes ) splice-quot finalize ;
+
M: #copy finalize* drop f ;
M: #shuffle finalize*
word>> "predicating" word-prop builtin-class? ;
MEMO: builtin-predicate-expansion ( word -- nodes )
- def>> splice-quot ;
+ def>> splice-final ;
: expand-builtin-predicate ( #call -- nodes )
word>> builtin-predicate-expansion ;
-: first-literal ( #call -- obj ) node-input-infos first literal>> ;
-
-: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
-
-: expand-tuple-boa? ( #call -- ? )
- dup word>> \ <tuple-boa> eq? [
- last-literal tuple-layout?
- ] [ drop f ] if ;
-
-MEMO: (tuple-boa-expansion) ( n -- quot )
- [
- [ 2 + ] map <reversed>
- [ '[ [ _ set-slot ] keep ] % ] each
- ] [ ] make ;
-
-: tuple-boa-expansion ( layout -- quot )
- #! No memoization here since otherwise we'd hang on to
- #! tuple layout objects.
- size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
-
-: expand-tuple-boa ( #call -- node )
- last-literal tuple-boa-expansion ;
-
-MEMO: <array>-expansion ( n -- quot )
- [
- [ swap (array) ] %
- [ \ 2dup , , [ swap set-array-nth ] % ] each
- \ nip ,
- ] [ ] make splice-quot ;
-
-: expand-<array>? ( #call -- ? )
- dup word>> \ <array> eq? [
- first-literal dup integer?
- [ 0 32 between? ] [ drop f ] if
- ] [ drop f ] if ;
-
-: expand-<array> ( #call -- node )
- first-literal <array>-expansion ;
-
-: bytes>cells ( m -- n ) cell align cell /i ;
-
-MEMO: <byte-array>-expansion ( n -- quot )
- [
- [ (byte-array) ] %
- bytes>cells [ cell * ] map
- [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
- ] [ ] make splice-quot ;
-
-: expand-<byte-array>? ( #call -- ? )
- dup word>> \ <byte-array> eq? [
- first-literal dup integer?
- [ 0 128 between? ] [ drop f ] if
- ] [ drop f ] if ;
-
-: expand-<byte-array> ( #call -- nodes )
- first-literal <byte-array>-expansion ;
-
M: #call finalize*
- {
- { [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
- { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
- { [ dup expand-<array>? ] [ expand-<array> ] }
- { [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
- [ ]
- } cond ;
+ dup builtin-predicate? [ expand-builtin-predicate ] when ;
M: node finalize* ;
-
-: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
GENERIC: compute-modularized-values* ( node -- )
M: #call compute-modularized-values*
- dup word>> {
- { [ \ >fixnum eq? ] [ in-d>> first maybe-modularize ] }
- ! { [
- ! {
- ! mod-integer-fixnum
- ! mod-integer-integer
- ! mod-fixnum-integer
- ! } memq?
- ! ] [ ] }
- [ drop ]
- } cond ;
+ dup word>> \ >fixnum eq?
+ [ in-d>> first maybe-modularize ] [ drop ] if ;
M: node compute-modularized-values* drop ;
SYMBOL: infer-children-data
: copy-value-info ( -- )
- value-infos [ clone ] change
- constraints [ clone ] change ;
+ value-infos [ H{ } clone suffix ] change
+ constraints [ H{ } clone suffix ] change ;
: no-value-info ( -- )
value-infos off
M: true-constraint assume*
[ \ f class-not <class-info> swap value>> refine-value-info ]
- [ constraints get at [ assume ] when* ]
+ [ constraints get assoc-stack [ assume ] when* ]
bi ;
M: true-constraint satisfied?
M: false-constraint assume*
[ \ f <class-info> swap value>> refine-value-info ]
- [ constraints get at [ assume ] when* ]
+ [ constraints get assoc-stack [ assume ] when* ]
bi ;
M: false-constraint satisfied?
C: --> implication
: assume-implication ( p q -- )
- [ constraints get [ swap suffix ] change-at ]
+ [ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: implication assume*
f f 3 <literal-info> 3array test-tuple <tuple-info> dup
object-info value-info-intersect =
] unit-test
+
+[ t ] [
+ null-info 3 <literal-info> value-info<=
+] unit-test
: null-info T{ value-info f null empty-interval } ; inline
-: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline
+: object-info T{ value-info f object full-interval } ; inline
: class-interval ( class -- interval )
dup real class<=
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
#! precise, we can turn it into a literal
- dup empty-interval eq? [
+ dup special-interval? [
2drop f f
] [
dup from>> first {
: literals<= ( info1 info2 -- ? )
{
{ [ dup literal?>> not ] [ 2drop t ] }
- { [ over literal?>> not ] [ 2drop f ] }
+ { [ over literal?>> not ] [ drop class>> null-class? ] }
[ [ literal>> ] bi@ eql? ]
} cond ;
]
} cond ;
-! Current value --> info mapping
+! Assoc stack of current value --> info mapping
SYMBOL: value-infos
: value-info ( value -- info )
- resolve-copy value-infos get at null-info or ;
+ resolve-copy value-infos get assoc-stack null-info or ;
: set-value-info ( info value -- )
- resolve-copy value-infos get set-at ;
+ resolve-copy value-infos get peek set-at ;
: refine-value-info ( info value -- )
- resolve-copy value-infos get [ value-info-intersect ] change-at ;
+ resolve-copy value-infos get
+ [ assoc-stack value-info-intersect ] 2keep
+ peek set-at ;
: value-literal ( value -- obj ? )
value-info >literal< ;
: immutable-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [
dup in-d>> peek node-value-info
- literal>> class>> immutable-tuple-class?
+ literal>> first immutable-tuple-class?
] [ drop f ] if ;
] bi* + + + + + ;
: should-inline? ( #call word -- ? )
- inlining-rank 5 >= ;
+ dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
SYMBOL: history
first object swap eliminate-dispatch ;
: do-inlining ( #call word -- ? )
+ #! If the generic was defined in an outer compilation unit,
+ #! then it doesn't have a definition yet; the definition
+ #! is built at the end of the compilation unit. We do not
+ #! attempt inlining at this stage since the stack discipline
+ #! is not finalized yet, so dispatch# might return an out
+ #! of bounds value. This case comes up if a parsing word
+ #! calls the compiler at parse time (doing so is
+ #! discouraged, but it should still work.)
{
+ { [ dup deferred? ] [ 2drop f ] }
{ [ dup custom-inlining? ] [ inline-custom ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
classes.tuple alien.accessors classes.tuple.private slots.private
definitions
stack-checker.state
-compiler.intrinsics
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.nodes
}
} cond
[ fixnum fits? fixnum integer ? ] keep <class/interval-info>
- [ 2nip ] curry "outputs" set-word-prop
+ '[ 2drop _ ] "outputs" set-word-prop
] each
-{ <tuple> <tuple-boa> (tuple) } [
+{ <tuple> <tuple-boa> } [
[
- literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
+ literal>> dup array? [ first ] [ drop tuple ] if <class-info>
[ clear ] dip
] "outputs" set-word-prop
] each
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
-float-arrays system ;
+float-arrays system sorting ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
[ T{ mutable-tuple-test f "hey" } x>> ] final-classes
] unit-test
-[ V{ tuple-layout } ] [
+[ V{ array } ] [
[ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
] unit-test
[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
+[ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences namespaces hashtables
+USING: accessors kernel sequences namespaces hashtables arrays
compiler.tree
compiler.tree.propagation.copy
compiler.tree.propagation.info
: propagate ( node -- node )
H{ } clone copies set
- H{ } clone constraints set
- H{ } clone value-infos set
+ H{ } clone 1array value-infos set
+ H{ } clone 1array constraints set
dup count-nodes
dup (propagate) ;
[ value-info<= ] 2all?
[ drop ] [ label>> f >>fixed-point drop ] if ;
+: latest-input-infos ( node -- infos )
+ in-d>> [ value-info ] map ;
+
: recursive-stacks ( #enter-recursive -- stacks initial )
[ label>> calls>> [ node-input-infos ] map flip ]
- [ in-d>> [ value-info ] map ] bi ;
+ [ latest-input-infos ] bi ;
: generalize-counter-interval ( interval initial-interval -- interval' )
{
] if ;
: propagate-recursive-phi ( #enter-recursive -- )
- [ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
- [ node-output-infos check-fixed-point ]
- [ out-d>> set-value-infos drop ]
- 3bi ;
+ [ recursive-stacks unify-recursive-stacks ] keep
+ out-d>> set-value-infos ;
M: #recursive propagate-around ( #recursive -- )
+ constraints [ H{ } clone suffix ] change
[
- constraints [ clone ] change
+ constraints [ but-last H{ } clone suffix ] change
child>>
[ first compute-copy-equiv ]
tri
] until-fixed-point ;
+: recursive-phi-infos ( node -- infos )
+ label>> enter-recursive>> node-output-infos ;
+
: generalize-return-interval ( info -- info' )
dup [ literal?>> ] [ class>> null-class? ] bi or
[ clone [-inf,inf] >>interval ] unless ;
[ generalize-return-interval ] map ;
: return-infos ( node -- infos )
- label>> [ return>> node-input-infos ] [ loop?>> ] bi
- [ generalize-return ] unless ;
+ label>> return>> node-input-infos generalize-return ;
+
+: save-return-infos ( node infos -- )
+ swap out-d>> set-value-infos ;
+
+: unless-loop ( node quot -- )
+ [ dup label>> loop?>> [ drop ] ] dip if ; inline
M: #call-recursive propagate-before ( #call-recursive -- )
- [ ] [ return-infos ] [ node-output-infos ] tri
- [ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;
+ [
+ [ ] [ latest-input-infos ] [ recursive-phi-infos ] tri
+ check-fixed-point
+ ]
+ [
+ [
+ [ ] [ return-infos ] [ node-output-infos ] tri
+ [ check-fixed-point ] [ drop save-return-infos ] 3bi
+ ] unless-loop
+ ] bi ;
M: #call-recursive annotate-node
dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
M: #enter-recursive annotate-node
dup out-d>> (annotate-node) ;
+M: #return-recursive propagate-before ( #return-recursive -- )
+ [
+ [ ] [ latest-input-infos ] [ node-input-infos ] tri
+ check-fixed-point
+ ] unless-loop ;
+
M: #return-recursive annotate-node
dup in-d>> (annotate-node) ;
: propagate-<tuple-boa> ( #call -- info )
in-d>> unclip-last
- value-info literal>> class>> (propagate-tuple-constructor) ;
+ value-info literal>> first (propagate-tuple-constructor) ;
: propagate-<complex> ( #call -- info )
in-d>> [ value-info ] map complex <tuple-info> ;
classes.algebra sequences sequences.deep slots.private
classes.tuple.private math math.private arrays
stack-checker.branches
-compiler.intrinsics
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
! See http://factorcode.org/license.txt for BSD license.\r
IN: concurrency.mailboxes\r
USING: dlists deques threads sequences continuations\r
-destructors namespaces random math quotations words kernel\r
+destructors namespaces math quotations words kernel\r
arrays assocs init system concurrency.conditions accessors\r
debugger debugger.threads locals ;\r
\r
! Concurrency library for Factor, based on Erlang/Termite style\r
! concurrency.\r
USING: kernel threads concurrency.mailboxes continuations\r
-namespaces assocs random accessors summary ;\r
+namespaces assocs accessors summary ;\r
IN: concurrency.messaging\r
\r
GENERIC: send ( message thread -- )\r
TUPLE: synchronous data sender tag ;\r
\r
: <synchronous> ( data -- sync )\r
- self 256 random-bits synchronous boa ;\r
+ self synchronous counter synchronous boa ;\r
\r
TUPLE: reply data tag ;\r
\r
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic kernel kernel.private math
memory namespaces make sequences layouts system hashtables
-classes alien byte-arrays combinators words sets ;
+classes alien byte-arrays combinators words sets fry ;
IN: cpu.architecture
+! Labels
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
+
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
+! Mapping from register class to machine registers
+HOOK: machine-registers cpu ( -- assoc )
+
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
M: object param-reg param-regs nth ;
-! Sequence mapping vreg-n to native assembler registers
-GENERIC: vregs ( register-class -- regs )
-
-! Load a literal (immediate or indirect)
-GENERIC# load-literal 1 ( obj vreg -- )
+HOOK: two-operand? cpu ( -- ? )
-HOOK: load-indirect cpu ( obj reg -- )
-
-HOOK: stack-frame-size cpu ( frame-size -- n )
-
-TUPLE: stack-frame total-size size params return ;
-
-! Set up caller stack frame
-HOOK: %prologue cpu ( n -- )
+HOOK: %load-immediate cpu ( reg obj -- )
+HOOK: %load-indirect cpu ( reg obj -- )
-: %prologue-later ( -- ) \ %prologue-later , ;
-
-! Tear down stack frame
-HOOK: %epilogue cpu ( n -- )
-
-: %epilogue-later ( -- ) \ %epilogue-later , ;
-
-! Store word XT in stack frame
-HOOK: %save-word-xt cpu ( -- )
-
-! Store dispatch branch XT in stack frame
-HOOK: %save-dispatch-xt cpu ( -- )
-
-M: object %save-dispatch-xt %save-word-xt ;
+HOOK: %peek cpu ( vreg loc -- )
+HOOK: %replace cpu ( vreg loc -- )
+HOOK: %inc-d cpu ( n -- )
+HOOK: %inc-r cpu ( n -- )
-! Call another word
+HOOK: stack-frame-size cpu ( stack-frame -- n )
HOOK: %call cpu ( word -- )
-
-! Local jump for branches
HOOK: %jump-label cpu ( label -- )
+HOOK: %return cpu ( -- )
-! Test if vreg is 'f' or not
-HOOK: %jump-f cpu ( label -- )
-
-HOOK: %dispatch cpu ( -- )
-
+HOOK: %dispatch cpu ( src temp -- )
HOOK: %dispatch-label cpu ( word -- )
-! Return to caller
-HOOK: %return cpu ( -- )
+HOOK: %slot cpu ( dst obj slot tag temp -- )
+HOOK: %slot-imm cpu ( dst obj slot tag -- )
+HOOK: %set-slot cpu ( src obj slot tag temp -- )
+HOOK: %set-slot-imm cpu ( src obj slot tag -- )
+
+HOOK: %string-nth cpu ( dst obj index temp -- )
+
+HOOK: %add cpu ( dst src1 src2 -- )
+HOOK: %add-imm cpu ( dst src1 src2 -- )
+HOOK: %sub cpu ( dst src1 src2 -- )
+HOOK: %sub-imm cpu ( dst src1 src2 -- )
+HOOK: %mul cpu ( dst src1 src2 -- )
+HOOK: %mul-imm cpu ( dst src1 src2 -- )
+HOOK: %and cpu ( dst src1 src2 -- )
+HOOK: %and-imm cpu ( dst src1 src2 -- )
+HOOK: %or cpu ( dst src1 src2 -- )
+HOOK: %or-imm cpu ( dst src1 src2 -- )
+HOOK: %xor cpu ( dst src1 src2 -- )
+HOOK: %xor-imm cpu ( dst src1 src2 -- )
+HOOK: %shl-imm cpu ( dst src1 src2 -- )
+HOOK: %shr-imm cpu ( dst src1 src2 -- )
+HOOK: %sar-imm cpu ( dst src1 src2 -- )
+HOOK: %not cpu ( dst src -- )
+
+HOOK: %integer>bignum cpu ( dst src temp -- )
+HOOK: %bignum>integer cpu ( dst src temp -- )
+
+HOOK: %add-float cpu ( dst src1 src2 -- )
+HOOK: %sub-float cpu ( dst src1 src2 -- )
+HOOK: %mul-float cpu ( dst src1 src2 -- )
+HOOK: %div-float cpu ( dst src1 src2 -- )
+
+HOOK: %integer>float cpu ( dst src -- )
+HOOK: %float>integer cpu ( dst src -- )
+
+HOOK: %copy cpu ( dst src -- )
+HOOK: %copy-float cpu ( dst src -- )
+HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
+HOOK: %box-float cpu ( dst src temp -- )
+HOOK: %box-alien cpu ( dst src temp -- )
+
+HOOK: %alien-unsigned-1 cpu ( dst src -- )
+HOOK: %alien-unsigned-2 cpu ( dst src -- )
+HOOK: %alien-unsigned-4 cpu ( dst src -- )
+HOOK: %alien-signed-1 cpu ( dst src -- )
+HOOK: %alien-signed-2 cpu ( dst src -- )
+HOOK: %alien-signed-4 cpu ( dst src -- )
+HOOK: %alien-cell cpu ( dst src -- )
+HOOK: %alien-float cpu ( dst src -- )
+HOOK: %alien-double cpu ( dst src -- )
+
+HOOK: %set-alien-integer-1 cpu ( ptr value -- )
+HOOK: %set-alien-integer-2 cpu ( ptr value -- )
+HOOK: %set-alien-integer-4 cpu ( ptr value -- )
+HOOK: %set-alien-cell cpu ( ptr value -- )
+HOOK: %set-alien-float cpu ( ptr value -- )
+HOOK: %set-alien-double cpu ( ptr value -- )
+
+HOOK: %allot cpu ( dst size class temp -- )
+HOOK: %write-barrier cpu ( src card# table -- )
+HOOK: %gc cpu ( -- )
-! Change datastack height
-HOOK: %inc-d cpu ( n -- )
+HOOK: %prologue cpu ( n -- )
+HOOK: %epilogue cpu ( n -- )
-! Change callstack height
-HOOK: %inc-r cpu ( n -- )
+HOOK: %compare cpu ( dst cc src1 src2 -- )
+HOOK: %compare-imm cpu ( dst cc src1 src2 -- )
+HOOK: %compare-float cpu ( dst cc src1 src2 -- )
-! Load stack into vreg
-HOOK: %peek cpu ( vreg loc -- )
+HOOK: %compare-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
-! Store vreg to stack
-HOOK: %replace cpu ( vreg loc -- )
+HOOK: %spill-integer cpu ( src n -- )
+HOOK: %spill-float cpu ( src n -- )
+HOOK: %reload-integer cpu ( dst n -- )
+HOOK: %reload-float cpu ( dst n -- )
-! Box and unbox floats
-HOOK: %unbox-float cpu ( dst src -- )
-HOOK: %box-float cpu ( dst src -- )
+HOOK: %loop-entry cpu ( -- )
! FFI stuff
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( heap-size -- ? )
-! Do we pass explode value structs?
+! Do we pass value structs by value or hidden reference?
HOOK: value-structs? cpu ( -- ? )
-! If t, fp parameters are shadowed by dummy int parameters
-HOOK: fp-shadows-int? cpu ( -- ? )
+! If t, all parameters are shadowed by dummy stack parameters
+HOOK: dummy-stack-params? cpu ( -- ? )
+
+! If t, all FP parameters are shadowed by dummy int parameters
+HOOK: dummy-int-params? cpu ( -- ? )
+
+! If t, all int parameters are shadowed by dummy FP parameters
+HOOK: dummy-fp-params? cpu ( -- ? )
HOOK: %prepare-unbox cpu ( -- )
HOOK: %alien-invoke cpu ( function library -- )
-HOOK: %cleanup cpu ( alien-node -- )
-
-HOOK: %alien-callback cpu ( quot -- )
-
-HOOK: %callback-value cpu ( ctype -- )
+HOOK: %cleanup cpu ( params -- )
-! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind cpu ( n -- )
+M: object %cleanup ( params -- ) drop ;
HOOK: %prepare-alien-indirect cpu ( -- )
HOOK: %alien-indirect cpu ( -- )
-M: stack-params param-reg drop ;
-
-M: stack-params param-regs drop f ;
-
-GENERIC: v>operand ( obj -- operand )
+HOOK: %alien-callback cpu ( quot -- )
-M: integer v>operand tag-fixnum ;
+HOOK: %callback-value cpu ( ctype -- )
-M: f v>operand drop \ f tag-number ;
+! Return to caller with stdcall unwinding (only for x86)
+HOOK: %callback-return cpu ( params -- )
-M: object load-literal v>operand load-indirect ;
+M: object %callback-return drop %return ;
-PREDICATE: small-slot < integer cells small-enough? ;
+M: stack-params param-reg drop ;
-PREDICATE: small-tagged < integer v>operand small-enough? ;
+M: stack-params param-regs drop f ;
: if-small-struct ( n size true false -- ? )
- [ over not over struct-small-enough? and ] 2dip
- [ [ nip ] prepose ] dip if ;
+ [ 2dup [ not ] [ struct-small-enough? ] bi* and ] 2dip
+ [ '[ nip @ ] ] dip if ;
inline
: %unbox-struct ( n c-type -- )
- [
- %unbox-small-struct
- ] [
- %unbox-large-struct
- ] if-small-struct ;
+ [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
: %box-struct ( n c-type -- )
- [
- %box-small-struct
- ] [
- %box-large-struct
- ] if-small-struct ;
-
-! Alien accessors
-HOOK: %unbox-byte-array cpu ( dst src -- )
-
-HOOK: %unbox-alien cpu ( dst src -- )
-
-HOOK: %unbox-f cpu ( dst src -- )
-
-HOOK: %unbox-any-c-ptr cpu ( dst src -- )
-
-HOOK: %box-alien cpu ( dst src -- )
-
-! GC check
-HOOK: %gc cpu ( -- )
-
-: operand ( var -- op ) get v>operand ; inline
-
-: unique-operands ( operands quot -- )
- >r [ operand ] map prune r> each ; inline
+ [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel cpu.ppc.architecture cpu.ppc.assembler
-kernel.private namespaces math sequences generic arrays
-compiler.generator compiler.generator.registers
-compiler.generator.fixup system layouts
-cpu.architecture alien ;
-IN: cpu.ppc.allot
-
-: load-zone-ptr ( reg -- )
- >r "nursery" f r> %load-dlsym ;
-
-: %allot ( header size -- )
- #! Store a pointer to 'size' bytes allocated from the
- #! nursery in r11.
- 8 align ! align the size
- 12 load-zone-ptr ! nusery -> r12
- 11 12 cell LWZ ! nursery.here -> r11
- 11 11 pick ADDI ! increment r11
- 11 12 cell STW ! r11 -> nursery.here
- 11 11 rot SUBI ! old value
- type-number tag-fixnum 12 LI ! compute header
- 12 11 0 STW ! store header
- ;
-
-: %store-tagged ( reg tag -- )
- >r dup fresh-object v>operand 11 r> tag-number ORI ;
-
-M: ppc %gc
- "end" define-label
- 12 load-zone-ptr
- 11 12 cell LWZ ! nursery.here -> r11
- 12 12 3 cells LWZ ! nursery.end -> r12
- 11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
- 11 0 12 CMP ! is here >= end?
- "end" get BLE
- 0 frame-required
- %prepare-alien-invoke
- "minor_gc" f %alien-invoke
- "end" resolve-label ;
-
-: %allot-float ( reg -- )
- #! exits with tagged ptr to object in r12, untagged in r11
- float 16 %allot
- 11 8 STFD
- 12 11 float tag-number ORI
- f fresh-object ;
-
-M: ppc %box-float ( dst src -- )
- [ v>operand ] bi@ %allot-float 12 MR ;
-
-: %allot-bignum ( #digits -- )
- #! 1 cell header, 1 cell length, 1 cell sign, + digits
- #! length is the # of digits + sign
- bignum over 3 + cells %allot
- 1+ v>operand 12 LI ! compute the length
- 12 11 cell STW ! store the length
- ;
-
-: %allot-bignum-signed-1 ( reg -- )
- #! on entry, reg is a 30-bit quantity sign-extended to
- #! 32-bits.
- #! exits with tagged ptr to bignum in reg
- [
- { "end" "non-zero" "pos" "store" } [ define-label ] each
- ! is it zero?
- 0 over v>operand 0 CMPI
- "non-zero" get BNE
- 0 >bignum over load-literal
- "end" get B
- ! it is non-zero
- "non-zero" resolve-label
- 1 %allot-bignum
- ! is the fixnum negative?
- 0 over v>operand 0 CMPI
- "pos" get BGE
- 1 12 LI
- ! store negative sign
- 12 11 2 cells STW
- ! negate fixnum
- dup v>operand dup -1 MULI
- "store" get B
- "pos" resolve-label
- 0 12 LI
- ! store positive sign
- 12 11 2 cells STW
- "store" resolve-label
- ! store the number
- dup v>operand 11 3 cells STW
- ! tag the bignum, store it in reg
- bignum %store-tagged
- "end" resolve-label
- ] with-scope ;
-
-M: ppc %box-alien ( dst src -- )
- { "end" "f" } [ define-label ] each
- 0 over v>operand 0 CMPI
- "f" get BEQ
- alien 4 cells %allot
- ! Store offset
- v>operand 11 3 cells STW
- f v>operand 12 LI
- ! Store expired slot
- 12 11 1 cells STW
- ! Store underlying-alien slot
- 12 11 2 cells STW
- ! Store tagged ptr in reg
- dup object %store-tagged
- "end" get B
- "f" resolve-label
- f v>operand swap v>operand LI
- "end" resolve-label ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-PowerPC inline memory allocation
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types cpu.ppc.assembler
-cpu.architecture generic kernel kernel.private math memory
-namespaces sequences words assocs compiler.generator
-compiler.generator.registers compiler.generator.fixup system
-layouts classes words.private alien combinators
-compiler.constants math.order make ;
-IN: cpu.ppc.architecture
-
-! PowerPC register assignments
-! r3-r10, r16-r31: integer vregs
-! f0-f13: float vregs
-! r11, r12: scratch
-! r14: data stack
-! r15: retain stack
-
-: ds-reg 14 ; inline
-: rs-reg 15 ; inline
-
-: reserved-area-size ( -- n )
- os {
- { linux [ 2 ] }
- { macosx [ 6 ] }
- } case cells ; foldable
-
-: lr-save ( -- n )
- os {
- { linux [ 1 ] }
- { macosx [ 2 ] }
- } case cells ; foldable
-
-: param@ ( n -- x ) reserved-area-size + ; inline
-
-: param-save-size ( -- n ) 8 cells ; foldable
-
-: local@ ( n -- x )
- reserved-area-size param-save-size + + ; inline
-
-: factor-area-size ( -- n ) 2 cells ; foldable
-
-: next-save ( n -- i ) cell - ;
-
-: xt-save ( n -- i ) 2 cells - ;
-
-M: ppc stack-frame-size ( n -- i )
- local@ factor-area-size + 4 cells align ;
-
-M: temp-reg v>operand drop 11 ;
-
-M: int-regs return-reg drop 3 ;
-M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
-M: int-regs vregs
- drop {
- 3 4 5 6 7 8 9 10
- 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
- } ;
-
-M: float-regs return-reg drop 1 ;
-M: float-regs param-regs
- drop os H{
- { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
- { linux { 1 2 3 4 5 6 7 8 } }
- } at ;
-M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
-
-GENERIC: loc>operand ( loc -- reg n )
-
-M: ds-loc loc>operand n>> cells neg ds-reg swap ;
-M: rs-loc loc>operand n>> cells neg rs-reg swap ;
-
-M: immediate load-literal
- [ v>operand ] bi@ LOAD ;
-
-M: ppc load-indirect ( obj reg -- )
- [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
- dup 0 LWZ ;
-
-M: ppc %save-word-xt ( -- )
- 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
-
-M: ppc %prologue ( n -- )
- 0 MFLR
- 1 1 pick neg ADDI
- 11 1 pick xt-save STW
- dup 11 LI
- 11 1 pick next-save STW
- 0 1 rot lr-save + STW ;
-
-M: ppc %epilogue ( n -- )
- #! At the end of each word that calls a subroutine, we store
- #! the previous link register value in r0 by popping it off
- #! the stack, set the link register to the contents of r0,
- #! and jump to the link register.
- 0 1 pick lr-save + LWZ
- 1 1 rot ADDI
- 0 MTLR ;
-
-: (%call) ( reg -- ) MTLR BLRL ;
-
-: (%jump) ( reg -- ) MTCTR BCTR ;
-
-: %load-dlsym ( symbol dll register -- )
- 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
-
-M: ppc %call ( label -- ) BL ;
-
-M: ppc %jump-label ( label -- ) B ;
-
-M: ppc %jump-f ( label -- )
- 0 "flag" operand f v>operand CMPI BEQ ;
-
-M: ppc %dispatch ( -- )
- [
- %epilogue-later
- 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
- "offset" operand "n" operand 1 SRAWI
- 11 11 "offset" operand ADD
- 11 dup 6 cells LWZ
- 11 (%jump)
- ] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "offset" } } }
- } with-template ;
-
-M: ppc %dispatch-label ( word -- )
- 0 , rc-absolute-cell rel-word ;
-
-M: ppc %return ( -- ) %epilogue-later BLR ;
-
-M: ppc %unwind drop %return ;
-
-M: ppc %peek ( vreg loc -- )
- >r v>operand r> loc>operand LWZ ;
-
-M: ppc %replace
- >r v>operand r> loc>operand STW ;
-
-M: ppc %unbox-float ( dst src -- )
- [ v>operand ] bi@ float-offset LFD ;
-
-M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
-
-M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
-
-M: int-regs %save-param-reg drop 1 rot local@ STW ;
-
-M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
-
-GENERIC: STF ( src dst off reg-class -- )
-
-M: single-float-regs STF drop STFS ;
-
-M: double-float-regs STF drop STFD ;
-
-M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
-
-GENERIC: LF ( dst src off reg-class -- )
-
-M: single-float-regs LF drop LFS ;
-
-M: double-float-regs LF drop LFD ;
-
-M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
-
-M: stack-params %load-param-reg ( stack reg reg-class -- )
- drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
-
-: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
-
-M: stack-params %save-param-reg ( stack reg reg-class -- )
- #! Funky. Read the parameter from the caller's stack frame.
- #! This word is used in callbacks
- drop
- 0 1 rot next-param@ LWZ
- 0 1 rot local@ STW ;
-
-M: ppc %prepare-unbox ( -- )
- ! First parameter is top of stack
- 3 ds-reg 0 LWZ
- ds-reg dup cell SUBI ;
-
-M: ppc %unbox ( n reg-class func -- )
- ! Value must be in r3
- ! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-
-M: ppc %unbox-long-long ( n func -- )
- ! Value must be in r3:r4
- ! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- [
- 3 1 pick local@ STW
- 4 1 rot cell + local@ STW
- ] when* ;
-
-M: ppc %unbox-large-struct ( n c-type -- )
- ! Value must be in r3
- ! Compute destination address and load struct size
- [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
- ! Call the function
- "to_value_struct" f %alien-invoke ;
-
-M: ppc %box ( n reg-class func -- )
- ! If the source is a stack location, load it into freg #0.
- ! If the source is f, then we assume the value is already in
- ! freg #0.
- >r
- over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
- r> f %alien-invoke ;
-
-M: ppc %box-long-long ( n func -- )
- >r [
- 3 1 pick local@ LWZ
- 4 1 rot cell + local@ LWZ
- ] when* r> f %alien-invoke ;
-
-: struct-return@ ( n -- n )
- [ stack-frame get params>> ] unless* local@ ;
-
-M: ppc %prepare-box-struct ( -- )
- #! Compute target address for value struct return
- 3 1 f struct-return@ ADDI
- 3 1 0 local@ STW ;
-
-M: ppc %box-large-struct ( n c-type -- )
- ! If n = f, then we're boxing a returned struct
- ! Compute destination address and load struct size
- [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
- ! Call the function
- "box_value_struct" f %alien-invoke ;
-
-M: ppc %prepare-alien-invoke
- #! Save Factor stack pointers in case the C code calls a
- #! callback which does a GC, which must reliably trace
- #! all roots.
- "stack_chain" f 11 %load-dlsym
- 11 11 0 LWZ
- 1 11 0 STW
- ds-reg 11 8 STW
- rs-reg 11 12 STW ;
-
-M: ppc %alien-invoke ( symbol dll -- )
- 11 %load-dlsym 11 (%call) ;
-
-M: ppc %alien-callback ( quot -- )
- 3 load-indirect "c_to_factor" f %alien-invoke ;
-
-M: ppc %prepare-alien-indirect ( -- )
- "unbox_alien" f %alien-invoke
- 13 3 MR ;
-
-M: ppc %alien-indirect ( -- )
- 13 (%call) ;
-
-M: ppc %callback-value ( ctype -- )
- ! Save top of data stack
- 3 ds-reg 0 LWZ
- 3 1 0 local@ STW
- ! Restore data/call/retain stacks
- "unnest_stacks" f %alien-invoke
- ! Restore top of data stack
- 3 1 0 local@ LWZ
- ! Unbox former top of data stack to return registers
- unbox-return ;
-
-M: ppc %cleanup ( alien-node -- ) drop ;
-
-: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
-
-: %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
-
-: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
-
-M: ppc value-structs?
- #! On Linux/PPC, value structs are passed in the same way
- #! as reference structs, we just have to make a copy first.
- os linux? not ;
-
-M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
-
-M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
-
-M: ppc struct-small-enough? ( size -- ? ) drop f ;
-
-M: ppc %box-small-struct
- drop "No small structs" throw ;
-
-M: ppc %unbox-small-struct
- drop "No small structs" throw ;
-
-! Alien intrinsics
-M: ppc %unbox-byte-array ( dst src -- )
- [ v>operand ] bi@ byte-array-offset ADDI ;
-
-M: ppc %unbox-alien ( dst src -- )
- [ v>operand ] bi@ alien-offset LWZ ;
-
-M: ppc %unbox-f ( dst src -- )
- drop 0 swap v>operand LI ;
-
-M: ppc %unbox-any-c-ptr ( dst src -- )
- { "is-byte-array" "end" "start" } [ define-label ] each
- ! Address is computed in R12
- 0 12 LI
- ! Load object into R11
- 11 swap v>operand MR
- ! We come back here with displaced aliens
- "start" resolve-label
- ! Is the object f?
- 0 11 f v>operand CMPI
- ! If so, done
- "end" get BEQ
- ! Is the object an alien?
- 0 11 header-offset LWZ
- 0 0 alien type-number tag-fixnum CMPI
- "is-byte-array" get BNE
- ! If so, load the offset
- 0 11 alien-offset LWZ
- ! Add it to address being computed
- 12 12 0 ADD
- ! Now recurse on the underlying alien
- 11 11 underlying-alien-offset LWZ
- "start" get B
- "is-byte-array" resolve-label
- ! Add byte array address to address being computed
- 12 12 11 ADD
- ! Add an offset to start of byte array's data area
- 12 12 byte-array-offset ADDI
- "end" resolve-label
- ! Done, store address in destination register
- v>operand 12 MR ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-PowerPC architecture description
+++ /dev/null
-unportable
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.generator.fixup kernel namespaces words
+USING: compiler.codegen.fixup kernel namespaces words
io.binary math math.order cpu.ppc.assembler.backend ;
IN: cpu.ppc.assembler
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.generator.fixup kernel namespaces make sequences
-words math math.bitwise io.binary parser lexer ;
+USING: compiler.codegen.fixup cpu.architecture
+compiler.constants kernel namespaces make sequences words math
+math.bitwise io.binary parser lexer ;
IN: cpu.ppc.assembler.backend
: insn ( operand opcode -- ) { 26 0 } bitfield , ;
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: bootstrap.image.private kernel kernel.private namespaces\r
-system cpu.ppc.assembler compiler.generator.fixup compiler.units\r
+system cpu.ppc.assembler compiler.codegen.fixup compiler.units\r
compiler.constants math math.private layouts words words.private\r
-vocabs slots.private ;\r
+vocabs slots.private locals.backend ;\r
IN: bootstrap.ppc\r
\r
4 \ cell set\r
\r
4 jit-code-format set\r
\r
-: ds-reg 14 ;\r
-: rs-reg 15 ;\r
+: ds-reg 29 ;\r
+: rs-reg 30 ;\r
\r
: factor-area-size ( -- n ) 4 bootstrap-cells ;\r
\r
3 ds-reg 0 STW\r
] f f f \ fixnum-bitnot define-sub-primitive\r
\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 tag-bits get SRAWI\r
+ ds-reg ds-reg 4 SUBI\r
+ 4 ds-reg 0 LWZ\r
+ 5 4 3 SLW\r
+ 6 3 NEG\r
+ 7 4 6 SRAW\r
+ 7 7 0 0 31 tag-bits get - RLWINM\r
+ 0 3 0 CMPI\r
+ 2 BGT\r
+ 5 7 MR\r
+ 5 ds-reg 0 STW\r
+] f f f \ fixnum-shift-fast define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg ds-reg 4 SUBI\r
+ 4 ds-reg 0 LWZ\r
+ 5 4 3 DIVW\r
+ 6 5 3 MULLW\r
+ 7 6 4 SUBF\r
+ 7 ds-reg 0 STW\r
+] f f f \ fixnum-mod define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 1 SRAWI\r
+ 4 4 LI\r
+ 4 3 4 SUBF\r
+ rs-reg 3 4 LWZX\r
+ 3 ds-reg 0 STW\r
+] f f f \ get-local define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg ds-reg 4 SUBI\r
+ 3 3 1 SRAWI\r
+ rs-reg 3 rs-reg SUBF\r
+] f f f \ drop-locals define-sub-primitive\r
+\r
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors alien.c-types arrays
-cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
-cpu.architecture kernel kernel.private math math.private
-namespaces sequences words generic quotations byte-arrays
-hashtables hashtables.private
-sequences.private sbufs vectors system layouts
-math.floats.private classes slots.private
-combinators
-compiler.constants
-compiler.intrinsics
-compiler.generator
-compiler.generator.fixup
-compiler.generator.registers ;
-IN: cpu.ppc.intrinsics
-
-: %slot-literal-known-tag ( -- out value offset )
- "val" operand
- "obj" operand
- "n" get cells
- "obj" get operand-tag - ;
-
-: %slot-literal-any-tag ( -- out value offset )
- "obj" operand "scratch1" operand %untag
- "val" operand "scratch1" operand "n" get cells ;
-
-: %slot-any ( -- out value offset )
- "obj" operand "scratch1" operand %untag
- "offset" operand "n" operand 1 SRAWI
- "scratch1" operand "val" operand "offset" operand ;
-
-\ slot {
- ! Slot number is literal and the tag is known
- {
- [ %slot-literal-known-tag LWZ ] H{
- { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "val" } } }
- { +output+ { "val" } }
- }
- }
- ! Slot number is literal
- {
- [ %slot-literal-any-tag LWZ ] H{
- { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "scratch1" } { f "val" } } }
- { +output+ { "val" } }
- }
- }
- ! Slot number in a register
- {
- [ %slot-any LWZX ] H{
- { +input+ { { f "obj" } { f "n" } } }
- { +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } }
- { +output+ { "val" } }
- }
- }
-} define-intrinsics
-
-: load-cards-offset ( dest -- )
- "cards_offset" f pick %load-dlsym dup 0 LWZ ;
-
-: load-decks-offset ( dest -- )
- "decks_offset" f pick %load-dlsym dup 0 LWZ ;
-
-: %write-barrier ( -- )
- "val" get operand-immediate? "obj" get fresh-object? or [
- card-mark "scratch1" operand LI
-
- ! Mark the card
- "val" operand load-cards-offset
- "obj" operand "scratch2" operand card-bits SRWI
- "scratch2" operand "scratch1" operand "val" operand STBX
-
- ! Mark the card deck
- "val" operand load-decks-offset
- "obj" operand "scratch2" operand deck-bits SRWI
- "scratch2" operand "scratch1" operand "val" operand STBX
- ] unless ;
-
-\ set-slot {
- ! Slot number is literal and tag is known
- {
- [ %slot-literal-known-tag STW %write-barrier ] H{
- { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "scratch1" } { f "scratch2" } } }
- { +clobber+ { "val" } }
- }
- }
- ! Slot number is literal
- {
- [ %slot-literal-any-tag STW %write-barrier ] H{
- { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "scratch1" } { f "scratch2" } } }
- { +clobber+ { "val" } }
- }
- }
- ! Slot number is in a register
- {
- [ %slot-any STWX %write-barrier ] H{
- { +input+ { { f "val" } { f "obj" } { f "n" } } }
- { +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } }
- { +clobber+ { "val" } }
- }
- }
-} define-intrinsics
-
-: fixnum-register-op ( op -- pair )
- [ "out" operand "y" operand "x" operand ] swap suffix H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- } 2array ;
-
-: fixnum-value-op ( op -- pair )
- [ "out" operand "x" operand "y" operand ] swap suffix H{
- { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- } 2array ;
-
-: define-fixnum-op ( word imm-op reg-op -- )
- >r fixnum-value-op r> fixnum-register-op 2array
- define-intrinsics ;
-
-{
- { fixnum+fast ADDI ADD }
- { fixnum-fast SUBI SUBF }
- { fixnum-bitand ANDI AND }
- { fixnum-bitor ORI OR }
- { fixnum-bitxor XORI XOR }
-} [
- first3 define-fixnum-op
-] each
-
-\ fixnum*fast {
- {
- [
- "out" operand "x" operand "y" get MULLI
- ] H{
- { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- }
- } {
- [
- "out" operand "x" operand %untag-fixnum
- "out" operand "y" operand "out" operand MULLW
- ] H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- }
- }
-} define-intrinsics
-
-: %untag-fixnums ( seq -- )
- [ dup %untag-fixnum ] unique-operands ;
-
-\ fixnum-shift-fast {
- {
- [
- "out" operand "x" operand "y" get
- dup 0 < [ neg SRAWI ] [ swapd SLWI ] if
- ! Mask off low bits
- "out" operand dup %untag
- ] H{
- { +input+ { { f "x" } { [ ] "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- }
- }
- {
- [
- { "positive" "end" } [ define-label ] each
- "out" operand "y" operand %untag-fixnum
- 0 "y" operand 0 CMPI
- "positive" get BGE
- "out" operand dup NEG
- "out" operand "x" operand "out" operand SRAW
- "end" get B
- "positive" resolve-label
- "out" operand "x" operand "out" operand SLW
- "end" resolve-label
- ! Mask off low bits
- "out" operand dup %untag
- ] H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- }
- }
-} define-intrinsics
-
-: generate-fixnum-mod ( -- )
- #! PowerPC doesn't have a MOD instruction; so we compute
- #! x-(x/y)*y. Puts the result in "s" operand.
- "s" operand "r" operand "y" operand MULLW
- "s" operand "s" operand "x" operand SUBF ;
-
-\ fixnum-mod [
- ! divide x by y, store result in x
- "r" operand "x" operand "y" operand DIVW
- generate-fixnum-mod
-] H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "r" } { f "s" } } }
- { +output+ { "s" } }
-} define-intrinsic
-
-\ fixnum-bitnot [
- "x" operand dup NOT
- "x" operand dup %untag
-] H{
- { +input+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-: fixnum-register-jump ( op -- pair )
- [ "x" operand 0 "y" operand CMP ] swap suffix
- { { f "x" } { f "y" } } 2array ;
-
-: fixnum-value-jump ( op -- pair )
- [ 0 "x" operand "y" operand CMPI ] swap suffix
- { { f "x" } { [ small-tagged? ] "y" } } 2array ;
-
-: define-fixnum-jump ( word op -- )
- [ fixnum-value-jump ] keep fixnum-register-jump
- 2array define-if-intrinsics ;
-
-{
- { fixnum< BGE }
- { fixnum<= BGT }
- { fixnum> BLE }
- { fixnum>= BLT }
- { eq? BNE }
-} [
- first2 define-fixnum-jump
-] each
-
-: overflow-check ( insn1 insn2 -- )
- [
- >r 0 0 LI
- 0 MTXER
- "r" operand "y" operand "x" operand r> execute
- >r
- "end" define-label
- "end" get BNO
- { "x" "y" } %untag-fixnums
- "r" operand "y" operand "x" operand r> execute
- "r" get %allot-bignum-signed-1
- "end" resolve-label
- ] with-scope ; inline
-
-: overflow-template ( word insn1 insn2 -- )
- [ overflow-check ] 2curry H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "r" } } }
- { +output+ { "r" } }
- { +clobber+ { "x" "y" } }
- } define-intrinsic ;
-
-\ fixnum+ \ ADD \ ADDO. overflow-template
-\ fixnum- \ SUBF \ SUBFO. overflow-template
-
-: generate-fixnum/i ( -- )
- #! This VOP is funny. If there is an overflow, it falls
- #! through to the end, and the result is in "x" operand.
- #! Otherwise it jumps to the "no-overflow" label and the
- #! result is in "r" operand.
- "end" define-label
- "no-overflow" define-label
- "r" operand "x" operand "y" operand DIVW
- ! if the result is greater than the most positive fixnum,
- ! which can only ever happen if we do
- ! most-negative-fixnum -1 /i, then the result is a bignum.
- most-positive-fixnum "s" operand LOAD
- "r" operand 0 "s" operand CMP
- "no-overflow" get BLE
- most-negative-fixnum neg "x" operand LOAD
- "x" get %allot-bignum-signed-1 ;
-
-\ fixnum/i [
- generate-fixnum/i
- "end" get B
- "no-overflow" resolve-label
- "r" operand "x" operand %tag-fixnum
- "end" resolve-label
-] H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "r" } { f "s" } } }
- { +output+ { "x" } }
- { +clobber+ { "y" } }
-} define-intrinsic
-
-\ fixnum/mod [
- generate-fixnum/i
- 0 "s" operand LI
- "end" get B
- "no-overflow" resolve-label
- generate-fixnum-mod
- "r" operand "x" operand %tag-fixnum
- "end" resolve-label
-] H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "r" } { f "s" } } }
- { +output+ { "x" "s" } }
- { +clobber+ { "y" } }
-} define-intrinsic
-
-\ fixnum>bignum [
- "x" operand dup %untag-fixnum
- "x" get %allot-bignum-signed-1
-] H{
- { +input+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-\ bignum>fixnum [
- "nonzero" define-label
- "positive" define-label
- "end" define-label
- "x" operand dup %untag
- "y" operand "x" operand cell LWZ
- ! if the length is 1, its just the sign and nothing else,
- ! so output 0
- 0 "y" operand 1 v>operand CMPI
- "nonzero" get BNE
- 0 "y" operand LI
- "end" get B
- "nonzero" resolve-label
- ! load the value
- "y" operand "x" operand 3 cells LWZ
- ! load the sign
- "x" operand "x" operand 2 cells LWZ
- ! is the sign negative?
- 0 "x" operand 0 CMPI
- "positive" get BEQ
- "y" operand dup -1 MULI
- "positive" resolve-label
- "y" operand dup %tag-fixnum
- "end" resolve-label
-] H{
- { +input+ { { f "x" } } }
- { +scratch+ { { f "y" } } }
- { +clobber+ { "x" } }
- { +output+ { "y" } }
-} define-intrinsic
-
-: define-float-op ( word op -- )
- [ "z" operand "x" operand "y" operand ] swap suffix H{
- { +input+ { { float "x" } { float "y" } } }
- { +scratch+ { { float "z" } } }
- { +output+ { "z" } }
- } define-intrinsic ;
-
-{
- { float+ FADD }
- { float- FSUB }
- { float* FMUL }
- { float/f FDIV }
-} [
- first2 define-float-op
-] each
-
-: define-float-jump ( word op -- )
- [ "x" operand 0 "y" operand FCMPU ] swap suffix
- { { float "x" } { float "y" } } define-if-intrinsic ;
-
-{
- { float< BGE }
- { float<= BGT }
- { float> BLE }
- { float>= BLT }
- { float= BNE }
-} [
- first2 define-float-jump
-] each
-
-\ float>fixnum [
- "scratch" operand "in" operand FCTIWZ
- "scratch" operand 1 0 param@ STFD
- "out" operand 1 cell param@ LWZ
- "out" operand dup %tag-fixnum
-] H{
- { +input+ { { float "in" } } }
- { +scratch+ { { float "scratch" } { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ fixnum>float [
- HEX: 4330 "scratch" operand LIS
- "scratch" operand 1 0 param@ STW
- "scratch" operand "in" operand %untag-fixnum
- "scratch" operand dup HEX: 8000 XORIS
- "scratch" operand 1 cell param@ STW
- "f1" operand 1 0 param@ LFD
- 4503601774854144.0 "scratch" operand load-indirect
- "f2" operand "scratch" operand float-offset LFD
- "f1" operand "f1" operand "f2" operand FSUB
-] H{
- { +input+ { { f "in" } } }
- { +scratch+ { { f "scratch" } { float "f1" } { float "f2" } } }
- { +output+ { "f1" } }
-} define-intrinsic
-
-
-\ tag [
- "out" operand "in" operand tag-mask get ANDI
- "out" operand dup %tag-fixnum
-] H{
- { +input+ { { f "in" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-: userenv ( reg -- )
- #! Load the userenv pointer in a register.
- "userenv" f rot %load-dlsym ;
-
-\ getenv [
- "n" operand dup 1 SRAWI
- "x" operand userenv
- "x" operand "n" operand "x" operand ADD
- "x" operand dup 0 LWZ
-] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "x" } } }
- { +output+ { "x" } }
- { +clobber+ { "n" } }
-} define-intrinsic
-
-\ setenv [
- "n" operand dup 1 SRAWI
- "x" operand userenv
- "x" operand "n" operand "x" operand ADD
- "val" operand "x" operand 0 STW
-] H{
- { +input+ { { f "val" } { f "n" } } }
- { +scratch+ { { f "x" } } }
- { +clobber+ { "n" } }
-} define-intrinsic
-
-\ (tuple) [
- tuple "layout" get size>> 2 + cells %allot
- ! Store layout
- "layout" get 12 load-indirect
- 12 11 cell STW
- ! Store tagged ptr in reg
- "tuple" get tuple %store-tagged
-] H{
- { +input+ { { [ ] "layout" } } }
- { +scratch+ { { f "tuple" } } }
- { +output+ { "tuple" } }
-} define-intrinsic
-
-\ (array) [
- array "n" get 2 + cells %allot
- ! Store length
- "n" operand 12 LI
- 12 11 cell STW
- ! Store tagged ptr in reg
- "array" get object %store-tagged
-] H{
- { +input+ { { [ ] "n" } } }
- { +scratch+ { { f "array" } } }
- { +output+ { "array" } }
-} define-intrinsic
-
-\ (byte-array) [
- byte-array "n" get 2 cells + %allot
- ! Store length
- "n" operand 12 LI
- 12 11 cell STW
- ! Store tagged ptr in reg
- "array" get object %store-tagged
-] H{
- { +input+ { { [ ] "n" } } }
- { +scratch+ { { f "array" } } }
- { +output+ { "array" } }
-} define-intrinsic
-
-\ <ratio> [
- ratio 3 cells %allot
- "numerator" operand 11 1 cells STW
- "denominator" operand 11 2 cells STW
- ! Store tagged ptr in reg
- "ratio" get ratio %store-tagged
-] H{
- { +input+ { { f "numerator" } { f "denominator" } } }
- { +scratch+ { { f "ratio" } } }
- { +output+ { "ratio" } }
-} define-intrinsic
-
-\ <complex> [
- complex 3 cells %allot
- "real" operand 11 1 cells STW
- "imaginary" operand 11 2 cells STW
- ! Store tagged ptr in reg
- "complex" get complex %store-tagged
-] H{
- { +input+ { { f "real" } { f "imaginary" } } }
- { +scratch+ { { f "complex" } } }
- { +output+ { "complex" } }
-} define-intrinsic
-
-\ <wrapper> [
- wrapper 2 cells %allot
- "obj" operand 11 1 cells STW
- ! Store tagged ptr in reg
- "wrapper" get object %store-tagged
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "wrapper" } } }
- { +output+ { "wrapper" } }
-} define-intrinsic
-
-! Alien intrinsics
-: %alien-accessor ( quot -- )
- "offset" operand dup %untag-fixnum
- "scratch" operand "offset" operand "alien" operand ADD
- "value" operand "scratch" operand 0 roll call ; inline
-
-: alien-integer-get-template
- H{
- { +input+ {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { f "value" } { f "scratch" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
- } ;
-
-: %alien-integer-get ( quot -- )
- %alien-accessor
- "value" operand dup %tag-fixnum ; inline
-
-: alien-integer-set-template
- H{
- { +input+ {
- { f "value" fixnum }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { f "scratch" } } }
- { +clobber+ { "value" "offset" } }
- } ;
-
-: %alien-integer-set ( quot -- )
- "offset" get "value" get = [
- "value" operand dup %untag-fixnum
- ] unless
- %alien-accessor ; inline
-
-: define-alien-integer-intrinsics ( word get-quot word set-quot -- )
- [ %alien-integer-set ] curry
- alien-integer-set-template
- define-intrinsic
- [ %alien-integer-get ] curry
- alien-integer-get-template
- define-intrinsic ;
-
-\ alien-unsigned-1 [ LBZ ]
-\ set-alien-unsigned-1 [ STB ]
-define-alien-integer-intrinsics
-
-\ alien-signed-1 [ pick >r LBZ r> dup EXTSB ]
-\ set-alien-signed-1 [ STB ]
-define-alien-integer-intrinsics
-
-\ alien-unsigned-2 [ LHZ ]
-\ set-alien-unsigned-2 [ STH ]
-define-alien-integer-intrinsics
-
-\ alien-signed-2 [ LHA ]
-\ set-alien-signed-2 [ STH ]
-define-alien-integer-intrinsics
-
-\ alien-cell [
- [ LWZ ] %alien-accessor
-] H{
- { +input+ {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { unboxed-alien "value" } { f "scratch" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
-} define-intrinsic
-
-\ set-alien-cell [
- [ STW ] %alien-accessor
-] H{
- { +input+ {
- { unboxed-c-ptr "value" pinned-c-ptr }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { f "scratch" } } }
- { +clobber+ { "offset" } }
-} define-intrinsic
-
-: alien-float-get-template
- H{
- { +input+ {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { float "value" } { f "scratch" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
- } ;
-
-: alien-float-set-template
- H{
- { +input+ {
- { float "value" float }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { f "scratch" } } }
- { +clobber+ { "offset" } }
- } ;
-
-: define-alien-float-intrinsics ( word get-quot word set-quot -- )
- [ %alien-accessor ] curry
- alien-float-set-template
- define-intrinsic
- [ %alien-accessor ] curry
- alien-float-get-template
- define-intrinsic ;
-
-\ alien-double [ LFD ]
-\ set-alien-double [ STFD ]
-define-alien-float-intrinsics
-
-\ alien-float [ LFS ]
-\ set-alien-float [ STFS ]
-define-alien-float-intrinsics
+++ /dev/null
-unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors system kernel layouts
+alien.c-types cpu.architecture cpu.ppc ;
+IN: cpu.ppc.linux
+
+<<
+t "longlong" c-type (>>stack-align?)
+t "ulonglong" c-type (>>stack-align?)
+>>
+
+M: linux reserved-area-size 2 cells ;
+
+M: linux lr-save 1 cells ;
+
+M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ;
+
+M: ppc value-structs? f ;
+
+M: ppc dummy-stack-params? f ;
+
+M: ppc dummy-int-params? f ;
+
+M: ppc dummy-fp-params? f ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors system kernel layouts
+alien.c-types cpu.architecture cpu.ppc ;
+IN: cpu.ppc.macosx
+
+<<
+4 "longlong" c-type (>>align)
+4 "ulonglong" c-type (>>align)
+4 "double" c-type (>>align)
+>>
+
+M: macosx reserved-area-size 6 cells ;
+
+M: macosx lr-save 2 cells ;
+
+M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
+
+M: ppc value-structs? t ;
+
+M: ppc dummy-stack-params? t ;
+
+M: ppc dummy-int-params? t ;
+
+M: ppc dummy-fp-params? f ;
--- /dev/null
+unportable
-USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics
-cpu.architecture namespaces alien.c-types kernel system
-combinators ;
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sequences kernel combinators make math
+math.order math.ranges system namespaces locals layouts words
+alien alien.c-types cpu.architecture cpu.ppc.assembler
+compiler.cfg.registers compiler.cfg.instructions
+compiler.constants compiler.codegen compiler.codegen.fixup
+compiler.cfg.intrinsics compiler.cfg.stack-frame ;
+IN: cpu.ppc
+
+! PowerPC register assignments:
+! r2-r27: integer vregs
+! r28: integer scratch
+! r29: data stack
+! r30: retain stack
+! f0-f29: float vregs
+! f30, f31: float scratch
+
+enable-float-intrinsics
+
+<< \ ##integer>float t frame-required? set-word-prop
+\ ##float>integer t frame-required? set-word-prop >>
+
+M: ppc machine-registers
+ {
+ { int-regs T{ range f 2 26 1 } }
+ { double-float-regs T{ range f 0 29 1 } }
+ } ;
+
+: scratch-reg 28 ; inline
+: fp-scratch-reg 30 ; inline
+
+M: ppc two-operand? f ;
+
+M: ppc %load-immediate ( reg n -- ) swap LOAD ;
+
+M:: ppc %load-indirect ( reg obj -- )
+ 0 reg LOAD32
+ obj rc-absolute-ppc-2/2 rel-literal
+ reg reg 0 LWZ ;
+
+: ds-reg 29 ; inline
+: rs-reg 30 ; inline
+
+GENERIC: loc-reg ( loc -- reg )
+
+M: ds-loc loc-reg drop ds-reg ;
+M: rs-loc loc-reg drop rs-reg ;
+
+: loc>operand ( loc -- reg n )
+ [ loc-reg ] [ n>> cells neg ] bi ; inline
+
+M: ppc %peek loc>operand LWZ ;
+M: ppc %replace loc>operand STW ;
+
+: (%inc) ( n reg -- ) dup rot cells ADDI ; inline
+
+M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
+M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
+
+HOOK: reserved-area-size os ( -- n )
+
+! The start of the stack frame contains the size of this frame
+! as well as the currently executing XT
+: factor-area-size ( -- n ) 2 cells ; foldable
+: next-save ( n -- i ) cell - ;
+: xt-save ( n -- i ) 2 cells - ;
+
+! Next, we have the spill area as well as the FFI parameter area.
+! They overlap, since basic blocks with FFI calls will never
+! spill.
+: param@ ( n -- x ) reserved-area-size + ; inline
+
+: param-save-size ( -- n ) 8 cells ; foldable
+
+: local@ ( n -- x )
+ reserved-area-size param-save-size + + ; inline
+
+: spill-integer-base ( -- n )
+ stack-frame get spill-counts>> double-float-regs swap at
+ double-float-regs reg-size * ;
+
+: spill-integer@ ( n -- offset )
+ cells spill-integer-base + param@ ;
+
+: spill-float@ ( n -- offset )
+ double-float-regs reg-size * param@ ;
+
+! Some FP intrinsics need a temporary scratch area in the stack
+! frame, 8 bytes in size
+: scratch@ ( n -- offset )
+ stack-frame get total-size>>
+ factor-area-size -
+ param-save-size -
+ + ;
+
+! Finally we have the linkage area
+HOOK: lr-save os ( -- n )
+
+M: ppc stack-frame-size ( stack-frame -- i )
+ [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+ [ params>> ]
+ [ return>> ]
+ tri + +
+ param-save-size +
+ reserved-area-size +
+ factor-area-size +
+ 4 cells align ;
+
+M: ppc %call ( label -- ) BL ;
+M: ppc %jump-label ( label -- ) B ;
+M: ppc %return ( -- ) BLR ;
+
+M:: ppc %dispatch ( src temp -- )
+ 0 temp LOAD32 rc-absolute-ppc-2/2 rel-here
+ temp temp src ADD
+ temp temp 5 cells LWZ
+ temp MTCTR
+ BCTR ;
+
+M: ppc %dispatch-label ( word -- )
+ 0 , rc-absolute-cell rel-word ;
+
+:: (%slot) ( obj slot tag temp -- reg offset )
+ temp slot obj ADD
+ temp tag neg ; inline
+
+: (%slot-imm) ( obj slot tag -- reg offset )
+ [ cells ] dip - ; inline
+
+M: ppc %slot ( dst obj slot tag temp -- ) (%slot) LWZ ;
+M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ;
+M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
+M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
+
+M:: ppc %string-nth ( dst src index temp -- )
+ [
+ "end" define-label
+ temp src index ADD
+ dst temp string-offset LBZ
+ temp src string-aux-offset LWZ
+ 0 temp \ f tag-number CMPI
+ "end" get BEQ
+ temp temp index ADD
+ temp temp index ADD
+ temp temp byte-array-offset LHZ
+ temp temp 8 SLWI
+ dst dst temp OR
+ "end" resolve-label
+ ] with-scope ;
+
+M: ppc %add ADD ;
+M: ppc %add-imm ADDI ;
+M: ppc %sub swap SUBF ;
+M: ppc %sub-imm SUBI ;
+M: ppc %mul MULLW ;
+M: ppc %mul-imm MULLI ;
+M: ppc %and AND ;
+M: ppc %and-imm ANDI ;
+M: ppc %or OR ;
+M: ppc %or-imm ORI ;
+M: ppc %xor XOR ;
+M: ppc %xor-imm XORI ;
+M: ppc %shl-imm swapd SLWI ;
+M: ppc %shr-imm swapd SRWI ;
+M: ppc %sar-imm SRAWI ;
+M: ppc %not NOT ;
+
+: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
+
+M:: ppc %integer>bignum ( dst src temp -- )
+ [
+ "end" define-label
+ dst 0 >bignum %load-indirect
+ ! Is it zero? Then just go to the end and return this zero
+ 0 src 0 CMPI
+ "end" get BEQ
+ ! Allocate a bignum
+ dst 4 cells bignum temp %allot
+ ! Write length
+ 2 tag-fixnum temp LI
+ temp dst 1 bignum@ STW
+ ! Compute sign
+ temp src MR
+ temp temp cell-bits 1- SRAWI
+ temp temp 1 ANDI
+ ! Store sign
+ temp dst 2 bignum@ STW
+ ! Make negative value positive
+ temp temp temp ADD
+ temp temp NEG
+ temp temp 1 ADDI
+ temp src temp MULLW
+ ! Store the bignum
+ temp dst 3 bignum@ STW
+ "end" resolve-label
+ ] with-scope ;
+
+M:: ppc %bignum>integer ( dst src temp -- )
+ [
+ "end" define-label
+ temp src 1 bignum@ LWZ
+ ! if the length is 1, its just the sign and nothing else,
+ ! so output 0
+ 0 dst LI
+ 0 temp 1 tag-fixnum CMPI
+ "end" get BEQ
+ ! load the value
+ dst src 3 bignum@ LWZ
+ ! load the sign
+ temp src 2 bignum@ LWZ
+ ! branchless arithmetic: we want to turn 0 into 1,
+ ! and 1 into -1
+ temp temp temp ADD
+ temp temp 1 SUBI
+ temp temp NEG
+ ! multiply value by sign
+ dst dst temp MULLW
+ "end" resolve-label
+ ] with-scope ;
+
+M: ppc %add-float FADD ;
+M: ppc %sub-float FSUB ;
+M: ppc %mul-float FMUL ;
+M: ppc %div-float FDIV ;
+
+M:: ppc %integer>float ( dst src -- )
+ HEX: 4330 scratch-reg LIS
+ scratch-reg 1 0 scratch@ STW
+ scratch-reg src MR
+ scratch-reg dup HEX: 8000 XORIS
+ scratch-reg 1 4 scratch@ STW
+ dst 1 0 scratch@ LFD
+ scratch-reg 4503601774854144.0 %load-indirect
+ fp-scratch-reg scratch-reg float-offset LFD
+ dst dst fp-scratch-reg FSUB ;
+
+M:: ppc %float>integer ( dst src -- )
+ fp-scratch-reg src FCTIWZ
+ fp-scratch-reg 1 0 scratch@ STFD
+ dst 1 4 scratch@ LWZ ;
+
+M: ppc %copy ( dst src -- ) MR ;
+
+M: ppc %copy-float ( dst src -- ) FMR ;
+
+M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
+
+M:: ppc %box-float ( dst src temp -- )
+ dst 16 float temp %allot
+ src dst float-offset STFD ;
+
+M:: ppc %unbox-any-c-ptr ( dst src temp -- )
+ [
+ { "is-byte-array" "end" "start" } [ define-label ] each
+ ! Address is computed in dst
+ 0 dst LI
+ ! Load object into scratch-reg
+ scratch-reg src MR
+ ! We come back here with displaced aliens
+ "start" resolve-label
+ ! Is the object f?
+ 0 scratch-reg \ f tag-number CMPI
+ ! If so, done
+ "end" get BEQ
+ ! Is the object an alien?
+ 0 scratch-reg header-offset LWZ
+ 0 0 alien type-number tag-fixnum CMPI
+ "is-byte-array" get BNE
+ ! If so, load the offset
+ 0 scratch-reg alien-offset LWZ
+ ! Add it to address being computed
+ dst dst 0 ADD
+ ! Now recurse on the underlying alien
+ scratch-reg scratch-reg underlying-alien-offset LWZ
+ "start" get B
+ "is-byte-array" resolve-label
+ ! Add byte array address to address being computed
+ dst dst scratch-reg ADD
+ ! Add an offset to start of byte array's data area
+ dst dst byte-array-offset ADDI
+ "end" resolve-label
+ ] with-scope ;
+
+: alien@ ( n -- n' ) cells object tag-number - ;
+
+M:: ppc %box-alien ( dst src temp -- )
+ [
+ "f" define-label
+ dst \ f tag-number %load-immediate
+ 0 src 0 CMPI
+ "f" get BEQ
+ dst 4 cells alien temp %allot
+ ! Store offset
+ src dst 3 alien@ STW
+ ! Store expired slot
+ temp \ f tag-number %load-immediate
+ temp dst 1 alien@ STW
+ ! Store underlying-alien slot
+ temp dst 2 alien@ STW
+ "f" resolve-label
+ ] with-scope ;
+
+M: ppc %alien-unsigned-1 0 LBZ ;
+M: ppc %alien-unsigned-2 0 LHZ ;
+
+M: ppc %alien-signed-1 dupd 0 LBZ dup EXTSB ;
+M: ppc %alien-signed-2 0 LHA ;
+
+M: ppc %alien-cell 0 LWZ ;
+
+M: ppc %alien-float 0 LFS ;
+M: ppc %alien-double 0 LFD ;
+
+M: ppc %set-alien-integer-1 swap 0 STB ;
+M: ppc %set-alien-integer-2 swap 0 STH ;
+
+M: ppc %set-alien-cell swap 0 STW ;
+
+M: ppc %set-alien-float swap 0 STFS ;
+M: ppc %set-alien-double swap 0 STFD ;
+
+: %load-dlsym ( symbol dll register -- )
+ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
+
+: load-zone-ptr ( reg -- )
+ [ "nursery" f ] dip %load-dlsym ;
+
+: load-allot-ptr ( nursery-ptr allot-ptr -- )
+ [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
+
+:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
+ scratch-reg allot-ptr n 8 align ADDI
+ scratch-reg nursery-ptr 4 STW ;
+
+:: store-header ( dst class -- )
+ class type-number tag-fixnum scratch-reg LI
+ scratch-reg dst 0 STW ;
+
+: store-tagged ( dst tag -- )
+ dupd tag-number ORI ;
+
+M:: ppc %allot ( dst size class nursery-ptr -- )
+ nursery-ptr dst load-allot-ptr
+ nursery-ptr dst size inc-allot-ptr
+ dst class store-header
+ dst class store-tagged ;
+
+: %alien-global ( dst name -- )
+ [ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
+
+: load-cards-offset ( dst -- )
+ "cards_offset" %alien-global ;
+
+: load-decks-offset ( dst -- )
+ "decks_offset" %alien-global ;
+
+M:: ppc %write-barrier ( src card# table -- )
+ card-mark scratch-reg LI
+
+ ! Mark the card
+ table load-cards-offset
+ src card# card-bits SRWI
+ table scratch-reg card# STBX
+
+ ! Mark the card deck
+ table load-decks-offset
+ src card# deck-bits SRWI
+ table scratch-reg card# STBX ;
+
+M: ppc %gc
+ "end" define-label
+ 12 load-zone-ptr
+ 11 12 cell LWZ ! nursery.here -> r11
+ 12 12 3 cells LWZ ! nursery.end -> r12
+ 11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
+ 11 0 12 CMP ! is here >= end?
+ "end" get BLE
+ %prepare-alien-invoke
+ "minor_gc" f %alien-invoke
+ "end" resolve-label ;
+
+M: ppc %prologue ( n -- )
+ 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
+ 0 MFLR
+ 1 1 pick neg ADDI
+ 11 1 pick xt-save STW
+ dup 11 LI
+ 11 1 pick next-save STW
+ 0 1 rot lr-save + STW ;
+
+M: ppc %epilogue ( n -- )
+ #! At the end of each word that calls a subroutine, we store
+ #! the previous link register value in r0 by popping it off
+ #! the stack, set the link register to the contents of r0,
+ #! and jump to the link register.
+ 0 1 pick lr-save + LWZ
+ 1 1 rot ADDI
+ 0 MTLR ;
+
+:: (%boolean) ( dst word -- )
+ "end" define-label
+ dst \ f tag-number %load-immediate
+ "end" get word execute
+ dst \ t %load-indirect
+ "end" get resolve-label ; inline
+
+: %boolean ( dst cc -- )
+ negate-cc {
+ { cc< [ \ BLT (%boolean) ] }
+ { cc<= [ \ BLE (%boolean) ] }
+ { cc> [ \ BGT (%boolean) ] }
+ { cc>= [ \ BGE (%boolean) ] }
+ { cc= [ \ BEQ (%boolean) ] }
+ { cc/= [ \ BNE (%boolean) ] }
+ } case ;
+
+: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
+: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline
+: (%compare-float) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
+
+M: ppc %compare (%compare) %boolean ;
+M: ppc %compare-imm (%compare-imm) %boolean ;
+M: ppc %compare-float (%compare-float) %boolean ;
+
+: %branch ( label cc -- )
+ {
+ { cc< [ BLT ] }
+ { cc<= [ BLE ] }
+ { cc> [ BGT ] }
+ { cc>= [ BGE ] }
+ { cc= [ BEQ ] }
+ { cc/= [ BNE ] }
+ } case ;
+
+M: ppc %compare-branch (%compare) %branch ;
+M: ppc %compare-imm-branch (%compare-imm) %branch ;
+M: ppc %compare-float-branch (%compare-float) %branch ;
+
+M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ;
+M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ;
+
+M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ;
+M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ;
+
+M: ppc %loop-entry ;
+
+M: int-regs return-reg drop 3 ;
+M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
+M: float-regs return-reg drop 1 ;
+
+M: int-regs %save-param-reg drop 1 rot local@ STW ;
+M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
+
+GENERIC: STF ( src dst off reg-class -- )
+
+M: single-float-regs STF drop STFS ;
+M: double-float-regs STF drop STFD ;
+
+M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
+
+GENERIC: LF ( dst src off reg-class -- )
+
+M: single-float-regs LF drop LFS ;
+M: double-float-regs LF drop LFD ;
+
+M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
+
+M: stack-params %load-param-reg ( stack reg reg-class -- )
+ drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
+
+: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
+
+M: stack-params %save-param-reg ( stack reg reg-class -- )
+ #! Funky. Read the parameter from the caller's stack frame.
+ #! This word is used in callbacks
+ drop
+ 0 1 rot next-param@ LWZ
+ 0 1 rot local@ STW ;
+
+M: ppc %prepare-unbox ( -- )
+ ! First parameter is top of stack
+ 3 ds-reg 0 LWZ
+ ds-reg dup cell SUBI ;
+
+M: ppc %unbox ( n reg-class func -- )
+ ! Value must be in r3
+ ! Call the unboxer
+ f %alien-invoke
+ ! Store the return value on the C stack
+ over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+
+M: ppc %unbox-long-long ( n func -- )
+ ! Value must be in r3:r4
+ ! Call the unboxer
+ f %alien-invoke
+ ! Store the return value on the C stack
+ [
+ 3 1 pick local@ STW
+ 4 1 rot cell + local@ STW
+ ] when* ;
+
+M: ppc %unbox-large-struct ( n c-type -- )
+ ! Value must be in r3
+ ! Compute destination address and load struct size
+ [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
+ ! Call the function
+ "to_value_struct" f %alien-invoke ;
+
+M: ppc %box ( n reg-class func -- )
+ ! If the source is a stack location, load it into freg #0.
+ ! If the source is f, then we assume the value is already in
+ ! freg #0.
+ >r
+ over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
+ r> f %alien-invoke ;
+
+M: ppc %box-long-long ( n func -- )
+ >r [
+ 3 1 pick local@ LWZ
+ 4 1 rot cell + local@ LWZ
+ ] when* r> f %alien-invoke ;
+
+: struct-return@ ( n -- n )
+ [ stack-frame get params>> ] unless* local@ ;
+
+M: ppc %prepare-box-struct ( -- )
+ #! Compute target address for value struct return
+ 3 1 f struct-return@ ADDI
+ 3 1 0 local@ STW ;
+
+M: ppc %box-large-struct ( n c-type -- )
+ ! If n = f, then we're boxing a returned struct
+ ! Compute destination address and load struct size
+ [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
+ ! Call the function
+ "box_value_struct" f %alien-invoke ;
+
+M: ppc %prepare-alien-invoke
+ #! Save Factor stack pointers in case the C code calls a
+ #! callback which does a GC, which must reliably trace
+ #! all roots.
+ "stack_chain" f 11 %load-dlsym
+ 11 11 0 LWZ
+ 1 11 0 STW
+ ds-reg 11 8 STW
+ rs-reg 11 12 STW ;
+
+M: ppc %alien-invoke ( symbol dll -- )
+ 11 %load-dlsym 11 MTLR BLRL ;
+
+M: ppc %alien-callback ( quot -- )
+ 3 swap %load-indirect "c_to_factor" f %alien-invoke ;
+
+M: ppc %prepare-alien-indirect ( -- )
+ "unbox_alien" f %alien-invoke
+ 13 3 MR ;
+
+M: ppc %alien-indirect ( -- )
+ 13 MTLR BLRL ;
+
+M: ppc %callback-value ( ctype -- )
+ ! Save top of data stack
+ 3 ds-reg 0 LWZ
+ 3 1 0 local@ STW
+ ! Restore data/call/retain stacks
+ "unnest_stacks" f %alien-invoke
+ ! Restore top of data stack
+ 3 1 0 local@ LWZ
+ ! Unbox former top of data stack to return registers
+ unbox-return ;
+
+M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
+
+M: ppc struct-small-enough? ( size -- ? ) drop f ;
+
+M: ppc %box-small-struct
+ drop "No small structs" throw ;
+
+M: ppc %unbox-small-struct
+ drop "No small structs" throw ;
+
+USE: vocabs.loader
{
- { [ os macosx? ] [
- 4 "longlong" c-type (>>align)
- 4 "ulonglong" c-type (>>align)
- 4 "double" c-type (>>align)
- ] }
- { [ os linux? ] [
- t "longlong" c-type (>>stack-align?)
- t "ulonglong" c-type (>>stack-align?)
- ] }
+ { [ os macosx? ] [ "cpu.ppc.macosx" require ] }
+ { [ os linux? ] [ "cpu.ppc.linux" require ] }
} cond
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types arrays cpu.x86.assembler
-cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
-cpu.architecture kernel kernel.private math namespaces sequences
-stack-checker.known-words compiler.generator.registers
-compiler.generator.fixup compiler.generator system layouts
-combinators command-line compiler compiler.units io
-vocabs.loader accessors init ;
+USING: locals alien.c-types alien.syntax arrays kernel
+math namespaces sequences system layouts io vocabs.loader
+accessors init combinators command-line cpu.x86.assembler
+cpu.x86 cpu.architecture compiler compiler.units
+compiler.constants compiler.alien compiler.codegen
+compiler.codegen.fixup compiler.cfg.instructions
+compiler.cfg.builder compiler.cfg.intrinsics ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
! this on all platforms, sacrificing some stack space for
! code simplicity.
+M: x86.32 machine-registers
+ {
+ { int-regs { EAX ECX EDX EBP EBX } }
+ { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
+ } ;
+
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
-M: temp-reg v>operand drop EBX ;
+M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
-M: int-regs vregs drop { EAX ECX EDX EBP } ;
M: int-regs push-return-reg return-reg PUSH ;
M: int-regs load-return-reg
[ stack@ ] [ return-reg ] bi* MOV ;
M: float-regs param-regs drop { } ;
-M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
[ [ align-sub ] [ call ] bi* ]
[ [ align-add ] [ drop ] bi* ] 2bi ; inline
-M: x86.32 fixnum>slot@ 1 SHR ;
+M: x86.32 rel-literal-x86 rc-absolute-cell rel-literal ;
-M: x86.32 prepare-division CDQ ;
-
-M: x86.32 load-indirect
- 0 [] MOV rc-absolute-cell rel-literal ;
+M: x86.32 %prologue ( n -- )
+ dup PUSH
+ 0 PUSH rc-absolute-cell rel-this
+ stack-reg swap 3 cells - SUB ;
M: object %load-param-reg 3drop ;
M: x86.32 %alien-callback ( quot -- )
4 [
- EAX load-indirect
+ EAX swap %load-indirect
EAX PUSH
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
! Unbox EAX
unbox-return ;
-M: x86.32 %cleanup ( alien-node -- )
+M: x86.32 %cleanup ( params -- )
#! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue.
[ drop ]
} cond ;
-M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
+M: x86.32 %callback-return ( n -- )
+ #! a) If the callback is stdcall, we have to clean up the
+ #! caller's stack frame.
+ #! b) If the callback is returning a large struct, we have
+ #! to fix ESP.
+ {
+ { [ dup abi>> "stdcall" = ] [
+ <alien-stack-frame>
+ [ params>> ] [ return>> ] bi +
+ ] }
+ { [ dup return>> large-struct? ] [ drop 4 ] }
+ [ drop 0 ]
+ } cond RET ;
+
+M: x86.32 dummy-stack-params? f ;
+
+M: x86.32 dummy-int-params? f ;
+
+M: x86.32 dummy-fp-params? f ;
os windows? [
cell "longlong" c-type (>>align)
4 "double" c-type (>>align)
] unless
-: (sse2?) ( -- ? ) "Intrinsic" throw ;
+FUNCTION: bool check_sse2 ( ) ;
-<<
-
-\ (sse2?) [
- { EAX EBX ECX EDX } [ PUSH ] each
- EAX 1 MOV
- CPUID
- EDX 26 SHR
- EDX 1 AND
- { EAX EBX ECX EDX } [ POP ] each
- JE
-] { } define-if-intrinsic
-
-\ (sse2?) { } { object } define-primitive
-
->>
-
-: sse2? ( -- ? ) (sse2?) ;
+: sse2? ( -- ? )
+ check_sse2 ;
"-no-sse2" cli-args member? [
+ [ optimized-recompile-hook ] recompile-hook
+ [ { check_sse2 } compile ] with-variable
+
"Checking if your CPU supports SSE2..." print flush
- [ optimized-recompile-hook ] recompile-hook [
- [ sse2? ] compile-call
- ] with-variable
- [
+ sse2? [
" - yes" print
- "cpu.x86.sse2" require
+ enable-float-intrinsics
[
sse2? [
"This image was built to use SSE2, which your CPU does not support." print
1 exit
] unless
] "cpu.x86" add-init-hook
- ] [
- " - no" print
- ] if
+ ] [ " - no" print ] if
] unless
4 \ cell set
+: stack-frame-size ( -- n ) 4 bootstrap-cells ;
+: shift-arg ( -- reg ) ECX ;
+: div-arg ( -- reg ) EAX ;
+: mod-arg ( -- reg ) EDX ;
: arg0 ( -- reg ) EAX ;
: arg1 ( -- reg ) EDX ;
: temp-reg ( -- reg ) EBX ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays cpu.x86.assembler
-cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
-cpu.x86.allot cpu.architecture kernel kernel.private math
-namespaces make sequences compiler.generator
-compiler.generator.registers compiler.generator.fixup system
-layouts alien alien.accessors alien.structs slots splitting
-assocs combinators ;
+USING: accessors arrays kernel math namespaces make sequences
+system layouts alien alien.c-types alien.accessors alien.structs
+slots splitting assocs combinators cpu.x86.assembler
+cpu.x86 cpu.architecture compiler.constants
+compiler.codegen compiler.codegen.fixup
+compiler.cfg.instructions compiler.cfg.builder
+compiler.cfg.intrinsics ;
IN: cpu.x86.64
+M: x86.64 machine-registers
+ {
+ { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
+ { double-float-regs {
+ XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
+ XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
+ } }
+ } ;
+
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
-M: temp-reg v>operand drop RBX ;
+: param-reg-1 int-regs param-regs first ; inline
+: param-reg-2 int-regs param-regs second ; inline
+: param-reg-3 int-regs param-regs third ; inline
M: int-regs return-reg drop RAX ;
-M: int-regs vregs drop { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } ;
-M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
-
M: float-regs return-reg drop XMM0 ;
-M: float-regs vregs
- drop {
- XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
- XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
- } ;
-
-M: float-regs param-regs
- drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-
-M: x86.64 fixnum>slot@ drop ;
-
-M: x86.64 prepare-division CQO ;
+M: x86.64 rel-literal-x86 rc-relative rel-literal ;
-M: x86.64 load-indirect ( literal reg -- )
- 0 [] MOV rc-relative rel-literal ;
+M: x86.64 %prologue ( n -- )
+ temp-reg-1 0 MOV rc-absolute-cell rel-this
+ dup PUSH
+ temp-reg-1 PUSH
+ stack-reg swap 3 cells - SUB ;
M: stack-params %load-param-reg
drop
- >r R11 swap stack@ MOV
- r> stack@ R11 MOV ;
+ >r R11 swap param@ MOV
+ r> param@ R11 MOV ;
M: stack-params %save-param-reg
drop
R11 swap next-stack@ MOV
- stack@ R11 MOV ;
+ param@ R11 MOV ;
: with-return-regs ( quot -- )
[
call
] with-scope ; inline
-! The ABI for passing structs by value is pretty messed up
-<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>reg-class) >>
-
-: struct-types&offset ( struct-type -- pairs )
- fields>> [
- [ type>> ] [ offset>> ] bi 2array
- ] map ;
-
-: split-struct ( pairs -- seq )
- [
- [ 8 mod zero? [ t , ] when , ] assoc-each
- ] { } make { t } split harvest ;
-
-: flatten-small-struct ( c-type -- seq )
- struct-types&offset split-struct [
- [ c-type c-type-reg-class ] map
- int-regs swap member? "void*" "double" ? c-type
- ] map ;
-
-: flatten-large-struct ( c-type -- seq )
- heap-size cell align
- cell /i "__stack_value" c-type <repetition> ;
-
-M: struct-type flatten-value-type ( type -- seq )
- dup heap-size 16 > [
- flatten-large-struct
- ] [
- flatten-small-struct
- ] if ;
-
M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack
- RDI R14 [] MOV
+ param-reg-1 R14 [] MOV
R14 cell SUB ;
M: x86.64 %unbox ( n reg-class func -- )
int-regs swap %unbox ;
: %unbox-struct-field ( c-type i -- )
- ! Alien must be in RDI.
- RDI swap cells [+] swap reg-class>> {
+ ! Alien must be in param-reg-1.
+ R11 swap cells [+] swap reg-class>> {
{ int-regs [ int-regs get pop swap MOV ] }
{ double-float-regs [ float-regs get pop swap MOVSD ] }
} case ;
M: x86.64 %unbox-small-struct ( c-type -- )
- ! Alien must be in RDI.
+ ! Alien must be in param-reg-1.
"alien_offset" f %alien-invoke
- ! Move alien_offset() return value to RDI so that we don't
+ ! Move alien_offset() return value to R11 so that we don't
! clobber it.
- RDI RAX MOV
+ R11 RAX MOV
[
- flatten-small-struct [ %unbox-struct-field ] each-index
+ flatten-value-type [ %unbox-struct-field ] each-index
] with-return-regs ;
M: x86.64 %unbox-large-struct ( n c-type -- )
- ! Source is in RDI
+ ! Source is in param-reg-1
heap-size
! Load destination address
- RSI rot stack@ LEA
+ param-reg-2 rot param@ LEA
! Load structure size
- RDX swap MOV
+ param-reg-3 swap MOV
! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- )
int-regs swap %box ;
-M: x86.64 struct-small-enough? ( size -- ? )
- heap-size 2 cells <= ;
-
-: box-struct-field@ ( i -- operand ) 1+ cells stack@ ;
+: box-struct-field@ ( i -- operand ) 1+ cells param@ ;
: %box-struct-field ( c-type i -- )
box-struct-field@ swap reg-class>> {
M: x86.64 %box-small-struct ( c-type -- )
#! Box a <= 16-byte struct.
[
- [ flatten-small-struct [ %box-struct-field ] each-index ]
- [ RDX swap heap-size MOV ] bi
- RDI 0 box-struct-field@ MOV
- RSI 1 box-struct-field@ MOV
+ [ flatten-value-type [ %box-struct-field ] each-index ]
+ [ param-reg-3 swap heap-size MOV ] bi
+ param-reg-1 0 box-struct-field@ MOV
+ param-reg-2 1 box-struct-field@ MOV
"box_small_struct" f %alien-invoke
] with-return-regs ;
: struct-return@ ( n -- operand )
- [ stack-frame get params>> ] unless* stack@ ;
+ [ stack-frame get params>> ] unless* param@ ;
M: x86.64 %box-large-struct ( n c-type -- )
! Struct size is parameter 2
- RSI swap heap-size MOV
+ param-reg-2 swap heap-size MOV
! Compute destination address
- RDI swap struct-return@ LEA
+ param-reg-1 swap struct-return@ LEA
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ;
! Compute target address for value struct return
RAX f struct-return@ LEA
! Store it as the first parameter
- 0 stack@ RAX MOV ;
+ 0 param@ RAX MOV ;
M: x86.64 %prepare-var-args RAX RAX XOR ;
RBP CALL ;
M: x86.64 %alien-callback ( quot -- )
- RDI load-indirect "c_to_factor" f %alien-invoke ;
+ param-reg-1 swap %load-indirect
+ "c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
! Save top of data stack
RSP 8 SUB
- RDI PUSH
+ param-reg-1 PUSH
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
- ! Put former top of data stack in RDI
- RDI POP
+ ! Put former top of data stack in param-reg-1
+ param-reg-1 POP
RSP 8 ADD
! Unbox former top of data stack to return registers
unbox-return ;
-M: x86.64 %cleanup ( alien-node -- ) drop ;
-
-M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
+! The result of reading 4 bytes from memory is a fixnum on
+! x86-64.
+enable-alien-4-intrinsics
-USE: cpu.x86.intrinsics
+! SSE2 is always available on x86-64.
+enable-float-intrinsics
-! On 64-bit systems, the result of reading 4 bytes from memory
-! is a fixnum.
-\ alien-unsigned-4 small-reg-32 define-unsigned-getter
-\ set-alien-unsigned-4 small-reg-32 define-setter
+USE: vocabs.loader
-\ alien-signed-4 small-reg-32 define-signed-getter
-\ set-alien-signed-4 small-reg-32 define-setter
+{
+ { [ os unix? ] [ "cpu.x86.64.unix" require ] }
+ { [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
+} cond
8 \ cell set
-: arg0 ( -- reg ) RDI ;
-: arg1 ( -- reg ) RSI ;
+: shift-arg ( -- reg ) RCX ;
+: div-arg ( -- reg ) RAX ;
+: mod-arg ( -- reg ) RDX ;
: temp-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private kernel namespaces system
+cpu.x86.assembler layouts vocabs parser ;
+IN: bootstrap.x86
+
+: stack-frame-size ( -- n ) 4 bootstrap-cells ;
+: arg0 ( -- reg ) RDI ;
+: arg1 ( -- reg ) RSI ;
+
+<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
+call
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays sequences math splitting make assocs
+kernel layouts system alien.c-types alien.structs
+cpu.architecture cpu.x86.assembler cpu.x86
+compiler.codegen compiler.cfg.registers ;
+IN: cpu.x86.64.unix
+
+M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
+
+M: float-regs param-regs
+ drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+
+M: x86.64 reserved-area-size 0 ;
+
+! The ABI for passing structs by value is pretty messed up
+<< "void*" c-type clone "__stack_value" define-primitive-type
+stack-params "__stack_value" c-type (>>reg-class) >>
+
+: struct-types&offset ( struct-type -- pairs )
+ fields>> [
+ [ type>> ] [ offset>> ] bi 2array
+ ] map ;
+
+: split-struct ( pairs -- seq )
+ [
+ [ 8 mod zero? [ t , ] when , ] assoc-each
+ ] { } make { t } split harvest ;
+
+: flatten-small-struct ( c-type -- seq )
+ struct-types&offset split-struct [
+ [ c-type c-type-reg-class ] map
+ int-regs swap member? "void*" "double" ? c-type
+ ] map ;
+
+: flatten-large-struct ( c-type -- seq )
+ heap-size cell align
+ cell /i "__stack_value" c-type <repetition> ;
+
+M: struct-type flatten-value-type ( type -- seq )
+ dup heap-size 16 > [
+ flatten-large-struct
+ ] [
+ flatten-small-struct
+ ] if ;
+
+M: x86.64 struct-small-enough? ( size -- ? )
+ heap-size 2 cells <= ;
+
+M: x86.64 dummy-stack-params? f ;
+
+M: x86.64 dummy-int-params? f ;
+
+M: x86.64 dummy-fp-params? f ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private kernel namespaces system
+cpu.x86.assembler layouts vocabs parser ;
+IN: bootstrap.x86
+
+: stack-frame-size ( -- n ) 8 bootstrap-cells ;
+: arg0 ( -- reg ) RCX ;
+: arg1 ( -- reg ) RDX ;
+
+<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
+call
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel layouts system math alien.c-types
+compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
+IN: cpu.x86.64.winnt
+
+M: int-regs param-regs drop { RCX RDX R8 R9 } ;
+
+M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
+
+M: x86.64 reserved-area-size 4 cells ;
+
+M: x86.64 struct-small-enough? ( size -- ? )
+ heap-size cell <= ;
+
+M: x86.64 dummy-stack-params? f ;
+
+M: x86.64 dummy-int-params? t ;
+
+M: x86.64 dummy-fp-params? t ;
+
+<<
+"longlong" "ptrdiff_t" typedef
+"int" "long" typedef
+"uint" "ulong" typedef
+>>
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel cpu.architecture cpu.x86.assembler
-cpu.x86.architecture kernel.private namespaces math sequences
-generic arrays compiler.generator compiler.generator.fixup
-compiler.generator.registers system layouts alien ;
-IN: cpu.x86.allot
-
-: allot-reg ( -- reg )
- #! We temporarily use the datastack register, since it won't
- #! be accessed inside the quotation given to %allot in any
- #! case.
- ds-reg ;
-
-: (object@) ( n -- operand ) allot-reg swap [+] ;
-
-: object@ ( n -- operand ) cells (object@) ;
-
-: load-zone-ptr ( reg -- )
- #! Load pointer to start of zone array
- 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
-
-: load-allot-ptr ( -- )
- allot-reg load-zone-ptr
- allot-reg PUSH
- allot-reg dup cell [+] MOV ;
-
-: inc-allot-ptr ( n -- )
- allot-reg POP
- allot-reg cell [+] swap 8 align ADD ;
-
-M: x86 %gc ( -- )
- "end" define-label
- temp-reg-1 load-zone-ptr
- temp-reg-2 temp-reg-1 cell [+] MOV
- temp-reg-2 1024 ADD
- temp-reg-1 temp-reg-1 3 cells [+] MOV
- temp-reg-2 temp-reg-1 CMP
- "end" get JLE
- 0 frame-required
- %prepare-alien-invoke
- "minor_gc" f %alien-invoke
- "end" resolve-label ;
-
-: store-header ( header -- )
- 0 object@ swap type-number tag-fixnum MOV ;
-
-: %allot ( header size quot -- )
- allot-reg PUSH
- swap >r >r
- load-allot-ptr
- store-header
- r> call
- r> inc-allot-ptr
- allot-reg POP ; inline
-
-: %store-tagged ( reg tag -- )
- >r dup fresh-object v>operand r>
- allot-reg swap tag-number OR
- allot-reg MOV ;
-
-M: x86 %box-float ( dst src -- )
- #! Only called by pentium4 backend, uses SSE2 instruction
- #! dest is a loc or a vreg
- float 16 [
- 8 (object@) swap v>operand MOVSD
- float %store-tagged
- ] %allot ;
-
-: %allot-bignum-signed-1 ( outreg inreg -- )
- #! on entry, inreg is a signed 32-bit quantity
- #! exits with tagged ptr to bignum in outreg
- #! 1 cell header, 1 cell length, 1 cell sign, + digits
- #! length is the # of digits + sign
- [
- { "end" "nonzero" "positive" "store" }
- [ define-label ] each
- dup v>operand 0 CMP ! is it zero?
- "nonzero" get JNE
- 0 >bignum pick load-literal ! this is our result
- "end" get JMP
- "nonzero" resolve-label
- bignum 4 cells [
- ! Write length
- 1 object@ 2 v>operand MOV
- ! Test sign
- dup v>operand 0 CMP
- "positive" get JGE
- 2 object@ 1 MOV ! negative sign
- dup v>operand NEG
- "store" get JMP
- "positive" resolve-label
- 2 object@ 0 MOV ! positive sign
- "store" resolve-label
- 3 object@ swap v>operand MOV
- ! Store tagged ptr in reg
- bignum %store-tagged
- ] %allot
- "end" resolve-label
- ] with-scope ;
-
-M: x86 %box-alien ( dst src -- )
- [
- { "end" "f" } [ define-label ] each
- dup v>operand 0 CMP
- "f" get JE
- alien 4 cells [
- 1 object@ f v>operand MOV
- 2 object@ f v>operand MOV
- ! Store src in alien-offset slot
- 3 object@ swap v>operand MOV
- ! Store tagged ptr in dst
- dup object %store-tagged
- ] %allot
- "end" get JMP
- "f" resolve-label
- f [ v>operand ] bi@ MOV
- "end" resolve-label
- ] with-scope ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays cpu.x86.assembler
-cpu.x86.assembler.private cpu.architecture kernel kernel.private
-math memory namespaces make sequences words compiler.generator
-compiler.generator.registers compiler.generator.fixup system
-layouts combinators compiler.constants math.order ;
-IN: cpu.x86.architecture
-
-HOOK: ds-reg cpu ( -- reg )
-HOOK: rs-reg cpu ( -- reg )
-HOOK: stack-reg cpu ( -- reg )
-
-: stack@ ( n -- op ) stack-reg swap [+] ;
-
-: next-stack@ ( n -- operand )
- #! nth parameter from the next stack frame. Used to box
- #! input values to callbacks; the callback has its own
- #! stack frame set up, and we want to read the frame
- #! set up by the caller.
- stack-frame get total-size>> + stack@ ;
-
-: reg-stack ( n reg -- op ) swap cells neg [+] ;
-
-M: ds-loc v>operand n>> ds-reg reg-stack ;
-M: rs-loc v>operand n>> rs-reg reg-stack ;
-
-M: int-regs %save-param-reg drop >r stack@ r> MOV ;
-M: int-regs %load-param-reg drop swap stack@ MOV ;
-
-GENERIC: MOVSS/D ( dst src reg-class -- )
-
-M: single-float-regs MOVSS/D drop MOVSS ;
-
-M: double-float-regs MOVSS/D drop MOVSD ;
-
-M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
-M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
-
-GENERIC: push-return-reg ( reg-class -- )
-GENERIC: load-return-reg ( n reg-class -- )
-GENERIC: store-return-reg ( n reg-class -- )
-
-! Only used by inline allocation
-HOOK: temp-reg-1 cpu ( -- reg )
-HOOK: temp-reg-2 cpu ( -- reg )
-
-HOOK: fixnum>slot@ cpu ( op -- )
-
-HOOK: prepare-division cpu ( -- )
-
-M: immediate load-literal v>operand swap v>operand MOV ;
-
-: align-stack ( n -- n' )
- os macosx? cpu x86.64? or [ 16 align ] when ;
-
-M: x86 stack-frame-size ( n -- i )
- 3 cells + align-stack ;
-
-M: x86 %save-word-xt ( -- )
- temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
-
-: decr-stack-reg ( n -- )
- dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
-
-M: x86 %prologue ( n -- )
- dup PUSH
- temp-reg v>operand PUSH
- 3 cells - decr-stack-reg ;
-
-: incr-stack-reg ( n -- )
- dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
-
-M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
-
-HOOK: %alien-global cpu ( symbol dll register -- )
-
-M: x86 %prepare-alien-invoke
- #! Save Factor stack pointers in case the C code calls a
- #! callback which does a GC, which must reliably trace
- #! all roots.
- "stack_chain" f temp-reg v>operand %alien-global
- temp-reg v>operand [] stack-reg MOV
- temp-reg v>operand [] cell SUB
- temp-reg v>operand 2 cells [+] ds-reg MOV
- temp-reg v>operand 3 cells [+] rs-reg MOV ;
-
-M: x86 %call ( label -- ) CALL ;
-
-M: x86 %jump-label ( label -- ) JMP ;
-
-M: x86 %jump-f ( label -- )
- "flag" operand f v>operand CMP JE ;
-
-: code-alignment ( -- n )
- building get length dup cell align swap - ;
-
-: align-code ( n -- )
- 0 <repetition> % ;
-
-M: x86 %dispatch ( -- )
- [
- %epilogue-later
- ! Load jump table base. We use a temporary register
- ! since on AMD64 we have to load a 64-bit immediate. On
- ! x86, this is redundant.
- ! Untag and multiply to get a jump table offset
- "n" operand fixnum>slot@
- ! Add jump table base
- "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
- "n" operand "offset" operand ADD
- "n" operand HEX: 7f [+] JMP
- ! Fix up the displacement above
- code-alignment dup bootstrap-cell 8 = 15 9 ? +
- building get dup pop* push
- align-code
- ] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "offset" } } }
- { +clobber+ { "n" } }
- } with-template ;
-
-M: x86 %dispatch-label ( word -- )
- 0 cell, rc-absolute-cell rel-word ;
-
-M: x86 %unbox-float ( dst src -- )
- [ v>operand ] bi@ float-offset [+] MOVSD ;
-
-M: x86 %peek [ v>operand ] bi@ MOV ;
-
-M: x86 %replace swap %peek ;
-
-: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
-
-M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
-
-M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
-
-M: x86 fp-shadows-int? ( -- ? ) f ;
-
-M: x86 value-structs? t ;
-
-M: x86 small-enough? ( n -- ? )
- HEX: -80000000 HEX: 7fffffff between? ;
-
-: %untag ( reg -- ) tag-mask get bitnot AND ;
-
-: %untag-fixnum ( reg -- ) tag-bits get SAR ;
-
-: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-
-M: x86 %return ( -- ) 0 %unwind ;
-
-! Alien intrinsics
-M: x86 %unbox-byte-array ( dst src -- )
- [ v>operand ] bi@ byte-array-offset [+] LEA ;
-
-M: x86 %unbox-alien ( dst src -- )
- [ v>operand ] bi@ alien-offset [+] MOV ;
-
-M: x86 %unbox-f ( dst src -- )
- drop v>operand 0 MOV ;
-
-M: x86 %unbox-any-c-ptr ( dst src -- )
- { "is-byte-array" "end" "start" } [ define-label ] each
- ! Address is computed in ds-reg
- ds-reg PUSH
- ds-reg 0 MOV
- ! Object is stored in ds-reg
- rs-reg PUSH
- rs-reg swap v>operand MOV
- ! We come back here with displaced aliens
- "start" resolve-label
- ! Is the object f?
- rs-reg f v>operand CMP
- "end" get JE
- ! Is the object an alien?
- rs-reg header-offset [+] alien type-number tag-fixnum CMP
- "is-byte-array" get JNE
- ! If so, load the offset and add it to the address
- ds-reg rs-reg alien-offset [+] ADD
- ! Now recurse on the underlying alien
- rs-reg rs-reg underlying-alien-offset [+] MOV
- "start" get JMP
- "is-byte-array" resolve-label
- ! Add byte array address to address being computed
- ds-reg rs-reg ADD
- ! Add an offset to start of byte array's data
- ds-reg byte-array-offset ADD
- "end" resolve-label
- ! Done, store address in destination register
- v>operand ds-reg MOV
- ! Restore rs-reg
- rs-reg POP
- ! Restore ds-reg
- ds-reg POP ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-unportable
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail
+
+[ { HEX: 48 HEX: d3 HEX: e0 } ] [ [ RAX CL SHL ] { } make ] unit-test
+[ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
+[ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
+[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays compiler.generator.fixup io.binary kernel
-combinators kernel.private math namespaces make sequences
-words system layouts math.order accessors
-cpu.x86.assembler.syntax ;
+USING: arrays cpu.architecture compiler.constants
+compiler.codegen.fixup io.binary kernel combinators
+kernel.private math namespaces make sequences words system
+layouts math.order accessors cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
M: operand CMP OCT: 070 2-operand ;
+: XCHG ( dst src -- ) OCT: 207 2-operand ;
+
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
: CDQ ( -- ) HEX: 99 , ;
: CQO ( -- ) HEX: 48 , CDQ ;
-: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
-: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
-: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
-: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
-: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
-: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
-: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
+: (SHIFT) ( dst src op -- )
+ over CL eq? [
+ nip t HEX: d3 3array 1-operand
+ ] [
+ swapd t HEX: c0 3array immediate-1
+ ] if ; inline
+
+: ROL ( dst n -- ) BIN: 000 (SHIFT) ;
+: ROR ( dst n -- ) BIN: 001 (SHIFT) ;
+: RCL ( dst n -- ) BIN: 010 (SHIFT) ;
+: RCR ( dst n -- ) BIN: 011 (SHIFT) ;
+: SHL ( dst n -- ) BIN: 100 (SHIFT) ;
+: SHR ( dst n -- ) BIN: 101 (SHIFT) ;
+: SAR ( dst n -- ) BIN: 111 (SHIFT) ;
GENERIC: IMUL2 ( dst src -- )
M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
swapd
(2-operand) ;
+: MOVZX ( dst src -- )
+ OCT: 266 extended-opcode
+ over register-16? [ BIN: 1 opcode-or ] when
+ swapd
+ (2-operand) ;
+
! Conditional move
: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
: CPUID ( -- ) HEX: a2 extended-opcode, ;
+! Misc
+
+: NOP ( -- ) HEX: 90 , ;
+
! x87 Floating Point Unit
: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences lexer parser ;
+USING: kernel words sequences lexer parser fry ;
IN: cpu.x86.assembler.syntax
: define-register ( name num size -- )
"register-size" set-word-prop ;
: define-registers ( names size -- )
- >r dup length r> [ define-register ] curry 2each ;
+ '[ _ define-register ] each-index ;
: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.x86.assembler layouts compiler.units math
-math.private compiler.generator.fixup compiler.constants vocabs
-slots.private words words.private ;
+math.private compiler.constants vocabs slots.private words
+words.private locals.backend ;
IN: bootstrap.x86
big-endian off
1 jit-code-format set
-: stack-frame-size ( -- n ) 4 bootstrap-cells ;
-
[
! Load word
temp-reg 0 MOV
temp-reg 0 MOV ! load XT
stack-frame-size PUSH ! save stack frame size
temp-reg PUSH ! push XT
- arg1 PUSH ! alignment
+ stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment
] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
[
: jit-math ( insn -- )
arg0 ds-reg [] MOV ! load second input
ds-reg bootstrap-cell SUB ! pop stack
- arg1 ds-reg [] MOV ! load first input
- [ arg1 arg0 ] dip execute ! compute result
- ds-reg [] arg1 MOV ! push result
+ [ ds-reg [] arg0 ] dip execute ! compute result
;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
[
- arg0 ds-reg [] MOV ! load input input
- arg0 NOT ! complement
- arg0 tag-mask get XOR ! clear tag bits
- ds-reg [] arg0 MOV ! save
+ ds-reg [] NOT ! complement
+ ds-reg [] tag-mask get XOR ! clear tag bits
] f f f \ fixnum-bitnot define-sub-primitive
+[
+ shift-arg ds-reg [] MOV ! load shift count
+ shift-arg tag-bits get SAR ! untag shift count
+ ds-reg bootstrap-cell SUB ! adjust stack pointer
+ temp-reg ds-reg [] MOV ! load value
+ arg1 temp-reg MOV ! make a copy
+ arg1 CL SHL ! compute positive shift value in arg1
+ shift-arg NEG ! compute negative shift value in arg0
+ temp-reg CL SAR
+ temp-reg tag-mask get bitnot AND
+ shift-arg 0 CMP ! if shift count was negative, move arg0 to arg1
+ arg1 temp-reg CMOVGE
+ ds-reg [] arg1 MOV ! push to stack
+] f f f \ fixnum-shift-fast define-sub-primitive
+
+[
+ temp-reg ds-reg [] MOV ! load second parameter
+ ds-reg bootstrap-cell SUB ! adjust stack pointer
+ div-arg ds-reg [] MOV ! load first parameter
+ mod-arg div-arg MOV ! make a copy
+ mod-arg bootstrap-cell-bits 1- SAR ! sign-extend
+ temp-reg IDIV ! divide
+ ds-reg [] mod-arg MOV ! push to stack
+] f f f \ fixnum-mod define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV ! load local number
+ fixnum>slot@ ! turn local number into offset
+ arg1 bootstrap-cell MOV ! load base
+ arg1 arg0 SUB ! turn it into a stack offset
+ arg0 rs-reg arg1 [+] MOV ! load local value
+ ds-reg [] arg0 MOV ! push to stack
+] f f f \ get-local define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV ! load local count
+ ds-reg bootstrap-cell SUB ! adjust stack pointer
+ fixnum>slot@ ! turn local number into offset
+ rs-reg arg0 SUB ! decrement retain stack pointer
+] f f f \ drop-locals define-sub-primitive
+
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors arrays cpu.x86.assembler
-cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
-kernel.private math math.private namespaces quotations sequences
-words generic byte-arrays hashtables hashtables.private
-sequences.private sbufs sbufs.private
-vectors vectors.private layouts system strings.private
-slots.private
-compiler.constants
-compiler.intrinsics
-compiler.generator
-compiler.generator.fixup
-compiler.generator.registers ;
-IN: cpu.x86.intrinsics
-
-! Type checks
-\ tag [
- "in" operand tag-mask get AND
- "in" operand %tag-fixnum
-] H{
- { +input+ { { f "in" } } }
- { +output+ { "in" } }
-} define-intrinsic
-
-! Slots
-: %slot-literal-known-tag ( -- op )
- "obj" operand
- "n" get cells
- "obj" get operand-tag - [+] ;
-
-: %slot-literal-any-tag ( -- op )
- "obj" operand %untag
- "obj" operand "n" get cells [+] ;
-
-: %slot-any ( -- op )
- "obj" operand %untag
- "n" operand fixnum>slot@
- "obj" operand "n" operand [+] ;
-
-\ slot {
- ! Slot number is literal and the tag is known
- {
- [ "val" operand %slot-literal-known-tag MOV ] H{
- { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "val" } } }
- { +output+ { "val" } }
- }
- }
- ! Slot number is literal
- {
- [ "obj" operand %slot-literal-any-tag MOV ] H{
- { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
- { +output+ { "obj" } }
- }
- }
- ! Slot number in a register
- {
- [ "obj" operand %slot-any MOV ] H{
- { +input+ { { f "obj" } { f "n" } } }
- { +output+ { "obj" } }
- { +clobber+ { "n" } }
- }
- }
-} define-intrinsics
-
-: generate-write-barrier ( -- )
- #! Mark the card pointed to by vreg.
- "val" get operand-immediate? "obj" get fresh-object? or [
- ! Mark the card
- "obj" operand card-bits SHR
- "cards_offset" f temp-reg v>operand %alien-global
- temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
-
- ! Mark the card deck
- "obj" operand deck-bits card-bits - SHR
- "decks_offset" f temp-reg v>operand %alien-global
- temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
- ] unless ;
-
-\ set-slot {
- ! Slot number is literal and the tag is known
- {
- [ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] H{
- { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
- { +clobber+ { "obj" } }
- }
- }
- ! Slot number is literal
- {
- [ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] H{
- { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
- { +clobber+ { "obj" } }
- }
- }
- ! Slot number in a register
- {
- [ %slot-any "val" operand MOV generate-write-barrier ] H{
- { +input+ { { f "val" } { f "obj" } { f "n" } } }
- { +clobber+ { "obj" "n" } }
- }
- }
-} define-intrinsics
-
-! Sometimes, we need to do stuff with operands which are
-! less than the word size. Instead of teaching the register
-! allocator about the different sized registers, with all
-! the complexity this entails, we just push/pop a register
-! which is guaranteed to be unused (the tempreg)
-: small-reg cell 8 = RBX EBX ? ; inline
-: small-reg-8 BL ; inline
-: small-reg-16 BX ; inline
-: small-reg-32 EBX ; inline
-
-! Fixnums
-: fixnum-op ( op hash -- pair )
- >r [ "x" operand "y" operand ] swap suffix r> 2array ;
-
-: fixnum-value-op ( op -- pair )
- H{
- { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
- { +output+ { "x" } }
- } fixnum-op ;
-
-: fixnum-register-op ( op -- pair )
- H{
- { +input+ { { f "x" } { f "y" } } }
- { +output+ { "x" } }
- } fixnum-op ;
-
-: define-fixnum-op ( word op -- )
- [ fixnum-value-op ] keep fixnum-register-op
- 2array define-intrinsics ;
-
-{
- { fixnum+fast ADD }
- { fixnum-fast SUB }
- { fixnum-bitand AND }
- { fixnum-bitor OR }
- { fixnum-bitxor XOR }
-} [
- first2 define-fixnum-op
-] each
-
-\ fixnum-bitnot [
- "x" operand NOT
- "x" operand tag-mask get XOR
-] H{
- { +input+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-\ fixnum*fast {
- {
- [
- "x" operand "y" get IMUL2
- ] H{
- { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
- { +output+ { "x" } }
- }
- } {
- [
- "out" operand "x" operand MOV
- "out" operand %untag-fixnum
- "y" operand "out" operand IMUL2
- ] H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- }
- }
-} define-intrinsics
-
-: %untag-fixnums ( seq -- )
- [ %untag-fixnum ] unique-operands ;
-
-\ fixnum-shift-fast [
- "x" operand "y" get
- dup 0 < [ neg SAR ] [ SHL ] if
- ! Mask off low bits
- "x" operand %untag
-] H{
- { +input+ { { f "x" } { [ ] "y" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-: overflow-check ( word -- )
- "end" define-label
- "z" operand "x" operand MOV
- "z" operand "y" operand pick execute
- ! If the previous arithmetic operation overflowed, then we
- ! turn the result into a bignum and leave it in EAX.
- "end" get JNO
- ! There was an overflow. Recompute the original operand.
- { "y" "x" } %untag-fixnums
- "x" operand "y" operand rot execute
- "z" get "x" get %allot-bignum-signed-1
- "end" resolve-label ; inline
-
-: overflow-template ( word insn -- )
- [ overflow-check ] curry H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "z" } } }
- { +output+ { "z" } }
- { +clobber+ { "x" "y" } }
- } define-intrinsic ;
-
-\ fixnum+ \ ADD overflow-template
-\ fixnum- \ SUB overflow-template
-
-: fixnum-jump ( op inputs -- pair )
- >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
-
-: fixnum-value-jump ( op -- pair )
- { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
-
-: fixnum-register-jump ( op -- pair )
- { { f "x" } { f "y" } } fixnum-jump ;
-
-: define-fixnum-jump ( word op -- )
- [ fixnum-value-jump ] keep fixnum-register-jump
- 2array define-if-intrinsics ;
-
-{
- { fixnum< JGE }
- { fixnum<= JG }
- { fixnum> JLE }
- { fixnum>= JL }
- { eq? JNE }
-} [
- first2 define-fixnum-jump
-] each
-
-\ fixnum>bignum [
- "x" operand %untag-fixnum
- "x" get dup %allot-bignum-signed-1
-] H{
- { +input+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-\ bignum>fixnum [
- "nonzero" define-label
- "positive" define-label
- "end" define-label
- "x" operand %untag
- "y" operand "x" operand cell [+] MOV
- ! if the length is 1, its just the sign and nothing else,
- ! so output 0
- "y" operand 1 v>operand CMP
- "nonzero" get JNE
- "y" operand 0 MOV
- "end" get JMP
- "nonzero" resolve-label
- ! load the value
- "y" operand "x" operand 3 cells [+] MOV
- ! load the sign
- "x" operand "x" operand 2 cells [+] MOV
- ! is the sign negative?
- "x" operand 0 CMP
- "positive" get JE
- "y" operand -1 IMUL2
- "positive" resolve-label
- "y" operand 3 SHL
- "end" resolve-label
-] H{
- { +input+ { { f "x" } } }
- { +scratch+ { { f "y" } } }
- { +clobber+ { "x" } }
- { +output+ { "y" } }
-} define-intrinsic
-
-! User environment
-: %userenv ( -- )
- "x" operand 0 MOV
- "userenv" f rc-absolute-cell rel-dlsym
- "n" operand fixnum>slot@
- "n" operand "x" operand ADD ;
-
-\ getenv [
- %userenv "n" operand dup [] MOV
-] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "x" } } }
- { +output+ { "n" } }
-} define-intrinsic
-
-\ setenv [
- %userenv "n" operand [] "val" operand MOV
-] H{
- { +input+ { { f "val" } { f "n" } } }
- { +scratch+ { { f "x" } } }
- { +clobber+ { "n" } }
-} define-intrinsic
-
-\ (tuple) [
- tuple "layout" get size>> 2 + cells [
- ! Store layout
- "layout" get "scratch" get load-literal
- 1 object@ "scratch" operand MOV
- ! Store tagged ptr in reg
- "tuple" get tuple %store-tagged
- ] %allot
-] H{
- { +input+ { { [ ] "layout" } } }
- { +scratch+ { { f "tuple" } { f "scratch" } } }
- { +output+ { "tuple" } }
-} define-intrinsic
-
-\ (array) [
- array "n" get 2 + cells [
- ! Store length
- 1 object@ "n" operand MOV
- ! Store tagged ptr in reg
- "array" get object %store-tagged
- ] %allot
-] H{
- { +input+ { { [ ] "n" } } }
- { +scratch+ { { f "array" } } }
- { +output+ { "array" } }
-} define-intrinsic
-
-\ (byte-array) [
- byte-array "n" get 2 cells + [
- ! Store length
- 1 object@ "n" operand MOV
- ! Store tagged ptr in reg
- "array" get object %store-tagged
- ] %allot
-] H{
- { +input+ { { [ ] "n" } } }
- { +scratch+ { { f "array" } } }
- { +output+ { "array" } }
-} define-intrinsic
-
-\ <ratio> [
- ratio 3 cells [
- 1 object@ "numerator" operand MOV
- 2 object@ "denominator" operand MOV
- ! Store tagged ptr in reg
- "ratio" get ratio %store-tagged
- ] %allot
-] H{
- { +input+ { { f "numerator" } { f "denominator" } } }
- { +scratch+ { { f "ratio" } } }
- { +output+ { "ratio" } }
-} define-intrinsic
-
-\ <complex> [
- complex 3 cells [
- 1 object@ "real" operand MOV
- 2 object@ "imaginary" operand MOV
- ! Store tagged ptr in reg
- "complex" get complex %store-tagged
- ] %allot
-] H{
- { +input+ { { f "real" } { f "imaginary" } } }
- { +scratch+ { { f "complex" } } }
- { +output+ { "complex" } }
-} define-intrinsic
-
-\ <wrapper> [
- wrapper 2 cells [
- 1 object@ "obj" operand MOV
- ! Store tagged ptr in reg
- "wrapper" get object %store-tagged
- ] %allot
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "wrapper" } } }
- { +output+ { "wrapper" } }
-} define-intrinsic
-
-! Alien intrinsics
-: %alien-accessor ( quot -- )
- "offset" operand %untag-fixnum
- "offset" operand "alien" operand ADD
- "offset" operand [] swap call ; inline
-
-: %alien-integer-get ( quot reg -- )
- small-reg PUSH
- swap %alien-accessor
- "value" operand small-reg MOV
- "value" operand %tag-fixnum
- small-reg POP ; inline
-
-: alien-integer-get-template
- H{
- { +input+ {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { f "value" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
- } ;
-
-: define-getter ( word quot reg -- )
- [ %alien-integer-get ] 2curry
- alien-integer-get-template
- define-intrinsic ;
-
-: define-unsigned-getter ( word reg -- )
- [ small-reg dup XOR MOV ] swap define-getter ;
-
-: define-signed-getter ( word reg -- )
- [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
-
-: %alien-integer-set ( quot reg -- )
- small-reg PUSH
- small-reg "value" operand MOV
- small-reg %untag-fixnum
- swap %alien-accessor
- small-reg POP ; inline
-
-: alien-integer-set-template
- H{
- { +input+ {
- { f "value" fixnum }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +clobber+ { "value" "offset" } }
- } ;
-
-: define-setter ( word reg -- )
- [ swap MOV ] swap
- [ %alien-integer-set ] 2curry
- alien-integer-set-template
- define-intrinsic ;
-
-\ alien-unsigned-1 small-reg-8 define-unsigned-getter
-\ set-alien-unsigned-1 small-reg-8 define-setter
-
-\ alien-signed-1 small-reg-8 define-signed-getter
-\ set-alien-signed-1 small-reg-8 define-setter
-
-\ alien-unsigned-2 small-reg-16 define-unsigned-getter
-\ set-alien-unsigned-2 small-reg-16 define-setter
-
-\ alien-signed-2 small-reg-16 define-signed-getter
-\ set-alien-signed-2 small-reg-16 define-setter
-
-\ alien-cell [
- "value" operand [ MOV ] %alien-accessor
-] H{
- { +input+ {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { unboxed-alien "value" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
-} define-intrinsic
-
-\ set-alien-cell [
- "value" operand [ swap MOV ] %alien-accessor
-] H{
- { +input+ {
- { unboxed-c-ptr "value" pinned-c-ptr }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +clobber+ { "offset" } }
-} define-intrinsic
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays cpu.x86.assembler
-cpu.x86.architecture cpu.x86.intrinsics generic kernel
-kernel.private math math.private memory namespaces sequences
-words compiler.generator compiler.generator.registers
-cpu.architecture math.floats.private layouts quotations ;
-IN: cpu.x86.sse2
-
-: define-float-op ( word op -- )
- [ "x" operand "y" operand ] swap suffix H{
- { +input+ { { float "x" } { float "y" } } }
- { +output+ { "x" } }
- } define-intrinsic ;
-
-{
- { float+ ADDSD }
- { float- SUBSD }
- { float* MULSD }
- { float/f DIVSD }
-} [
- first2 define-float-op
-] each
-
-: define-float-jump ( word op -- )
- [ "x" operand "y" operand UCOMISD ] swap suffix
- { { float "x" } { float "y" } } define-if-intrinsic ;
-
-{
- { float< JAE }
- { float<= JA }
- { float> JBE }
- { float>= JB }
- { float= JNE }
-} [
- first2 define-float-jump
-] each
-
-\ float>fixnum [
- "out" operand "in" operand CVTTSD2SI
- "out" operand tag-bits get SHL
-] H{
- { +input+ { { float "in" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ fixnum>float [
- "in" operand %untag-fixnum
- "out" operand "in" operand CVTSI2SD
-] H{
- { +input+ { { f "in" } } }
- { +scratch+ { { float "out" } } }
- { +output+ { "out" } }
- { +clobber+ { "in" } }
-} define-intrinsic
-
-: alien-float-get-template
- H{
- { +input+ {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { float "value" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
- } ;
-
-: alien-float-set-template
- H{
- { +input+ {
- { float "value" float }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +clobber+ { "offset" } }
- } ;
-
-: define-alien-float-intrinsics ( word get-quot word set-quot -- )
- [ "value" operand swap %alien-accessor ] curry
- alien-float-set-template
- define-intrinsic
- [ "value" operand swap %alien-accessor ] curry
- alien-float-get-template
- define-intrinsic ;
-
-\ alien-double
-[ MOVSD ]
-\ set-alien-double
-[ swap MOVSD ]
-define-alien-float-intrinsics
-
-\ alien-float
-[ dupd MOVSS dup CVTSS2SD ]
-\ set-alien-float
-[ swap dup dup CVTSD2SS MOVSS ]
-define-alien-float-intrinsics
+++ /dev/null
-SSE2 floating point intrinsics for Pentium 4 and above
+++ /dev/null
-unportable
--- /dev/null
+unportable
+compiler
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs alien alien.c-types arrays strings
+cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
+kernel kernel.private math memory namespaces make sequences
+words system layouts combinators math.order fry locals
+compiler.constants compiler.cfg.registers
+compiler.cfg.instructions compiler.codegen
+compiler.codegen.fixup ;
+IN: cpu.x86
+
+M: x86 two-operand? t ;
+
+HOOK: temp-reg-1 cpu ( -- reg )
+HOOK: temp-reg-2 cpu ( -- reg )
+
+M: x86 %load-immediate MOV ;
+
+HOOK: rel-literal-x86 cpu ( literal -- )
+
+M: x86 %load-indirect swap 0 [] MOV rel-literal-x86 ;
+
+HOOK: ds-reg cpu ( -- reg )
+HOOK: rs-reg cpu ( -- reg )
+
+: reg-stack ( n reg -- op ) swap cells neg [+] ;
+
+GENERIC: loc>operand ( loc -- operand )
+
+M: ds-loc loc>operand n>> ds-reg reg-stack ;
+M: rs-loc loc>operand n>> rs-reg reg-stack ;
+
+M: x86 %peek loc>operand MOV ;
+M: x86 %replace loc>operand swap MOV ;
+: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; inline
+M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
+M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
+
+: align-stack ( n -- n' )
+ os macosx? cpu x86.64? or [ 16 align ] when ;
+
+HOOK: reserved-area-size cpu ( -- n )
+
+M: x86 stack-frame-size ( stack-frame -- i )
+ [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+ [ params>> ]
+ [ return>> ]
+ tri + +
+ 3 cells +
+ reserved-area-size +
+ align-stack ;
+
+M: x86 %call ( label -- ) CALL ;
+M: x86 %jump-label ( label -- ) JMP ;
+M: x86 %return ( -- ) 0 RET ;
+
+: code-alignment ( align -- n )
+ [ building get [ integer? ] count dup ] dip align swap - ;
+
+: align-code ( n -- )
+ 0 <repetition> % ;
+
+M:: x86 %dispatch ( src temp -- )
+ ! Load jump table base. We use a temporary register
+ ! since on AMD64 we have to load a 64-bit immediate. On
+ ! x86, this is redundant.
+ ! Add jump table base
+ temp HEX: ffffffff MOV rc-absolute-cell rel-here
+ src temp ADD
+ src HEX: 7f [+] JMP
+ ! Fix up the displacement above
+ cell code-alignment dup bootstrap-cell 8 = 15 9 ? +
+ building get dup pop* push
+ align-code ;
+
+M: x86 %dispatch-label ( word -- )
+ 0 cell, rc-absolute-cell rel-word ;
+
+:: (%slot) ( obj slot tag temp -- op )
+ temp slot obj [+] LEA
+ temp tag neg [+] ; inline
+
+:: (%slot-imm) ( obj slot tag -- op )
+ obj slot cells tag - [+] ; inline
+
+M: x86 %slot ( dst obj slot tag temp -- ) (%slot) MOV ;
+M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
+M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ;
+M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
+
+M: x86 %add [+] LEA ;
+M: x86 %add-imm [+] LEA ;
+M: x86 %sub nip SUB ;
+M: x86 %sub-imm neg [+] LEA ;
+M: x86 %mul nip swap IMUL2 ;
+M: x86 %mul-imm nip IMUL2 ;
+M: x86 %and nip AND ;
+M: x86 %and-imm nip AND ;
+M: x86 %or nip OR ;
+M: x86 %or-imm nip OR ;
+M: x86 %xor nip XOR ;
+M: x86 %xor-imm nip XOR ;
+M: x86 %shl-imm nip SHL ;
+M: x86 %shr-imm nip SHR ;
+M: x86 %sar-imm nip SAR ;
+M: x86 %not drop NOT ;
+
+: bignum@ ( reg n -- op )
+ cells bignum tag-number - [+] ; inline
+
+M:: x86 %integer>bignum ( dst src temp -- )
+ #! on entry, inreg is a signed 32-bit quantity
+ #! exits with tagged ptr to bignum in outreg
+ #! 1 cell header, 1 cell length, 1 cell sign, + digits
+ #! length is the # of digits + sign
+ [
+ "end" define-label
+ ! Load cached zero value
+ dst 0 >bignum %load-indirect
+ src 0 CMP
+ ! Is it zero? Then just go to the end and return this zero
+ "end" get JE
+ ! Allocate a bignum
+ dst 4 cells bignum temp %allot
+ ! Write length
+ dst 1 bignum@ 2 tag-fixnum MOV
+ ! Store value
+ dst 3 bignum@ src MOV
+ ! Compute sign
+ temp src MOV
+ temp cell-bits 1- SAR
+ temp 1 AND
+ ! Store sign
+ dst 2 bignum@ temp MOV
+ ! Make negative value positive
+ temp temp ADD
+ temp NEG
+ temp 1 ADD
+ src temp IMUL2
+ ! Store the bignum
+ dst 3 bignum@ temp MOV
+ "end" resolve-label
+ ] with-scope ;
+
+M:: x86 %bignum>integer ( dst src temp -- )
+ [
+ "end" define-label
+ ! load length
+ temp src 1 bignum@ MOV
+ ! if the length is 1, its just the sign and nothing else,
+ ! so output 0
+ dst 0 MOV
+ temp 1 tag-fixnum CMP
+ "end" get JE
+ ! load the value
+ dst src 3 bignum@ MOV
+ ! load the sign
+ temp src 2 bignum@ MOV
+ ! convert it into -1 or 1
+ temp temp ADD
+ temp NEG
+ temp 1 ADD
+ ! make dst signed
+ temp dst IMUL2
+ "end" resolve-label
+ ] with-scope ;
+
+M: x86 %add-float nip ADDSD ;
+M: x86 %sub-float nip SUBSD ;
+M: x86 %mul-float nip MULSD ;
+M: x86 %div-float nip DIVSD ;
+
+M: x86 %integer>float CVTSI2SD ;
+M: x86 %float>integer CVTTSD2SI ;
+
+: ?MOV ( dst src -- )
+ 2dup = [ 2drop ] [ MOV ] if ; inline
+
+M: x86 %copy ( dst src -- ) ?MOV ;
+
+M: x86 %copy-float ( dst src -- )
+ 2dup = [ 2drop ] [ MOVSD ] if ;
+
+M: x86 %unbox-float ( dst src -- )
+ float-offset [+] MOVSD ;
+
+M:: x86 %unbox-any-c-ptr ( dst src temp -- )
+ [
+ { "is-byte-array" "end" "start" } [ define-label ] each
+ dst 0 MOV
+ temp src MOV
+ ! We come back here with displaced aliens
+ "start" resolve-label
+ ! Is the object f?
+ temp \ f tag-number CMP
+ "end" get JE
+ ! Is the object an alien?
+ temp header-offset [+] alien type-number tag-fixnum CMP
+ "is-byte-array" get JNE
+ ! If so, load the offset and add it to the address
+ dst temp alien-offset [+] ADD
+ ! Now recurse on the underlying alien
+ temp temp underlying-alien-offset [+] MOV
+ "start" get JMP
+ "is-byte-array" resolve-label
+ ! Add byte array address to address being computed
+ dst temp ADD
+ ! Add an offset to start of byte array's data
+ dst byte-array-offset ADD
+ "end" resolve-label
+ ] with-scope ;
+
+M:: x86 %box-float ( dst src temp -- )
+ dst 16 float temp %allot
+ dst float-offset [+] src MOVSD ;
+
+: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
+
+M:: x86 %box-alien ( dst src temp -- )
+ [
+ "end" define-label
+ dst \ f tag-number MOV
+ src 0 CMP
+ "end" get JE
+ dst 4 cells alien temp %allot
+ dst 1 alien@ \ f tag-number MOV
+ dst 2 alien@ \ f tag-number MOV
+ ! Store src in alien-offset slot
+ dst 3 alien@ src MOV
+ "end" resolve-label
+ ] with-scope ;
+
+: small-reg-4 ( reg -- reg' )
+ H{
+ { EAX EAX }
+ { ECX ECX }
+ { EDX EDX }
+ { EBX EBX }
+ { ESP ESP }
+ { EBP EBP }
+ { ESI ESP }
+ { EDI EDI }
+
+ { RAX EAX }
+ { RCX ECX }
+ { RDX EDX }
+ { RBX EBX }
+ { RSP ESP }
+ { RBP EBP }
+ { RSI ESP }
+ { RDI EDI }
+ } at ; inline
+
+: small-reg-2 ( reg -- reg' )
+ small-reg-4 H{
+ { EAX AX }
+ { ECX CX }
+ { EDX DX }
+ { EBX BX }
+ { ESP SP }
+ { EBP BP }
+ { ESI SI }
+ { EDI DI }
+ } at ; inline
+
+: small-reg-1 ( reg -- reg' )
+ small-reg-4 {
+ { EAX AL }
+ { ECX CL }
+ { EDX DL }
+ { EBX BL }
+ } at ; inline
+
+: small-reg ( reg size -- reg' )
+ {
+ { 1 [ small-reg-1 ] }
+ { 2 [ small-reg-2 ] }
+ { 4 [ small-reg-4 ] }
+ } case ;
+
+: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
+
+: small-reg-that-isn't ( exclude -- reg' )
+ small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ;
+
+: with-save/restore ( reg quot -- )
+ [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
+
+:: with-small-register ( dst exclude quot: ( new-dst -- ) -- )
+ #! If the destination register overlaps a small register, we
+ #! call the quot with that. Otherwise, we find a small
+ #! register that is not in exclude, and call quot, saving
+ #! and restoring the small register.
+ dst small-reg-4 small-regs memq? [ dst quot call ] [
+ exclude small-reg-that-isn't
+ [ quot call ] with-save/restore
+ ] if ; inline
+
+M:: x86 %string-nth ( dst src index temp -- )
+ "end" define-label
+ dst { src index temp } [| new-dst |
+ temp src index [+] LEA
+ new-dst 1 small-reg temp string-offset [+] MOV
+ new-dst new-dst 1 small-reg MOVZX
+ temp src string-aux-offset [+] MOV
+ temp \ f tag-number CMP
+ "end" get JE
+ new-dst temp XCHG
+ new-dst index ADD
+ new-dst index ADD
+ new-dst 2 small-reg new-dst byte-array-offset [+] MOV
+ new-dst new-dst 2 small-reg MOVZX
+ new-dst 8 SHL
+ new-dst temp OR
+ "end" resolve-label
+ dst new-dst ?MOV
+ ] with-small-register ;
+
+:: %alien-integer-getter ( dst src size quot -- )
+ dst { src } [| new-dst |
+ new-dst dup size small-reg dup src [] MOV
+ quot call
+ dst new-dst ?MOV
+ ] with-small-register ; inline
+
+: %alien-unsigned-getter ( dst src size -- )
+ [ MOVZX ] %alien-integer-getter ; inline
+
+M: x86 %alien-unsigned-1 1 %alien-unsigned-getter ;
+M: x86 %alien-unsigned-2 2 %alien-unsigned-getter ;
+
+: %alien-signed-getter ( dst src size -- )
+ [ MOVSX ] %alien-integer-getter ; inline
+
+M: x86 %alien-signed-1 1 %alien-signed-getter ;
+M: x86 %alien-signed-2 2 %alien-signed-getter ;
+M: x86 %alien-signed-4 4 %alien-signed-getter ;
+
+M: x86 %alien-unsigned-4 4 [ 2drop ] %alien-integer-getter ;
+
+M: x86 %alien-cell [] MOV ;
+M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
+M: x86 %alien-double [] MOVSD ;
+
+:: %alien-integer-setter ( ptr value size -- )
+ value { ptr } [| new-value |
+ new-value value ?MOV
+ ptr [] new-value size small-reg MOV
+ ] with-small-register ; inline
+
+M: x86 %set-alien-integer-1 1 %alien-integer-setter ;
+M: x86 %set-alien-integer-2 2 %alien-integer-setter ;
+M: x86 %set-alien-integer-4 4 %alien-integer-setter ;
+M: x86 %set-alien-cell [ [] ] dip MOV ;
+M: x86 %set-alien-float dup dup CVTSD2SS [ [] ] dip MOVSS ;
+M: x86 %set-alien-double [ [] ] dip MOVSD ;
+
+: load-zone-ptr ( reg -- )
+ #! Load pointer to start of zone array
+ 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+
+: load-allot-ptr ( nursery-ptr allot-ptr -- )
+ [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
+
+: inc-allot-ptr ( nursery-ptr n -- )
+ [ cell [+] ] dip 8 align ADD ;
+
+: store-header ( temp class -- )
+ [ [] ] [ type-number tag-fixnum ] bi* MOV ;
+
+: store-tagged ( dst tag -- )
+ tag-number OR ;
+
+M:: x86 %allot ( dst size class nursery-ptr -- )
+ nursery-ptr dst load-allot-ptr
+ dst class store-header
+ dst class store-tagged
+ nursery-ptr size inc-allot-ptr ;
+
+HOOK: %alien-global cpu ( symbol dll register -- )
+
+M:: x86 %write-barrier ( src card# table -- )
+ #! Mark the card pointed to by vreg.
+ ! Mark the card
+ card# src MOV
+ card# card-bits SHR
+ "cards_offset" f table %alien-global
+ table card# [+] card-mark <byte> MOV
+
+ ! Mark the card deck
+ card# deck-bits card-bits - SHR
+ "decks_offset" f table %alien-global
+ table card# [+] card-mark <byte> MOV ;
+
+M: x86 %gc ( -- )
+ "end" define-label
+ temp-reg-1 load-zone-ptr
+ temp-reg-2 temp-reg-1 cell [+] MOV
+ temp-reg-2 1024 ADD
+ temp-reg-1 temp-reg-1 3 cells [+] MOV
+ temp-reg-2 temp-reg-1 CMP
+ "end" get JLE
+ %prepare-alien-invoke
+ "minor_gc" f %alien-invoke
+ "end" resolve-label ;
+
+HOOK: stack-reg cpu ( -- reg )
+
+: decr-stack-reg ( n -- )
+ dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
+
+: incr-stack-reg ( n -- )
+ dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
+
+M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
+
+: %boolean ( dst word -- )
+ over \ f tag-number MOV
+ 0 [] swap execute
+ \ t rel-literal-x86 ; inline
+
+M: x86 %compare ( dst cc src1 src2 -- )
+ CMP {
+ { cc< [ \ CMOVL %boolean ] }
+ { cc<= [ \ CMOVLE %boolean ] }
+ { cc> [ \ CMOVG %boolean ] }
+ { cc>= [ \ CMOVGE %boolean ] }
+ { cc= [ \ CMOVE %boolean ] }
+ { cc/= [ \ CMOVNE %boolean ] }
+ } case ;
+
+M: x86 %compare-imm ( dst cc src1 src2 -- )
+ %compare ;
+
+M: x86 %compare-float ( dst cc src1 src2 -- )
+ UCOMISD {
+ { cc< [ \ CMOVB %boolean ] }
+ { cc<= [ \ CMOVBE %boolean ] }
+ { cc> [ \ CMOVA %boolean ] }
+ { cc>= [ \ CMOVAE %boolean ] }
+ { cc= [ \ CMOVE %boolean ] }
+ { cc/= [ \ CMOVNE %boolean ] }
+ } case ;
+
+M: x86 %compare-branch ( label cc src1 src2 -- )
+ CMP {
+ { cc< [ JL ] }
+ { cc<= [ JLE ] }
+ { cc> [ JG ] }
+ { cc>= [ JGE ] }
+ { cc= [ JE ] }
+ { cc/= [ JNE ] }
+ } case ;
+
+M: x86 %compare-imm-branch ( label src1 src2 cc -- )
+ %compare-branch ;
+
+M: x86 %compare-float-branch ( label cc src1 src2 -- )
+ UCOMISD {
+ { cc< [ JB ] }
+ { cc<= [ JBE ] }
+ { cc> [ JA ] }
+ { cc>= [ JAE ] }
+ { cc= [ JE ] }
+ { cc/= [ JNE ] }
+ } case ;
+
+: stack@ ( n -- op ) stack-reg swap [+] ;
+
+: param@ ( n -- op ) reserved-area-size + stack@ ;
+
+: spill-integer-base ( stack-frame -- n )
+ [ params>> ] [ return>> ] bi + reserved-area-size + ;
+
+: spill-integer@ ( n -- op )
+ cells
+ stack-frame get spill-integer-base
+ + stack@ ;
+
+: spill-float-base ( stack-frame -- n )
+ [ spill-integer-base ]
+ [ spill-counts>> int-regs swap at int-regs reg-size * ]
+ bi + ;
+
+: spill-float@ ( n -- op )
+ double-float-regs reg-size *
+ stack-frame get spill-float-base
+ + stack@ ;
+
+M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
+M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
+
+M: x86 %spill-float ( src n -- ) spill-float@ swap MOVSD ;
+M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
+
+M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
+
+M: int-regs %save-param-reg drop >r param@ r> MOV ;
+M: int-regs %load-param-reg drop swap param@ MOV ;
+
+GENERIC: MOVSS/D ( dst src reg-class -- )
+
+M: single-float-regs MOVSS/D drop MOVSS ;
+M: double-float-regs MOVSS/D drop MOVSD ;
+
+M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ;
+M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ;
+
+GENERIC: push-return-reg ( reg-class -- )
+GENERIC: load-return-reg ( n reg-class -- )
+GENERIC: store-return-reg ( n reg-class -- )
+
+M: x86 %prepare-alien-invoke
+ #! Save Factor stack pointers in case the C code calls a
+ #! callback which does a GC, which must reliably trace
+ #! all roots.
+ "stack_chain" f temp-reg-1 %alien-global
+ temp-reg-1 [] stack-reg MOV
+ temp-reg-1 [] cell SUB
+ temp-reg-1 2 cells [+] ds-reg MOV
+ temp-reg-1 3 cells [+] rs-reg MOV ;
+
+M: x86 value-structs? t ;
+
+M: x86 small-enough? ( n -- ? )
+ HEX: -80000000 HEX: 7fffffff between? ;
+
+: next-stack@ ( n -- operand )
+ #! nth parameter from the next stack frame. Used to box
+ #! input values to callbacks; the callback has its own
+ #! stack frame set up, and we want to read the frame
+ #! set up by the caller.
+ stack-frame get total-size>> + stack@ ;
: create-function-sql ( class -- statement )
[
- [ remove-id ] dip
+ [ dup remove-id ] dip
"create function add_" 0% dup 0%
"(" 0%
over [ "," 0% ]
") values(" 0%
swap [ ", " 0% ] [ drop bind-name% ] interleave
"); " 0%
- "select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
+ "select currval(''" 0% 0% "_" 0%
+ find-primary-key first column-name>> 0%
+ "_seq'');' language sql;" 0%
] query-make ;
M: postgresql-db create-sql-statement ( class -- seq )
[ f ] [ <dlist> 3 over push-front 4 over push-back -1 swap deque-member? ] unit-test
[ f ] [ <dlist> 0 swap deque-member? ] unit-test
+
+! Make sure clone does the right thing
+[ V{ 2 1 } V{ 2 1 3 } ] [
+ <dlist> 1 over push-front 2 over push-front
+ dup clone 3 over push-back
+ [ dlist>seq ] bi@
+] unit-test
: dlist-each ( dlist quot -- )
[ obj>> ] prepose dlist-each-node ; inline
+: dlist>seq ( dlist -- seq )
+ [ ] pusher [ dlist-each ] dip ;
+
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
+M: dlist clone
+ <dlist> [
+ [ push-back ] curry dlist-each
+ ] keep ;
+
INSTANCE: dlist deque
M: float-array >pprint-sequence ;
M: float-array pprint* pprint-object ;
+! Rice
USING: hints math.vectors arrays ;
HINTS: vneg { float-array } { array } ;
HINTS: norm-sq { float-array } { array } ;
HINTS: norm { float-array } { array } ;
HINTS: normalize { float-array } { array } ;
+
+! More rice. Experimental, currently causes a slowdown in raytracer
+! for some odd reason.
+
+USING: words classes.algebra compiler.tree.propagation.info ;
+
+{ v+ v- v* v/ vmax vmin } [
+ [
+ [ class>> float-array class<= ] both?
+ float-array object ? <class-info>
+ ] "outputs" set-word-prop
+] each
+
+{ n*v n/v } [
+ [
+ nip class>> float-array class<= float-array object ? <class-info>
+ ] "outputs" set-word-prop
+] each
+
+{ v*n v/n } [
+ [
+ drop class>> float-array class<= float-array object ? <class-info>
+ ] "outputs" set-word-prop
+] each
+
+{ vneg normalize } [
+ [
+ class>> float-array class<= float-array object ? <class-info>
+ ] "outputs" set-word-prop
+] each
+
+\ norm-sq [
+ class>> float-array class<= float object ? <class-info>
+] "outputs" set-word-prop
+
+\ v. [
+ [ class>> float-array class<= ] both?
+ float object ? <class-info>
+] "outputs" set-word-prop
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators parser splitting math
-quotations arrays make qualified words ;
+quotations arrays make words ;
IN: fry
: _ ( -- * ) "Only valid inside a fry" throw ;
strings sbufs vectors byte-arrays quotations
io.streams.byte-array classes.builtin parser lexer
classes.predicate classes.union classes.intersection
-classes.singleton classes.tuple tools.vocabs.browser ;
+classes.singleton classes.tuple tools.vocabs.browser math.parser
+accessors ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
{ { $snippet { $emphasis "foo" } "?" } "outputs a boolean" { { $link empty? } } }
{ { $snippet "?" { $emphasis "foo" } } { "conditionally performs " { $snippet { $emphasis "foo" } } } { { $links ?nth } } }
{ { $snippet "<" { $emphasis "foo" } ">" } { "creates a new " { $snippet "foo" } } { { $link <array> } } }
+ { { $snippet ">" { $emphasis "foo" } } { "converts the top of the stack into a " { $snippet "foo" } } { { $link >array } } }
+ { { $snippet { $emphasis "foo" } ">" { $emphasis "bar" } } { "converts a " { $snippet "foo" } " into a " { $snippet "bar" } } { { $link number>string } } }
{ { $snippet "new-" { $emphasis "foo" } } { "creates a new " { $snippet "foo" } ", taking some kind of parameter from the stack which determines the type of the object to be created" } { { $link new-sequence } ", " { $link new-lexer } ", " { $link new } } }
{ { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } }
{ { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } }
{ { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } }
- { { $snippet { $emphasis "foo" } "-" { $emphasis "bar" } } { "(tuple accessors) outputs the value of the " { $snippet "bar" } " slot of the " { $snippet "foo" } " at the top of the stack" } { } }
- { { $snippet "set-" { $emphasis "foo" } "-" { $emphasis "bar" } } { "(tuple mutators) sets the value of the " { $snippet "bar" } " slot of the " { $snippet "foo" } " at the top of the stack" } { } }
+ { { $snippet { $emphasis "foo" } ">>" } { "gets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link >>name } } }
+ { { $snippet ">>" { $emphasis "foo" } } { "sets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link name>> } } }
{ { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-input-stream with-output-stream } }
{ { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } }
}
{ $subsection "slots" }
{ $subsection "mirrors" } ;
-USE: random
-
ARTICLE: "numbers" "Numbers"
{ $subsection "arithmetic" }
{ $subsection "math-constants" }
{ $subsection "math-functions" }
{ $subsection "number-strings" }
-{ $subsection "random" }
"Number implementations:"
{ $subsection "integers" }
{ $subsection "rationals" }
} ;
HELP: ABOUT:
-{ $syntax "MAIN: article" }
+{ $syntax "ABOUT: article" }
{ $values { "article" "a help article" } }
{ $description "Defines the main documentation article for the current vocabulary." } ;
USING: help.markup help.syntax ui.commands ui.operations
ui.tools.search ui.tools.workspace editors vocabs.loader
kernel sequences prettyprint tools.test tools.vocabs strings
-unicode.categories unicode.case ;
+unicode.categories unicode.case ui.tools.browser ;
IN: help.tutorial
ARTICLE: "first-program-start" "Creating a vocabulary for your first program"
"Factor source code is organized into " { $link "vocabularies" } ". Before we can write our first program, we must create a vocabulary for it."
$nl
-"Start by asking Factor for the path to your ``work'' directory, where you will place your own code:"
+"Start by loading the scaffold tool:"
+{ $code "USE: tools.scaffold" }
+"Then, ask the scaffold tool to create a new vocabulary named " { $snippet "palindrome" } ":"
+{ $code "\"resource:work\" \"palindrome\" scaffold-vocab" }
+"If you look at the output, you will see that a few files were created in your ``work'' directory. The following phrase will print the full path of your work directory:"
{ $code "\"work\" resource-path ." }
-"Open the work directory in your file manager, and create a subdirectory named " { $snippet "palindrome" } ". Inside this directory, create a file named " { $snippet "palindrome.factor" } " using your favorite text editor. Leave the file empty for now."
+"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". We will be editing this file."
$nl
-"Inside the Factor listener, type"
-{ $code "USE: palindrome" }
-"The source file should now load. Since it is empty, it does nothing. If you get an error message, make sure you created the directory and the file in the right place and gave them the right names."
-$nl
-"Now, we will start filling out this source file. Go back to your editor, and type:"
-{ $code
- "! Copyright (C) 2008 <your name here>"
- "! See http://factorcode.org/license.txt for BSD license."
-}
-"This is the standard header for Factor source files; it consists of two " { $link "syntax-comments" } "."
-$nl
-"Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
+"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
{ $code "IN: palindrome" }
+"We will add new definitions after the " { $link POSTPONE: IN: } " form."
+$nl
"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ;
ARTICLE: "first-program-logic" "Writing some logic in your first program"
$nl
"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
$nl
-"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary by entering the following in the listener:"
-{ $code "\\ dup see" }
-"This shows the definition of " { $link dup } ", along with an " { $link POSTPONE: IN: } " form."
+"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary. Enter " { $snippet "dup" } " in the listener's input area, and press " { $operation com-follow } ". This will open the documentation browser tool, viewing the help for the " { $link dup } " word. One of the subheadings in the help article will mention the word's vocabulary."
$nl
-"Now, add the following at the start of the source file:"
+"So now, add the following at the start of the source file:"
{ $code "USING: kernel ;" }
-"Next, find out what vocabulary " { $link reverse } " lives in:"
-{ $code "\\ reverse see" }
+"Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the workspace listener's input area, and press " { $operation com-follow } "."
+$nl
"It lives in the " { $vocab-link "sequences" } " vocabulary, so we add that to the search path:"
{ $code "USING: kernel sequences ;" }
-"Finally, check what vocabulary " { $link = } " lives in:"
-{ $code "\\ = see" }
-"It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
-
+"Finally, check what vocabulary " { $link = } " lives in, and confirm that it's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
+$nl
"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
ARTICLE: "first-program-test" "Testing your first program"
{ $code "." }
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
$nl
-"Create a file named " { $snippet "palindrome-tests.factor" } " in the same directory as " { $snippet "palindrome.factor" } ". Now, we can run unit tests from the listener:"
-{ $code "\"palindrome\" test" }
-"We will add some unit tests corresponding to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
+"Open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
+$nl
+"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
$nl
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
{ $code
ARTICLE: "first-program" "Your first program"
"In this tutorial, we will write a simple Factor program which prompts the user to enter a word, and tests if it is a palindrome (that is, the word is spelled the same backwards and forwards)."
$nl
-"In this tutorial, you will learn about basic Factor development tools, as well as application deployment."
+"In this tutorial, you will learn about basic Factor development tools. You may want to open a second workspace window by pressing " { $command workspace "workflow" workspace-window } "; this will allow you to read this tutorial and browse other documentation at the same time."
{ $subsection "first-program-start" }
{ $subsection "first-program-logic" }
{ $subsection "first-program-test" }
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each
-{ peek pop* pop push } [
+{ peek pop* pop } [
{ vector } "specializer" set-word-prop
] each
+\ push { { vector } { sbuf } } "specializer" set-word-prop
+
\ push-all
{ { string sbuf } { array vector } { byte-array byte-vector } }
"specializer" set-word-prop
[ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline
: buffer-pop ( buffer -- byte )
- [ buffer-peek ] [ 1 swap buffer-consume ] bi ;
-
-HINTS: buffer-pop buffer ;
+ [ buffer-peek ] [ 1 swap buffer-consume ] bi ; inline
: buffer-length ( buffer -- n )
[ fill>> ] [ pos>> ] bi - ; inline
HINTS: >buffer byte-array buffer ;
: byte>buffer ( byte buffer -- )
+ [ >fixnum ] dip
[ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ]
[ 1 swap n>buffer ]
- bi ;
-
-HINTS: byte>buffer fixnum buffer ;
+ bi ; inline
: search-buffer-until ( pos fill ptr separators -- n )
- [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ;
+ [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ; inline
: finish-buffer-until ( buffer n -- byte-array separator )
[
] [
[ buffer-length ] keep
buffer-read f
- ] if* ;
+ ] if* ; inline
: buffer-until ( separators buffer -- byte-array separator )
swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip
: decode-if< ( stream encoding max -- character )
nip swap stream-read1 dup
- [ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline
+ [ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline
PRIVATE>
SINGLETON: ascii
IN: io.encodings.string
ARTICLE: "io.encodings.string" "Encoding and decoding strings"
-"Strings can be encoded or decoded to and from byte arrays through an encoding with the following words:"
+"Strings can be encoded or decoded to and from byte arrays through an encoding by passing "
+{ $link "encodings-descriptors" } " to the following words:"
{ $subsection encode }
{ $subsection decode } ;
M: input-port stream-read1
dup check-disposed
- dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ;
+ dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
: read-step ( count port -- byte-array/f )
dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
: wait-to-write ( len port -- )
tuck buffer>> buffer-capacity <=
- [ drop ] [ stream-flush ] if ;
+ [ drop ] [ stream-flush ] if ; inline
M: output-port stream-write1
dup check-disposed
1 over wait-to-write
- buffer>> byte>buffer ;
+ buffer>> byte>buffer ; inline
M: output-port stream-write
dup check-disposed
HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
-HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ;
+HINTS: encoder-write { string output-port utf8 } { string output-port ascii } ;
$nl
"The two methods are equivalent, representing a functional versus an object-oriented approach to the problem." ;
+ARTICLE: "server-examples" "Threaded server examples"
+"The " { $vocab-link "time-server" } " vocabulary implements a simple threaded server which sends the current time to the client. The " { $vocab-link "concurrency.distributed" } ", " { $vocab-link "ftp.server" } ", and " { $vocab-link "http.server" } " vocabularies demonstrate more complex usage of the threaded server library." ;
+
ARTICLE: "io.servers.connection" "Threaded servers"
"The " { $vocab-link "io.servers.connection" } " vocabulary implements a generic server abstraction for " { $link "network-connection" } ". A set of threads listen for connections, and additional threads are spawned for each client connection. In addition to this basic functionality, it provides some advanced features such as logging, connection limits and secure socket support."
-{ $subsection threaded-server }
-{ $subsection "server-config" }
+{ $subsection "server-examples" }
"Creating threaded servers with client handler quotations:"
{ $subsection <threaded-server> }
"Client handlers can also be implemented by subclassing a threaded server; see " { $link "server-config-handler" } " for details:"
+{ $subsection threaded-server }
{ $subsection new-threaded-server }
{ $subsection handle-client* }
+"The server must be configured before it can be started."
+{ $subsection "server-config" }
"Starting the server:"
{ $subsection start-server }
{ $subsection start-server* }
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors alien.accessors math io ;
+USING: kernel accessors alien alien.c-types alien.accessors math io ;
IN: io.streams.memory
TUPLE: memory-stream alien index ;
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
[ [ 1+ ] change-index drop ] bi ;
+
+M: memory-stream stream-read
+ [
+ [ index>> ] [ alien>> ] bi <displaced-alien>
+ swap memory>byte-array
+ ] [ [ + ] change-index drop ] 2bi ;
PEG: tokenize-command ( command -- ast/f )
'argument' " " token repeat1 list-of
- " " token repeat0 swap over pack
+ " " token repeat0 tuck pack
just ;
swap >>type
swap >>mount-point ;
-: find-first-volume ( word -- string handle )
+: volume>paths ( string -- array )
+ 16384 "ushort" <c-array> tuck dup length
+ 0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
+ win32-error-string throw
+ ] [
+ *uint "ushort" heap-size * head
+ utf16n alien>string CHAR: \0 split
+ ] if ;
+
+: find-first-volume ( -- string handle )
MAX_PATH 1+ <byte-array> dup length
dupd
FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ;
-: find-next-volume ( handle -- string )
+: find-next-volume ( handle -- string/f )
MAX_PATH 1+ <byte-array> dup length
- [ FindNextVolume win32-error=0/f ] 2keep drop
- utf16n alien>string ;
+ over [ FindNextVolume ] dip swap 0 = [
+ GetLastError ERROR_NO_MORE_FILES =
+ [ drop f ] [ win32-error ] if
+ ] [
+ utf16n alien>string
+ ] if ;
-: mounted ( -- array )
+: find-volumes ( -- array )
find-first-volume
[
'[
]
] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
+M: winnt file-systems ( -- array )
+ find-volumes [ volume>paths ] map
+ concat [
+ [ file-system-info ]
+ [ drop winnt-file-system-info new swap >>mount-point ] recover
+ ] map ;
+
: file-times ( path -- timestamp timestamp timestamp )
[
normalize-path open-existing &dispose handle>>
--- /dev/null
+Slava Pestov
+James Cash
--- /dev/null
+IN: linked-assocs
+USING: help.markup help.syntax assocs ;
+
+HELP: linked-assoc
+{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assoc with a dlist. The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ;
+
+HELP: <linked-assoc>
+{ $values { "exemplar" "an exemplar assoc" } }
+{ $description "Creates an empty linked assoc backed by a new instance of the same type as the exemplar." } ;
+
+HELP: <linked-hash>
+{ $values { "assoc" linked-assoc } }
+{ $description "Creates an empty linked assoc backed by a hashtable." } ;
+
+ARTICLE: "linked-assocs" "Linked assocs"
+"A " { $emphasis "linked assoc" } " is an assoc which combines an underlying assoc with a dlist to form a structure which has the insertion and retrieval characteristics of the underlying assoc (typically a hashtable), but with the ability to get the entries in insertion order by calling " { $link >alist } "."
+$nl
+"Linked assocs are implemented in the " { $vocab-link "linked-assocs" } " vocabulary."
+{ $subsection linked-assoc }
+{ $subsection <linked-hash> }
+{ $subsection <linked-assoc> } ;
+
+ABOUT: "linked-assocs"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences assocs tools.test linked-assocs math ;
+IN: linked-assocs.test
+
+{ { 1 2 3 } } [
+ <linked-hash> 1 "b" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ values
+] unit-test
+
+{ 2 t } [
+ <linked-hash> 1 "b" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ "c" swap at*
+] unit-test
+
+{ { 2 3 4 } { "c" "a" "d" } 3 } [
+ <linked-hash> 1 "a" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ 4 "d" pick set-at
+ [ values ] [ keys ] [ assoc-size ] tri
+] unit-test
+
+{ f 1 } [
+ <linked-hash> 1 "c" pick set-at
+ 2 "b" pick set-at
+ "c" over delete-at
+ "c" over at swap assoc-size
+] unit-test
+
+{ { } 0 } [
+ <linked-hash> 1 "a" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ 4 "d" pick set-at
+ dup clear-assoc [ keys ] [ assoc-size ] bi
+] unit-test
+
+{ { } { 1 2 3 } } [
+ <linked-hash> dup clone
+ 1 "c" pick set-at
+ 2 "q" pick set-at
+ 3 "a" pick set-at
+ [ values ] bi@
+] unit-test
+
+{ 9 } [
+ <linked-hash>
+ { [ 3 * ] [ 1- ] } "first" pick set-at
+ { [ [ 1- ] bi@ ] [ 2 / ] } "second" pick set-at
+ 4 6 pick values [ first call ] each
+ + swap values <reversed> [ second call ] each
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, James Cash.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs arrays kernel deques dlists sequences fry ;
+IN: linked-assocs
+
+TUPLE: linked-assoc assoc dlist ;
+
+: <linked-assoc> ( exemplar -- assoc )
+ 0 swap new-assoc <dlist> linked-assoc boa ;
+
+: <linked-hash> ( -- assoc )
+ H{ } <linked-assoc> ;
+
+M: linked-assoc assoc-size assoc>> assoc-size ;
+
+M: linked-assoc at* assoc>> at* [ [ obj>> second ] when ] keep ;
+
+M: linked-assoc delete-at
+ [ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ]
+ [ assoc>> delete-at ] 2bi ;
+
+<PRIVATE
+: add-to-dlist ( value key lassoc -- node )
+ [ swap 2array ] dip dlist>> push-back* ;
+PRIVATE>
+
+M: linked-assoc set-at
+ [ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
+ assoc>> set-at ;
+
+: dlist>seq ( dlist -- seq )
+ [ ] pusher [ dlist-each ] dip ;
+
+M: linked-assoc >alist
+ dlist>> dlist>seq ;
+
+M: linked-assoc clear-assoc
+ [ assoc>> clear-assoc ] [ dlist>> clear-deque ] bi ;
+
+M: linked-assoc clone
+ [ assoc>> clone ] [ dlist>> clone ] bi
+ linked-assoc boa ;
+
+INSTANCE: linked-assoc assoc
--- /dev/null
+Assocs that yield items in insertion order
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel slots.private sequences effects words ;
+USING: math.private kernel slots.private sequences effects words ;
IN: locals.backend
: load-locals ( n -- )
- dup zero? [ drop ] [ swap >r 1- load-locals ] if ;
-
-: get-local ( n -- value )
- dup zero? [ drop dup ] [ r> swap 1- get-local swap >r ] if ;
+ dup 0 eq? [ drop ] [ swap >r 1 fixnum-fast load-locals ] if ;
: local-value 2 slot ; inline
: set-local-value 2 set-slot ; inline
-
-: drop-locals ( n -- )
- dup zero? [ drop ] [ r> drop 1- drop-locals ] if ;
USING: help.syntax help.markup kernel macros prettyprint
-memoize ;
+memoize combinators arrays ;
IN: locals
HELP: [|
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
+ARTICLE: "locals-literals" "Locals in array and hashtable literals"
+"Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables."
+$nl
+"The data types which receive this special handling are the following:"
+{ $list
+ { $link "arrays" }
+ { $link "hashtables" }
+ { $link "vectors" }
+ { $link "tuples" }
+}
+"This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:"
+{ $example
+ "IN: scratchpad"
+ "TUPLE: person first-name last-name ;"
+ ": ordinary-word-test ( -- tuple )"
+ " T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
+ "ordinary-word-test ordinary-word-test eq? ."
+ "t"
+}
+"In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:"
+{ $example
+ "IN: scratchpad"
+ "TUPLE: person first-name last-name ;"
+ ":: ordinary-word-test ( -- tuple )"
+ " T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
+ "ordinary-word-test ordinary-word-test eq? ."
+ "f"
+}
+"One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
+$nl
+"For example, here is an implementation of the " { $link 3array } " word which uses this feature:"
+{ $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
+
ARTICLE: "locals-mutable" "Mutable locals"
"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's name with the " { $snippet "!" } " suffix."
$nl
"Lambda abstractions:"
{ $subsection POSTPONE: [| }
"Additional topics:"
+{ $subsection "locals-literals" }
{ $subsection "locals-mutable" }
{ $subsection "locals-limitations" }
"Locals complement dynamically scoped variables implemented in the " { $vocab-link "namespaces" } " vocabulary." ;
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
-combinators.short-circuit.smart math.order math.functions ;
+combinators.short-circuit.smart math.order math.functions
+definitions compiler.units ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
[ 9 ] [ 3 big-case-test ] unit-test
+GENERIC: lambda-method-forget-test ( a -- b )
+
+M:: integer lambda-method-forget-test ( a -- b ) ;
+
+[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
+
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]
"lambda" word-prop body>> ;
M: lambda-method reset-word
- [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+ [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-memoized memoized lambda-word ;
-USING: help.markup help.syntax math ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax math sequences ;
IN: math.bitwise
-ARTICLE: "math-bitfields" "Constructing bit fields"
-"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
-{ $subsection bitfield } ;
-
-ABOUT: "math-bitfields"
-
HELP: bitfield
{ $values { "values..." "a series of objects" } { "bitspec" "an array" } { "n" integer } }
{ $description "Constructs an integer from a series of values on the stack together with a bit field specifier, which is an array whose elements have one of the following shapes:"
{ $example "USING: math.bitwise prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ;
HELP: bitroll
-{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
+{ $values { "x" integer } { "s" "a shift integer" } { "w" "a wrap integer" } { "y" integer }
+}
{ $description "Roll n by s bits to the left, wrapping around after w bits." }
{ $examples
{ $example "USING: math.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
{ $example "USING: math.bitwise prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
} ;
+
+HELP: bit-clear?
+{ $values
+ { "x" integer } { "n" integer }
+ { "?" "a boolean" }
+}
+{ $description "Returns " { $link t } " if the nth bit is set to zero." }
+{ $examples
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: ff 8 bit-clear? ."
+ "t"
+ }
+ { $example "" "USING: math.bitwise prettyprint ;"
+ "HEX: ff 7 bit-clear? ."
+ "f"
+ }
+} ;
+
+{ bit? bit-clear? set-bit clear-bit } related-words
+
+HELP: bit-count
+{ $values
+ { "x" integer }
+ { "n" integer }
+}
+{ $description "Returns the number of set bits as an integer." }
+{ $examples
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: f0 bit-count ."
+ "4"
+ }
+ { $example "USING: math.bitwise prettyprint ;"
+ "-7 bit-count ."
+ "2"
+ }
+} ;
+
+HELP: bitroll-32
+{ $values
+ { "n" integer } { "s" integer }
+ { "n'" integer }
+}
+{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 32 bits." }
+{ $examples
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: 1 10 bitroll-32 .h"
+ "400"
+ }
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: 1 -10 bitroll-32 .h"
+ "400000"
+ }
+} ;
+
+HELP: bitroll-64
+{ $values
+ { "n" integer } { "s" "a shift integer" }
+ { "n'" integer }
+}
+{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 64 bits." }
+{ $examples
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: 1 10 bitroll-64 .h"
+ "400"
+ }
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: 1 -10 bitroll-64 .h"
+ "40000000000000"
+ }
+} ;
+
+{ bitroll bitroll-32 bitroll-64 } related-words
+
+HELP: clear-bit
+{ $values
+ { "x" integer } { "n" integer }
+ { "y" integer }
+}
+{ $description "Sets the nth bit of " { $snippet "x" } " to zero." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ff 7 clear-bit .h"
+ "7f"
+ }
+} ;
+
+HELP: flags
+{ $values
+ { "values" sequence }
+}
+{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "IN: scratchpad"
+ ": MY-CONSTANT HEX: 1 ; inline"
+ "{ HEX: 20 MY-CONSTANT BIN: 100 } flags .h"
+ "25"
+ }
+} ;
+
+HELP: mask
+{ $values
+ { "x" integer } { "n" integer }
+ { "?" "a boolean" }
+}
+{ $description "After the operation, only the bits that were set in both the mask and the original number are set." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "BIN: 11111111 BIN: 101 mask .b"
+ "101"
+ }
+} ;
+
+HELP: mask-bit
+{ $values
+ { "m" integer } { "n" integer }
+ { "m'" integer }
+}
+{ $description "Turns off all bits besides the nth bit." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ff 2 mask-bit .b"
+ "100"
+ }
+} ;
+
+HELP: mask?
+{ $values
+ { "x" integer } { "n" integer }
+ { "?" "a boolean" }
+}
+{ $description "Returns true if all of the bits in the mask " { $snippet "n" } " are set in the integer input " { $snippet "x" } "." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ff HEX: f mask? ."
+ "t"
+ }
+
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: f0 HEX: 1 mask? ."
+ "f"
+ }
+} ;
+
+HELP: on-bits
+{ $values
+ { "n" integer }
+ { "m" integer }
+}
+{ $description "Returns an integer with " { $snippet "n" } " bits set." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "6 on-bits .h"
+ "3f"
+ }
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "64 on-bits .h"
+ "ffffffffffffffff"
+ }
+}
+;
+
+HELP: set-bit
+{ $values
+ { "x" integer } { "n" integer }
+ { "y" integer }
+}
+{ $description "Sets the nth bit of " { $snippet "x" } "." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "0 5 set-bit .h"
+ "20"
+ }
+} ;
+
+HELP: shift-mod
+{ $values
+ { "n" integer } { "s" integer } { "w" integer }
+ { "n" integer }
+}
+{ $description "" } ;
+
+HELP: unmask
+{ $values
+ { "x" integer } { "n" integer }
+ { "?" "a boolean" }
+}
+{ $description "Clears the bits in " { $snippet "x" } " if they are set in the mask " { $snippet "n" } "." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ff HEX: 0f unmask .h"
+ "f0"
+ }
+} ;
+
+HELP: unmask?
+{ $values
+ { "x" integer } { "n" integer }
+ { "?" "a boolean" }
+}
+{ $description "Tests whether unmasking the bits in " { $snippet "x" } " would return an integer greater than zero." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ff HEX: 0f unmask? ."
+ "t"
+ }
+} ;
+
+HELP: w*
+{ $values
+ { "int" integer } { "int" integer }
+ { "int" integer }
+}
+{ $description "Multiplies two integers and wraps the result to 32 bits." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ffffffff HEX: 2 w* ."
+ "4294967294"
+ }
+} ;
+
+HELP: w+
+{ $values
+ { "int" integer } { "int" integer }
+ { "int" integer }
+}
+{ $description "Adds two integers and wraps the result to 32 bits." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ffffffff HEX: 2 w+ ."
+ "1"
+ }
+} ;
+
+HELP: w-
+{ $values
+ { "int" integer } { "int" integer }
+ { "int" integer }
+}
+{ $description "Subtracts two integers and wraps the result to 32 bits." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: 0 HEX: ff w- ."
+ "4294967041"
+ }
+} ;
+
+HELP: wrap
+{ $values
+ { "m" integer } { "n" integer }
+ { "m'" integer }
+}
+{ $description "Wraps an integer " { $snippet "m" } " by modding it by " { $snippet "n" } ". This word is uses bitwise arithmetic and does not actually call the modulus word, and as such can only mod by powers of two." }
+{ $examples "Equivalent to modding by 8:"
+ { $example
+ "USING: math.bitwise prettyprint ;"
+ "HEX: ffff 8 wrap .h"
+ "7"
+ }
+} ;
+
+ARTICLE: "math-bitfields" "Constructing bit fields"
+"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
+{ $subsection bitfield } ;
+
+ARTICLE: "math.bitwise" "Bitwise arithmetic"
+"The " { $vocab-link "math.bitwise" } " vocabulary can implements bitwise arithmetic words that are useful for efficiency, low-level programming, and interfacing with C libraries." $nl
+"Setting and clearing bits:"
+{ $subsection set-bit }
+{ $subsection clear-bit }
+"Testing if bits are set or clear:"
+{ $subsection bit? }
+{ $subsection bit-clear? }
+"Operations with bitmasks:"
+{ $subsection mask }
+{ $subsection unmask }
+{ $subsection mask? }
+{ $subsection unmask? }
+"Generating an integer with n set bits:"
+{ $subsection on-bits }
+"Counting the number of set bits:"
+{ $subsection bit-count }
+"More efficient modding by powers of two:"
+{ $subsection wrap }
+"Bit-rolling:"
+{ $subsection bitroll }
+{ $subsection bitroll-32 }
+{ $subsection bitroll-64 }
+"32-bit arithmetic:"
+{ $subsection w+ }
+{ $subsection w- }
+{ $subsection w* }
+"Bitfields:"
+{ $subsection flags }
+{ $subsection "math-bitfields" } ;
+
+ABOUT: "math.bitwise"
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo must-infer
+
+[ 1 ] [ { 1 } flags ] unit-test
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions sequences
sequences.private words namespaces macros hints
! utilities
: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
: set-bit ( x n -- y ) 2^ bitor ; inline
-: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
+: bit-clear? ( x n -- ? ) 2^ bitand 0 = ; inline
: unmask ( x n -- ? ) bitnot bitand ; inline
: unmask? ( x n -- ? ) unmask 0 > ; inline
: mask ( x n -- ? ) bitand ; inline
: mask? ( x n -- ? ) mask 0 > ; inline
: wrap ( m n -- m' ) 1- bitand ; inline
: bits ( m n -- m' ) 2^ wrap ; inline
-: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
+: mask-bit ( m n -- m' ) 2^ mask ; inline
+: on-bits ( n -- m ) 2^ 1- ; inline
: shift-mod ( n s w -- n )
- >r shift r> 2^ wrap ; inline
+ [ shift ] dip 2^ wrap ; inline
: bitroll ( x s w -- y )
- [ wrap ] keep
- [ shift-mod ]
- [ [ - ] keep shift-mod ] 3bi bitor ; inline
+ [ wrap ] keep
+ [ shift-mod ]
+ [ [ - ] keep shift-mod ] 3bi bitor ; inline
-: bitroll-32 ( n s -- n' ) 32 bitroll ;
+: bitroll-32 ( n s -- n' ) 32 bitroll ; inline
HINTS: bitroll-32 bignum fixnum ;
-: bitroll-64 ( n s -- n' ) 64 bitroll ;
+: bitroll-64 ( n s -- n' ) 64 bitroll ; inline
HINTS: bitroll-64 bignum fixnum ;
! flags
MACRO: flags ( values -- )
- [ 0 ] [ [ execute bitor ] curry compose ] reduce ;
+ [ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
! bitfield
<PRIVATE
[ swapd shift bitor ] curry ;
M: pair (bitfield-quot) ( spec -- quot )
- first2 over word? [ >r swapd execute r> ] [ ] ?
+ first2 over word? [ [ swapd execute ] dip ] [ ] ?
[ shift bitor ] append 2curry ;
PRIVATE>
PRIVATE>
: bit-count ( x -- n )
- dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline
+ dup 0 < [ bitnot ] when (bit-count) ; inline
gcd nip
] unit-test
+[ 11 ] [
+ 13262642990609552931815424
+ 159151715887314635181785
+ gcd nip
+] unit-test
+
+[ 3 ] [
+ 13262642990609552931
+ 1591517158873146351
+ gcd nip
+] unit-test
+
+[ 26525285981219 ] [
+ 132626429906095
+ 159151715887314
+ gcd nip
+] unit-test
+
+
: verify-gcd ( a b -- ? )
2dup gcd
>r rot * swap rem r> = ;
[ -4.0 ] [ -4.4 round ] unit-test
[ 5.0 ] [ 4.5 round ] unit-test
[ 4.0 ] [ 4.4 round ] unit-test
+
+[ 6 59967 ] [ 3837888 factor-2s ] unit-test
+[ 6 -59967 ] [ -3837888 factor-2s ] unit-test
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel math.constants math.private
-math.libm combinators math.order ;
+math.libm combinators math.order sequences ;
IN: math.functions
+: >fraction ( a/b -- a b )
+ [ numerator ] [ denominator ] bi ; inline
+
<PRIVATE
: (rect>) ( x y -- z )
2dup >r >r >r odd? r> call r> 2/ r> each-bit
] if ; inline recursive
-: ^n ( z w -- z^w )
- 1 swap [
- [ dupd * ] when >r sq r>
- ] each-bit nip ; inline
+: map-bits ( n quot: ( ? -- obj ) -- seq )
+ accumulator [ each-bit ] dip ; inline
+
+: factor-2s ( n -- r s )
+ #! factor an integer into 2^r * s
+ dup 0 = [ 1 ] [
+ 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while
+ ] if ; inline
+
+<PRIVATE
+
+GENERIC# ^n 1 ( z w -- z^w )
+
+: (^n) 1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline
+
+M: integer ^n
+ [ factor-2s ] dip [ (^n) ] keep rot * shift ;
+
+M: ratio ^n
+ [ >fraction ] dip tuck [ ^n ] 2bi@ / ;
+
+M: float ^n
+ (^n) ;
: integer^ ( x y -- z )
dup 0 > [ ^n ] [ neg ^n recip ] if ; inline
+PRIVATE>
+
: >rect ( z -- x y )
[ real-part ] [ imaginary-part ] bi ; inline
: polar> ( abs arg -- z ) cis * ; inline
+<PRIVATE
+
: ^mag ( w abs arg -- magnitude )
>r >r >float-rect swap r> swap fpow r> rot * fexp /f ;
inline
: 0^ ( x -- z )
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
+PRIVATE>
+
: ^ ( x y -- z )
{
{ [ over zero? ] [ nip 0^ ] }
0 1 (a,b) 1 2 [a,b] interval-union 0 2 (a,b] =
] unit-test
-[ f ] [ 0 1 (a,b) f interval-union ] unit-test
-
[ t ] [
0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
] unit-test
[ empty-interval ] [ 0 5 (a,b] empty-interval interval-intersect ] unit-test
+[ t ] [
+ 0 1 (a,b) full-interval interval-intersect 0 1 (a,b) =
+] unit-test
+
[ t ] [
empty-interval empty-interval interval-subset?
] unit-test
! Interval random tester
: random-element ( interval -- n )
- dup to>> first over from>> first tuck - random +
- 2dup swap interval-contains? [
- nip
+ dup full-interval eq? [
+ drop 32 random-bits 31 2^ -
] [
- drop random-element
+ dup to>> first over from>> first tuck - random +
+ 2dup swap interval-contains? [
+ nip
+ ] [
+ drop random-element
+ ] if
] if ;
: random-interval ( -- interval )
- 2000 random 1000 - dup 2 1000 random + +
- 1 random zero? [ [ neg ] bi@ swap ] when
- 4 random {
- { 0 [ [a,b] ] }
- { 1 [ [a,b) ] }
- { 2 [ (a,b) ] }
- { 3 [ (a,b] ] }
- } case ;
+ 10 random 0 = [ full-interval ] [
+ 2000 random 1000 - dup 2 1000 random + +
+ 1 random zero? [ [ neg ] bi@ swap ] when
+ 4 random {
+ { 0 [ [a,b] ] }
+ { 1 [ [a,b) ] }
+ { 2 [ (a,b) ] }
+ { 3 [ (a,b] ] }
+ } case
+ ] if ;
: random-unary-op ( -- pair )
{
{ bitand interval-bitand }
{ bitor interval-bitor }
{ bitxor interval-bitxor }
- { shift interval-shift }
+ ! { shift interval-shift }
{ min interval-min }
{ max interval-max }
}
SYMBOL: empty-interval
+SYMBOL: full-interval
+
TUPLE: interval { from read-only } { to read-only } ;
: <interval> ( from to -- int )
: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
-: [-inf,inf] ( -- interval )
- T{ interval f { -1./0. t } { 1./0. t } } ; inline
+: [-inf,inf] ( -- interval ) full-interval ; inline
: compare-endpoints ( p1 p2 quot -- ? )
>r over first over first r> call [
: do-empty-interval ( i1 i2 quot -- i3 )
{
- { [ pick empty-interval eq? ] [ drop drop ] }
+ { [ pick empty-interval eq? ] [ 2drop ] }
{ [ over empty-interval eq? ] [ drop nip ] }
+ { [ pick full-interval eq? ] [ 2drop ] }
+ { [ over full-interval eq? ] [ drop nip ] }
[ call ]
} cond ; inline
: interval-intersect ( i1 i2 -- i3 )
{
- { [ dup empty-interval eq? ] [ nip ] }
{ [ over empty-interval eq? ] [ drop ] }
+ { [ dup empty-interval eq? ] [ nip ] }
+ { [ over full-interval eq? ] [ nip ] }
+ { [ dup full-interval eq? ] [ drop ] }
[
- 2dup and [
- [ interval>points ] bi@ swapd
- [ [ swap endpoint< ] most ]
- [ [ swap endpoint> ] most ] 2bi*
- <interval>
- ] [
- or
- ] if
+ [ interval>points ] bi@ swapd
+ [ [ swap endpoint< ] most ]
+ [ [ swap endpoint> ] most ] 2bi*
+ <interval>
]
} cond ;
: interval-union ( i1 i2 -- i3 )
{
- { [ dup empty-interval eq? ] [ drop ] }
{ [ over empty-interval eq? ] [ nip ] }
- [
- 2dup and [
- [ interval>points 2array ] bi@ append points>interval
- ] [
- 2drop f
- ] if
- ]
+ { [ dup empty-interval eq? ] [ drop ] }
+ { [ over full-interval eq? ] [ drop ] }
+ { [ dup full-interval eq? ] [ nip ] }
+ [ [ interval>points 2array ] bi@ append points>interval ]
} cond ;
: interval-subset? ( i1 i2 -- ? )
: interval-contains? ( x int -- ? )
dup empty-interval eq? [ 2drop f ] [
- [ from>> first2 [ >= ] [ > ] if ]
- [ to>> first2 [ <= ] [ < ] if ]
- 2bi and
+ dup full-interval eq? [ 2drop t ] [
+ [ from>> first2 [ >= ] [ > ] if ]
+ [ to>> first2 [ <= ] [ < ] if ]
+ 2bi and
+ ] if
] if ;
: interval-zero? ( int -- ? )
: interval-sq ( i1 -- i2 ) dup interval* ;
+: special-interval? ( interval -- ? )
+ { empty-interval full-interval } memq? ;
+
: interval-singleton? ( int -- ? )
- dup empty-interval eq? [
+ dup special-interval? [
drop f
] [
interval>points
: interval-length ( int -- n )
{
{ [ dup empty-interval eq? ] [ drop 0 ] }
- { [ dup not ] [ drop 0 ] }
+ { [ dup full-interval eq? ] [ drop 1/0. ] }
[ interval>points [ first ] bi@ swap - ]
} cond ;
[ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
: interval-interior ( i1 -- i2 )
- dup empty-interval eq? [
+ dup special-interval? [
interval>points [ first ] bi@ (a,b)
] unless ;
: interval-abs ( i1 -- i2 )
{
{ [ dup empty-interval eq? ] [ ] }
+ { [ dup full-interval eq? ] [ drop 0 [a,inf] ] }
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
[ (interval-abs) points>interval ]
} cond ;
: interval< ( i1 i2 -- ? )
{
- { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
+ { [ 2dup [ special-interval? ] either? ] [ incomparable ] }
{ [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
{ [ 2dup left-endpoint-< ] [ f ] }
{ [ 2dup right-endpoint-< ] [ f ] }
: interval<= ( i1 i2 -- ? )
{
- { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
+ { [ 2dup [ special-interval? ] either? ] [ incomparable ] }
{ [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
{ [ 2dup right-endpoint-<= ] [ t ] }
[ incomparable ]
interval-bitor ;
: assume< ( i1 i2 -- i3 )
- dup empty-interval eq? [ drop ] [
+ dup special-interval? [ drop ] [
to>> first [-inf,a) interval-intersect
] if ;
: assume<= ( i1 i2 -- i3 )
- dup empty-interval eq? [ drop ] [
+ dup special-interval? [ drop ] [
to>> first [-inf,a] interval-intersect
] if ;
: assume> ( i1 i2 -- i3 )
- dup empty-interval eq? [ drop ] [
+ dup special-interval? [ drop ] [
from>> first (a,inf] interval-intersect
] if ;
: assume>= ( i1 i2 -- i3 )
- dup empty-interval eq? [ drop ] [
+ dup special-interval? [ drop ] [
from>> first [a,inf] interval-intersect
] if ;
: integral-closure ( i1 -- i2 )
- dup empty-interval eq? [
+ dup special-interval? [
[ from>> first2 [ 1+ ] unless ]
[ to>> first2 [ 1- ] unless ]
bi [a,b]
M: math-partial integer-op-input-classes
"derived-from" word-prop rest ;
+ERROR: bad-integer-op word ;
+
M: word integer-op-input-classes
- "input-classes" word-prop
- [ "Bug: integer-op-input-classes" throw ] unless* ;
+ dup "input-classes" word-prop
+ [ ] [ bad-integer-op ] ?if ;
: generic-variant ( op -- generic-op/f )
dup "derived-from" word-prop [ first ] [ ] ?if ;
USING: help.markup help.syntax math math.private
-math.ratios.private ;
+math.ratios.private math.functions ;
IN: math.ratios
ARTICLE: "rationals" "Rational numbers"
USING: accessors kernel kernel.private math math.functions math.private ;
IN: math.ratios
-: >fraction ( a/b -- a b )
- dup numerator swap denominator ; inline
-
: 2>fraction ( a/b c/d -- a c b d )
[ >fraction ] bi@ swapd ; inline
[ object>> [ swap slot ] curry ] bi
map zip ;
-M: mirror assoc-size object>> layout-of size>> ;
+M: mirror assoc-size object>> layout-of second ;
INSTANCE: mirror assoc
HELP: gl-error
{ $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ;
-HELP: do-state
- {
- $values
- { "mode" { "One of the " { $link "opengl-geometric-primitives" } } }
- { "quot" quotation }
- }
-{ $description "Wraps a quotation in " { $link glBegin } "/" { $link glEnd } " calls." } ;
-
HELP: do-enabled
{ $values { "what" integer } { "quot" quotation } }
{ $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ;
{ $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } }
{ $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ;
-HELP: gl-vertex
-{ $values { "point" "a pair of integers" } }
-{ $description "Wrapper for " { $link glVertex2d } " taking a point object." } ;
-
HELP: gl-line
{ $values { "a" "a pair of integers" } { "b" "a pair of integers" } }
{ $description "Draws a line between two points." } ;
HELP: gl-fill-rect
-{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
-{ $description "Draws a filled rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ;
+{ $values { "dim" "a pair of integers" } }
+{ $description "Draws a filled rectangle with the top-left corner at the origin and the given dimensions." } ;
HELP: gl-rect
-{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
-{ $description "Draws the outline of a rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ;
-
-HELP: rect-vertices
-{ $values { "lower-left" "A pair of numbers indicating the lower-left coordinates of the rectangle." } { "upper-right" "The upper-right coordinates of the rectangle." } }
-{ $description "Emits" { $link glVertex2d } " calls outlining the axis-aligned rectangle from " { $snippet "lower-left" } " to " { $snippet "upper-right" } " on the z=0 plane in counterclockwise order." } ;
-
-HELP: gl-fill-poly
-{ $values { "points" "a sequence of pairs of integers" } }
-{ $description "Draws a filled polygon." } ;
-
-HELP: gl-poly
-{ $values { "points" "a sequence of pairs of integers" } }
-{ $description "Draws the outline of a polygon." } ;
-
-HELP: gl-gradient
-{ $values { "direction" "an orientation specifier" } { "colors" "a sequence of color specifiers" } { "dim" "a pair of integers" } }
-{ $description "Draws a rectangle with top-left corner " { $snippet "{ 0 0 }" } " and dimensions " { $snippet "dim" } ", filled with a smoothly shaded transition between the colors in " { $snippet "colors" } "." } ;
+{ $values { "dim" "a pair of integers" } }
+{ $description "Draws the outline of a rectangle with the top-left corner at the origin and the given dimensions." } ;
HELP: gen-texture
{ $values { "id" integer } }
{ $subsection "opengl-low-level" }
"Wrappers:"
{ $subsection gl-color }
-{ $subsection gl-vertex }
{ $subsection gl-translate }
{ $subsection gen-texture }
{ $subsection bind-texture-unit }
"Combinators:"
-{ $subsection do-state }
{ $subsection do-enabled }
{ $subsection do-attribs }
{ $subsection do-matrix }
{ $subsection gl-line }
{ $subsection gl-fill-rect }
{ $subsection gl-rect }
-{ $subsection gl-fill-poly }
-{ $subsection gl-poly }
-{ $subsection gl-gradient }
;
ABOUT: "gl-utilities"
! Portions copyright (C) 2007 Eduardo Cavazos.
! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-
USING: alien alien.c-types continuations kernel libc math macros
- namespaces math.vectors math.constants math.functions
- math.parser opengl.gl opengl.glu combinators arrays sequences
- splitting words byte-arrays assocs colors accessors ;
-
+namespaces math.vectors math.constants math.functions
+math.parser opengl.gl opengl.glu combinators arrays sequences
+splitting words byte-arrays assocs colors accessors
+generalizations locals memoize ;
IN: opengl
-: coordinates ( point1 point2 -- x1 y2 x2 y2 )
- [ first2 ] bi@ ;
-
-: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
- [ first2 [ >fixnum ] bi@ ] bi@ ;
+: color>raw ( object -- r g b a )
+ >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
-: gl-color ( color -- ) first4 glColor4d ; inline
+: gl-color ( color -- ) color>raw glColor4d ; inline
-: gl-clear-color ( color -- )
- first4 glClearColor ;
+: gl-clear-color ( color -- ) color>raw glClearColor ;
: gl-clear ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
-: color>raw ( object -- r g b a )
- >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
-
-: set-color ( object -- ) color>raw glColor4d ;
-: set-clear-color ( object -- ) color>raw glClearColor ;
-
: gl-error ( -- )
glGetError dup zero? [
"GL error: " over gluErrorString append throw
] unless drop ;
-: do-state ( mode quot -- )
- swap glBegin call glEnd ; inline
-
: do-enabled ( what quot -- )
over glEnable dip glDisable ; inline
+
: do-enabled-client-state ( what quot -- )
over glEnableClientState dip glDisableClientState ; inline
: (all-enabled) ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
+
: (all-enabled-client-state) ( seq quot -- )
[ dup [ glEnableClientState ] each ] dip
dip
MACRO: all-enabled ( seq quot -- )
>r words>values r> [ (all-enabled) ] 2curry ;
+
MACRO: all-enabled-client-state ( seq quot -- )
>r words>values r> [ (all-enabled-client-state) ] 2curry ;
swap [ glMatrixMode glPushMatrix call ] keep
glMatrixMode glPopMatrix ; inline
-: gl-vertex ( point -- )
- dup length {
- { 2 [ first2 glVertex2d ] }
- { 3 [ first3 glVertex3d ] }
- { 4 [ first4 glVertex4d ] }
- } case ;
-
-: gl-normal ( normal -- ) first3 glNormal3d ;
-
: gl-material ( face pname params -- )
>c-float-array glMaterialfv ;
+: gl-vertex-pointer ( seq -- )
+ [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
+
+: gl-color-pointer ( seq -- )
+ [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline
+
+: gl-texture-coord-pointer ( seq -- )
+ [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
+
+: line-vertices ( a b -- )
+ append >c-float-array gl-vertex-pointer ;
+
: gl-line ( a b -- )
- GL_LINES [ gl-vertex gl-vertex ] do-state ;
+ line-vertices GL_LINES 0 2 glDrawArrays ;
-: gl-fill-rect ( loc ext -- )
- coordinates glRectd ;
+: (rect-vertices) ( dim -- vertices )
+ {
+ [ drop 0 1 ]
+ [ first 1- 1 ]
+ [ [ first 1- ] [ second ] bi ]
+ [ second 0 swap ]
+ } cleave 8 narray >c-float-array ;
-: gl-rect ( loc ext -- )
- GL_FRONT_AND_BACK GL_LINE glPolygonMode
- >r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
- GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
+: rect-vertices ( dim -- )
+ (rect-vertices) gl-vertex-pointer ;
-: (gl-poly) ( points state -- )
- [ [ gl-vertex ] each ] do-state ;
+: (gl-rect) ( -- )
+ GL_LINE_LOOP 0 4 glDrawArrays ;
-: gl-fill-poly ( points -- )
- dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
+: gl-rect ( dim -- )
+ rect-vertices (gl-rect) ;
-: gl-poly ( points -- )
- GL_LINE_LOOP (gl-poly) ;
+: (fill-rect-vertices) ( dim -- vertices )
+ {
+ [ drop 0 0 ]
+ [ first 0 ]
+ [ first2 ]
+ [ second 0 swap ]
+ } cleave 8 narray >c-float-array ;
+
+: fill-rect-vertices ( dim -- )
+ (fill-rect-vertices) gl-vertex-pointer ;
+
+: (gl-fill-rect) ( -- )
+ GL_QUADS 0 4 glDrawArrays ;
+
+: gl-fill-rect ( dim -- )
+ fill-rect-vertices (gl-fill-rect) ;
: circle-steps ( steps -- angles )
dup length v/n 2 pi * v*n ;
: circle-points ( loc dim steps -- points )
circle-steps unit-circle adjust-points scale-points ;
-: gl-circle ( loc dim steps -- )
- circle-points gl-poly ;
-
-: gl-fill-circle ( loc dim steps -- )
- circle-points gl-fill-poly ;
-
-: prepare-gradient ( direction dim -- v1 v2 )
- tuck v* [ v- ] keep ;
-
-: gl-gradient ( direction colors dim -- )
- GL_QUAD_STRIP [
- swap >r prepare-gradient r>
- [ length dup 1- v/n ] keep [
- >r >r 2dup r> r> set-color v*n
- dup gl-vertex v+ gl-vertex
- ] 2each 2drop
- ] do-state ;
+: circle-vertices ( loc dim steps -- vertices )
+ circle-points concat >c-float-array ;
: (gen-gl-object) ( quot -- id )
>r 1 0 <uint> r> keep *uint ; inline
+
: gen-texture ( -- id )
[ glGenTextures ] (gen-gl-object) ;
+
: gen-gl-buffer ( -- id )
[ glGenBuffers ] (gen-gl-object) ;
: (delete-gl-object) ( id quot -- )
>r 1 swap <uint> r> call ; inline
+
: delete-texture ( id -- )
[ glDeleteTextures ] (delete-gl-object) ;
+
: delete-gl-buffer ( id -- )
[ glDeleteBuffers ] (delete-gl-object) ;
: gl-translate ( point -- ) first2 0.0 glTranslated ;
-<PRIVATE
-
-: top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
-
-: top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
-
-: bottom-left 0 1 glTexCoord2i second 0.0 swap glVertex2d ; inline
-
-: bottom-right 1 1 glTexCoord2i gl-vertex ; inline
+MEMO: (rect-texture-coords) ( -- seq )
+ { 0 0 1 0 1 1 0 1 } >c-float-array ;
-PRIVATE>
-
-: four-sides ( dim -- )
- dup top-left dup top-right dup bottom-right bottom-left ;
+: rect-texture-coords ( -- )
+ (rect-texture-coords) gl-texture-coord-pointer ;
: draw-sprite ( sprite -- )
- dup loc>> gl-translate
- GL_TEXTURE_2D over texture>> glBindTexture
- init-texture
- GL_QUADS [ dim2>> four-sides ] do-state
- GL_TEXTURE_2D 0 glBindTexture ;
-
-: rect-vertices ( lower-left upper-right -- )
- GL_QUADS [
- over first2 glVertex2d
- dup first pick second glVertex2d
- dup first2 glVertex2d
- swap first swap second glVertex2d
- ] do-state ;
+ GL_TEXTURE_COORD_ARRAY [
+ dup loc>> gl-translate
+ GL_TEXTURE_2D over texture>> glBindTexture
+ init-texture rect-texture-coords
+ dim2>> fill-rect-vertices
+ (gl-fill-rect)
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-enabled-client-state ;
: make-sprite-dlist ( sprite -- id )
GL_MODELVIEW [
: with-translation ( loc quot -- )
GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline
+: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
+ [ first2 [ >fixnum ] bi@ ] bi@ ;
+
: gl-set-clip ( loc dim -- )
fix-coordinates glScissor ;
M: ebnf-foreign (transform) ( ast -- parser )\r
dup word>> search\r
[ "Foreign word '" swap word>> append "' not found" append throw ] unless*\r
- swap rule>> [ main ] unless* dupd swap rule [\r
+ swap rule>> [ main ] unless* over rule [\r
nip\r
] [\r
execute\r
] [
pprint-object
] if ;
-
-M: tuple-layout pprint*
- "( tuple layout )" swap present-text ;
USING: prettyprint.backend prettyprint.config
prettyprint.sections prettyprint.private help.markup help.syntax
-io kernel words definitions quotations strings ;
+io kernel words definitions quotations strings generic classes ;
IN: prettyprint
ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"
{ $subsection pprint-cell }
"Printing a definition (see " { $link "definitions" } "):"
{ $subsection see }
+"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
+{ $subsection see-methods }
"More prettyprinter usage:"
{ $subsection "prettyprint-numbers" }
{ $subsection "prettyprint-stacks" }
HELP: pprint
{ $values { "obj" object } }
-{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
+{ $warning
+ "Unparsing a large object can take a long time and consume a lot of memory. If you need to print large objects, use " { $link pprint-short } " or set some " { $link "prettyprint-variables" } " to limit output size."
+} ;
{ pprint pprint* with-pprint } related-words
HELP: .
{ $values { "obj" object } }
-{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
+{ $warning
+ "Printing a large object can take a long time and consume a lot of memory. If you need to print large objects, use " { $link short. } " or set some " { $link "prettyprint-variables" } " to limit output size."
+} ;
HELP: unparse
{ $values { "obj" object } { "str" "Factor source string" } }
-{ $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
+{ $warning
+ "Unparsing a large object can take a long time and consume a lot of memory. If you need to unparse large objects, use " { $link unparse-short } " or set some " { $link "prettyprint-variables" } " to limit output size."
+} ;
HELP: pprint-short
{ $values { "obj" object } }
{ $values { "defspec" "a definition specifier" } }
{ $contract "Prettyprints a definition." } ;
+HELP: see-methods
+{ $values { "word" "a " { $link generic } " or a " { $link class } } }
+{ $contract "Prettyprints the methods defined on a generic word or class." } ;
+
HELP: definer
{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
{ $contract "Outputs the parsing words which delimit the definition." }
: pprint-cell ( obj -- ) [ pprint ] with-cell ;
+: simple-table. ( values -- )
+ standard-table-style [
+ [
+ [
+ [
+ dup string?
+ [ [ write ] with-cell ]
+ [ pprint-cell ]
+ if
+ ] each
+ ] with-row
+ ] each
+ ] tabular-output ;
+
GENERIC: see ( defspec -- )
: comment. ( string -- )
"RENAME: + math => -"
"2 3 - ! => 5" } } ;
+ARTICLE: "qualified" "Qualified word lookup"
+"The " { $vocab-link "qualified" } " vocabulary provides a handful of parsing words which give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } "."
+$nl
+"These words are useful when there is no way to avoid using two vocabularies with identical word names in the same source file."
+{ $subsection POSTPONE: QUALIFIED: }
+{ $subsection POSTPONE: QUALIFIED-WITH: }
+{ $subsection POSTPONE: FROM: }
+{ $subsection POSTPONE: EXCLUDE: }
+{ $subsection POSTPONE: RENAME: } ;
+
+ABOUT: "qualified"
-USING: tools.test qualified ;
-IN: foo
+USING: tools.test qualified eval accessors parser ;
+IN: qualified.tests.foo
: x 1 ;
-IN: bar
+: y 5 ;
+IN: qualified.tests.bar
: x 2 ;
-IN: baz
+: y 4 ;
+IN: qualified.tests.baz
: x 3 ;
-QUALIFIED: foo
-QUALIFIED: bar
-[ 1 2 3 ] [ foo:x bar:x x ] unit-test
+QUALIFIED: qualified.tests.foo
+QUALIFIED: qualified.tests.bar
+[ 1 2 3 ] [ qualified.tests.foo:x qualified.tests.bar:x x ] unit-test
-QUALIFIED-WITH: bar p
+QUALIFIED-WITH: qualified.tests.bar p
[ 2 ] [ p:x ] unit-test
-RENAME: x baz => y
+RENAME: x qualified.tests.baz => y
[ 3 ] [ y ] unit-test
-FROM: baz => x ;
+FROM: qualified.tests.baz => x ;
[ 3 ] [ x ] unit-test
+[ 3 ] [ y ] unit-test
-EXCLUDE: bar => x ;
+EXCLUDE: qualified.tests.bar => x ;
[ 3 ] [ x ] unit-test
+[ 4 ] [ y ] unit-test
+
+[ "USE: qualified IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
+[ error>> no-word-error? ] must-fail-with
+[ "USE: qualified IN: qualified.tests RENAME: doesnotexist qualified.tests => blah" eval ]
+[ error>> no-word-error? ] must-fail-with
! Copyright (C) 2007, 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences assocs hashtables parser lexer
-vocabs words namespaces vocabs.loader debugger sets ;
+vocabs words namespaces vocabs.loader debugger sets fry ;
IN: qualified
: define-qualified ( vocab-name prefix-name -- )
[ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
- [ -rot >r append r> ] curry assoc-map
+ '[ [ [ _ ] dip append ] dip ] assoc-map
use get push ;
: QUALIFIED:
: expect=> ( -- ) scan "=>" assert= ;
-: partial-vocab ( words name -- assoc )
- dupd [
- lookup [ "No such word: " swap append throw ] unless*
- ] curry map zip ;
+: partial-vocab ( words vocab -- assoc )
+ '[ dup _ lookup [ no-word-error ] unless* ]
+ { } map>assoc ;
-: partial-vocab-ignoring ( words name -- assoc )
+: FROM:
+ #! Syntax: FROM: vocab => words... ;
+ scan dup load-vocab drop expect=>
+ ";" parse-tokens swap partial-vocab use get push ; parsing
+
+: partial-vocab-excluding ( words vocab -- assoc )
[ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
: EXCLUDE:
#! Syntax: EXCLUDE: vocab => words ... ;
scan expect=>
- ";" parse-tokens swap partial-vocab-ignoring use get push ; parsing
-
-: FROM:
- #! Syntax: FROM: vocab => words... ;
- scan dup load-vocab drop expect=>
- ";" parse-tokens swap partial-vocab use get push ; parsing
+ ";" parse-tokens swap partial-vocab-excluding use get push ; parsing
: RENAME:
#! Syntax: RENAME: word vocab => newname
- scan scan dup load-vocab drop lookup [ "No such word" throw ] unless*
+ scan scan dup load-vocab drop
+ dupd lookup [ ] [ no-word-error ] ?if
expect=>
scan associate use get push ; parsing
: mt-a HEX: 9908b0df ; inline
: calculate-y ( n seq -- y )
- [ nth 32 mask-bit ]
+ [ nth 31 mask-bit ]
[ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline
: (mt-generate) ( n seq -- next-mt )
[ next-index ]
[ seq>> nth mt-temper ]
[ [ 1+ ] change-i drop ] tri ;
+
+USE: init
+
+[
+ [ 32 random-bits ] with-system-random
+ <mersenne-twister> random-generator set-global
+] "bootstrap.random" add-init-hook
: with-secure-random ( quot -- )
secure-random-generator get swap with-random ; inline
+
+USE: vocabs.loader
+
+{
+ { [ os windows? ] [ "random.windows" require ] }
+ { [ os unix? ] [ "random.unix" require ] }
+} cond
+
+"random.mersenne-twister" require
SINGLETON: beginning-of-input
SINGLETON: end-of-input
-! : beginning-of-input ( -- obj )
-: handle-front-anchor ( -- ) front-anchor push-stack ;
-: end-of-line ( -- obj )
- end-of-input
+: newlines ( -- obj1 obj2 obj3 )
CHAR: \r <constant>
CHAR: \n <constant>
- 2dup 2array <concatenation> 4array <alternation> lookahead boa ;
+ 2dup 2array <concatenation> ;
+
+: beginning-of-line ( -- obj )
+ beginning-of-input newlines 4array <alternation> lookbehind boa ;
+
+: end-of-line ( -- obj )
+ end-of-input newlines 4array <alternation> lookahead boa ;
+
+: handle-front-anchor ( -- )
+ get-multiline beginning-of-line beginning-of-input ? push-stack ;
-: handle-back-anchor ( -- ) end-of-line push-stack ;
+: handle-back-anchor ( -- )
+ get-multiline end-of-line end-of-input ? push-stack ;
ERROR: bad-character-class obj ;
ERROR: expected-posix-class ;
[ [ push ] keep current-regexp get (>>stack) ]
[ finish-regexp-parse push-stack ] bi* ;
-
: parse-regexp-token ( token -- ? )
{
-! todo: only match these at beginning/end of regexp
- { CHAR: ^ [ handle-front-anchor t ] }
- { CHAR: $ [ handle-back-anchor t ] }
-
- { CHAR: . [ handle-dot t ] }
- { CHAR: ( [ handle-left-parenthesis t ] }
+ { CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning?
{ CHAR: ) [ handle-right-parenthesis f ] }
+ { CHAR: . [ handle-dot t ] }
{ CHAR: | [ handle-pipe t ] }
{ CHAR: ? [ handle-question t ] }
{ CHAR: * [ handle-star t ] }
{ CHAR: { [ handle-left-brace t ] }
{ CHAR: [ [ handle-left-bracket t ] }
{ CHAR: \ [ handle-escape t ] }
- [ <constant> push-stack t ]
+ [
+ dup CHAR: $ = peek1 f = and [
+ drop
+ handle-back-anchor f
+ ] [
+ <constant> push-stack t
+ ] if
+ ]
} case ;
: (parse-regexp) ( -- )
read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
+: parse-regexp-beginning ( -- )
+ peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ;
+
: parse-regexp ( regexp -- )
dup current-regexp [
raw>> [
- <string-reader> [ (parse-regexp) ] with-input-stream
+ <string-reader> [
+ parse-regexp-beginning (parse-regexp)
+ ] with-input-stream
] unless-empty
current-regexp get
stack finish-regexp-parse
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
-
reversed-regexp initial-option
construct-regexp ;
-
: parsing-regexp ( accum end -- accum )
lexer get dup skip-blank
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
: R{ CHAR: } parsing-regexp ; parsing
: R| CHAR: | parsing-regexp ; parsing
-
: find-regexp-syntax ( string -- prefix suffix )
{
{ "R/ " "/" }
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators kernel math math.ranges
quotations sequences regexp.parser regexp.classes fry arrays
-combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
+combinators.short-circuit regexp.utils prettyprint regexp.nfa
+shuffle ;
IN: regexp.traversal
TUPLE: dfa-traverser
[ dfa-table>> ] [ dfa-traversal-flags>> ] bi
dfa-traverser new
swap >>traversal-flags
- swap [ start-state>> >>current-state ] keep
- >>dfa-table
+ swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
swap >>text
t >>traverse-forward
0 >>start-index
[ [ first2 1+ 2array ] map ] change-capture-counters
! dup current-state>> .
dup [ current-state>> ] [ traversal-flags>> ] bi
- at [ dup . flag-action ] with each ;
+ at [ flag-action ] with each ;
: increment-state ( dfa-traverser state -- dfa-traverser )
[
V{ } clone >>matches ;
: match-literal ( transition from-state table -- to-state/f )
- transitions>> at* [ at ] [ 2drop f ] if ;
+ transitions>> at at ;
: match-class ( transition from-state table -- to-state/f )
transitions>> at* [
] [ drop ] if ;
: match-default ( transition from-state table -- to-state/f )
- [ nip ] dip transitions>> at*
- [ t swap at* [ ] [ drop f ] if ] [ drop f ] if ;
+ nipd transitions>> at t swap at ;
: match-transition ( obj from-state dfa -- to-state/f )
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
pop-literal nip >>library
pop-literal nip >>return
! Quotation which coerces parameters to required types
- dup param-prep-quot recursive-state get infer-quot
+ dup param-prep-quot infer-quot-here
! Set ABI
dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
! Magic #: consume exactly the number of inputs
! Add node to IR
dup #alien-invoke,
! Quotation which coerces return value to required type
- return-prep-quot recursive-state get infer-quot ;
+ return-prep-quot infer-quot-here ;
: infer-alien-indirect ( -- )
alien-indirect-params new
pop-parameters >>parameters
pop-literal nip >>return
! Quotation which coerces parameters to required types
- dup param-prep-quot [ dip ] curry recursive-state get infer-quot
+ dup param-prep-quot [ dip ] curry infer-quot-here
! Magic #: consume the function pointer, too
dup 1 alien-stack
! Add node to IR
dup #alien-indirect,
! Quotation which coerces return value to required type
- return-prep-quot recursive-state get infer-quot ;
+ return-prep-quot infer-quot-here ;
! Callbacks are registered in a global hashtable. If you clear
! this hashtable, they will all be blown away by code GC, beware
: callback-bottom ( params -- )
xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
- recursive-state get infer-quot ;
+ infer-quot-here ;
: infer-alien-callback ( -- )
alien-callback-params new
: terminate ( -- )
terminated? on meta-d get clone meta-r get clone #terminate, ;
+: infer-quot-here ( quot -- )
+ [ apply-object terminated? get not ] all? drop ;
+
: infer-quot ( quot rstate -- )
recursive-state get [
recursive-state set
- [ apply-object terminated? get not ] all? drop
+ infer-quot-here
] dip recursive-state set ;
: infer-quot-recursive ( quot word label -- )
2array recursive-state get swap prefix infer-quot ;
: time-bomb ( error -- )
- '[ _ throw ] recursive-state get infer-quot ;
+ '[ _ throw ] infer-quot-here ;
: bad-call ( -- )
"call must be given a callable" time-bomb ;
: infer-branches ( branches -- input children data )
[ pop-d ] dip
[ infer-branch ] map
- [ stack-visitor branch-variable ] keep ;
+ [ stack-visitor branch-variable ] keep ; inline
: (infer-if) ( branches -- )
- infer-branches [ first2 #if, ] dip compute-phi-function ;
+ infer-branches
+ [ first2 #if, ] dip compute-phi-function ;
: infer-if ( -- )
2 consume-d
dup [ known [ curried? ] [ composed? ] bi or ] contains? [
output-d
[ rot [ drop call ] [ nip call ] if ]
- recursive-state get infer-quot
+ infer-quot-here
] [
[ #drop, ] [ [ literal ] map (infer-if) ] bi
] if ;
: infer-dispatch ( -- )
pop-literal nip [ <literal> ] map
- infer-branches [ #dispatch, ] dip compute-phi-function ;
+ infer-branches
+ [ #dispatch, ] dip compute-phi-function ;
M: curried infer-call*
swap push-d
- [ uncurry ] recursive-state get infer-quot
+ [ uncurry ] infer-quot-here
[ quot>> known pop-d [ set-known ] keep ]
[ obj>> known pop-d [ set-known ] keep ] bi
push-d infer-call ;
M: composed infer-call*
swap push-d
- [ uncompose ] recursive-state get infer-quot
+ [ uncompose ] infer-quot-here
[ quot2>> known pop-d [ set-known ] keep ]
[ quot1>> known pop-d [ set-known ] keep ] bi
push-d push-d
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
- peek-d literal value>> size>> 1+ { tuple } <effect>
+ peek-d literal value>> second 1+ { tuple } <effect>
apply-word/effect ;
: infer-(throw) ( -- )
\ <tuple> { tuple-layout } { tuple } define-primitive
\ <tuple> make-flushable
-\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } define-primitive
-\ <tuple-layout> make-foldable
-
\ datastack { } { array } define-primitive
\ datastack make-flushable
GENERIC: infer ( quot -- effect )
M: callable infer ( quot -- effect )
- [ recursive-state get infer-quot ] with-infer drop ;
+ [ infer-quot-here ] with-infer drop ;
: infer. ( quot -- )
#! Safe to call from inference transforms.
recursive-state get at ;
: local-recursive-state ( -- assoc )
- recursive-state get dup keys
- [ dup word? [ inline? ] when not ] find drop
+ recursive-state get dup
+ [ first dup word? [ inline? ] when not ] find drop
[ head-slice ] when* ;
: inline-recursive-label ( word -- label/f )
-USING: help.markup help.syntax words definitions ;
+USING: help.markup help.syntax words definitions prettyprint ;
IN: tools.crossref
ARTICLE: "tools.crossref" "Cross-referencing tools"
{ $subsection usage. }
{ $subsection apropos }
-{ $see-also "definitions" "words" } ;
+{ $see-also "definitions" "words" see see-methods } ;
ABOUT: "tools.crossref"
{ "compiler" deploy-compiler? }
{ "threads" deploy-threads? }
{ "ui" deploy-ui? }
- { "random" deploy-random? }
+ { "unicode" deploy-unicode? }
} [ nip get ] assoc-filter keys
native-io? [ "io" suffix ] when ;
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
{ $subsection deploy-compiler? }
-{ $subsection deploy-random? }
+{ $subsection deploy-unicode? }
{ $subsection deploy-threads? }
{ $subsection deploy-ui? }
"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
$nl
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
-HELP: deploy-random?
-{ $description "Deploy flag. If set, the random number generator protocol is included, together with two implementations: a native OS-specific random number generator, and the Mersenne Twister."
+HELP: deploy-unicode?
+{ $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included."
$nl
-"On by default. If your program does not generate random numbers you can disable this to save some space." } ;
+"Off by default. If your program needs to use " { $link POSTPONE: CHAR: } " with named characters, enable this flag." } ;
HELP: deploy-threads?
{ $description "Deploy flag. If set, thread support will be included in the final image."
SYMBOL: deploy-ui?
SYMBOL: deploy-compiler?
SYMBOL: deploy-math?
-SYMBOL: deploy-random?
+SYMBOL: deploy-unicode?
SYMBOL: deploy-threads?
SYMBOL: deploy-io
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-threads? t }
- { deploy-random? t }
+ { deploy-unicode? f }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-word-defs? f }
\r
[ t ] [ 1200000 small-enough? ] unit-test\r
\r
-! [ ] [ "tetris" shake-and-bake ] unit-test\r
-! \r
-! [ t ] [ 1500000 small-enough? ] unit-test\r
+[ ] [ "tetris" shake-and-bake ] unit-test\r
+\r
+[ t ] [ 1500000 small-enough? ] unit-test\r
\r
[ ] [ "bunny" shake-and-bake ] unit-test\r
\r
compiled-generic-crossref
recompile-hook
update-tuples-hook
+ remake-generics-hook
definition-observers
definitions:crossref
interactive-vocabs
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-io 1 }
{ deploy-name "tools.deploy.test.6" }
{ deploy-math? t }
- { deploy-random? f }
{ deploy-compiler? t }
{ deploy-ui? f }
{ deploy-c-types? f }
"resource:factor.dll" swap copy-file-into ;
: copy-freetype ( bundle-name -- )
- deploy-ui? get [
- {
- "resource:freetype6.dll"
- "resource:zlib1.dll"
- } swap copy-files-into
- ] [ drop ] if ;
+ {
+ "resource:freetype6.dll"
+ "resource:zlib1.dll"
+ } swap copy-files-into ;
: create-exe-dir ( vocab bundle-name -- vm )
+ dup copy-dll
deploy-ui? get [
- dup copy-dll
dup copy-freetype
dup "" copy-fonts
] when
M: winnt deploy*
"resource:" [
- deploy-name over deploy-config at
- [
- {
+ dup deploy-config [
+ deploy-name get
+ [
[ create-exe-dir ]
[ image-name ]
[ drop ]
- [ drop deploy-config ]
- } 2cleave make-deploy-image
- ]
- [ nip open-in-explorer ] 2bi
+ 2tri namespace make-deploy-image
+ ]
+ [ nip open-in-explorer ] 2bi
+ ] bind
] with-directory ;
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io words alien kernel math.parser alien.syntax
io.launcher system assocs arrays sequences namespaces make
-qualified system math compiler.generator.fixup
+qualified system math compiler.codegen.fixup
io.encodings.ascii accessors generic tr ;
IN: tools.disassembler
"{ $values" print
[ " " write ($values.) ]
[ [ nl " " write ($values.) ] unless-empty ] bi*
- " }" write nl
+ nl "}" print
] if
] when* ;
{ $subsection test-all } ;
ARTICLE: "tools.test.failure" "Handling test failures"
-"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Sometimes, you want to develop a tool which inspects the test failures and takes some kind of action instead; one example is " { $vocab-link "builder" } "."
+"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "."
$nl
"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:"
{ $list
: benchmark ( quot -- runtime )
millis >r call millis r> - ; inline
-: simple-table. ( values -- )
- standard-table-style [
- [
- [
- [
- dup string?
- [ [ write ] with-cell ]
- [ pprint-cell ]
- if
- ] each
- ] with-row
- ] each
- ] tabular-output ;
-
: time. ( data -- )
unclip
"==== RUNNING TIME" print nl pprint " ms" print nl
:: (draw-string) ( open-font sprites string loc -- )
GL_TEXTURE_2D [
loc [
+ -0.5 0.5 0.0 glTranslated
string open-font string char-widths scan-sums [
[ open-font sprites ] 2dip draw-char
] 2each
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math models namespaces sequences
- strings quotations assocs combinators classes colors
- classes.tuple opengl math.vectors
- ui.commands ui.gadgets ui.gadgets.borders
- ui.gadgets.labels ui.gadgets.theme
- ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
- ui.render math.geometry.rect ;
+strings quotations assocs combinators classes colors
+classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
+ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
+ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
+ui.render math.geometry.rect locals alien.c-types ;
IN: ui.gadgets.buttons
} cond ;
M: button-paint draw-interior
- button-paint draw-interior ;
+ button-paint dup [ draw-interior ] [ 2drop ] if ;
M: button-paint draw-boundary
- button-paint draw-boundary ;
+ button-paint dup [ draw-boundary ] [ 2drop ] if ;
: align-left ( button -- button )
{ 0 1/2 } >>align ; inline
#! the mouse is held down.
repeat-button new-button bevel-button-theme ;
-TUPLE: checkmark-paint color ;
+TUPLE: checkmark-paint < caching-pen color last-vertices ;
-C: <checkmark-paint> checkmark-paint
+: <checkmark-paint> ( color -- paint )
+ checkmark-paint new swap >>color ;
+
+<PRIVATE
+
+: checkmark-points ( dim -- points )
+ {
+ [ { 0 0 } v* { 0 1 } v+ ]
+ [ { 1 1 } v* { 0 1 } v+ ]
+ [ { 0 1 } v* ]
+ [ { 1 0 } v* ]
+ } cleave 4array ;
+
+: checkmark-vertices ( dim -- vertices )
+ checkmark-points concat >c-float-array ;
+
+PRIVATE>
+
+M: checkmark-paint recompute-pen
+ swap dim>> checkmark-vertices >>last-vertices drop ;
M: checkmark-paint draw-interior
- color>> set-color
- origin get [
- rect-dim
- { 0 0 } over gl-line
- dup { 0 1 } v* swap { 1 0 } v* gl-line
- ] with-translation ;
+ [ compute-pen ]
+ [ color>> gl-color ]
+ [ last-vertices>> gl-vertex-pointer ] tri
+ GL_LINES 0 4 glDrawArrays ;
: checkmark-theme ( gadget -- gadget )
f
M: checkbox model-changed
swap value>> >>selected? relayout-1 ;
-TUPLE: radio-paint color ;
+TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ;
+
+: <radio-paint> ( color -- paint ) radio-paint new swap >>color ;
+
+<PRIVATE
+
+: circle-steps 8 ;
-C: <radio-paint> radio-paint
+PRIVATE>
+
+M: radio-paint recompute-pen
+ swap dim>>
+ [ { 4 4 } swap { 9 9 } v- circle-steps circle-vertices >>interior-vertices ]
+ [ { 1 1 } swap { 3 3 } v- circle-steps circle-vertices >>boundary-vertices ] bi
+ drop ;
+
+<PRIVATE
+
+: (radio-paint) ( gadget paint -- )
+ [ compute-pen ] [ color>> gl-color ] bi ;
+
+PRIVATE>
M: radio-paint draw-interior
- color>> set-color
- origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
+ [ (radio-paint) ] [ interior-vertices>> gl-vertex-pointer ] bi
+ GL_POLYGON 0 circle-steps glDrawArrays ;
M: radio-paint draw-boundary
- color>> set-color
- origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
+ [ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
+ GL_LINE_LOOP 0 circle-steps glDrawArrays ;
-: radio-knob-theme ( gadget -- gadget )
- f
- f
- black <radio-paint>
- black <radio-paint>
- <button-paint> >>interior
- black <radio-paint> >>boundary ;
+:: radio-knob-theme ( gadget -- gadget )
+ [let | radio-paint [ black <radio-paint> ] |
+ gadget
+ f f radio-paint radio-paint <button-paint> >>interior
+ radio-paint >>boundary
+ { 16 16 } >>dim
+ ] ;
: <radio-knob> ( -- gadget )
- <gadget>
- radio-knob-theme
- { 16 16 } >>dim ;
+ <gadget> radio-knob-theme ;
TUPLE: radio-control < button value ;
: draw-caret ( -- )
editor get focused?>> [
editor get
- dup caret-color>> set-color
- dup caret-loc origin get v+
- swap caret-dim over v+
- [ { 0.5 -0.5 } v+ ] bi@ gl-line
+ [ caret-color>> gl-color ]
+ [
+ dup caret-loc origin get v+
+ swap caret-dim over v+
+ gl-line
+ ] bi
] when ;
: line-translation ( n -- loc )
: draw-lines ( -- )
\ first-visible-line get [
- editor get dup color>> set-color
+ editor get dup color>> gl-color
dup visible-lines
[ draw-line 1 translate-lines ] with each
] with-editor-translation ;
dup editor-mark* swap editor-caret* sort-pair ;
: (draw-selection) ( x1 x2 -- )
- 2dup = [ 2 + ] when
- 0.0 swap editor get line-height glRectd ;
+ over -
+ dup 0 = [ 2 + ] when
+ [ 0.0 2array ] [ editor get line-height 2array ] bi*
+ swap [ gl-fill-rect ] with-translation ;
: draw-selected-line ( start end n -- )
[ start/end-on-line ] keep tuck
- >r >r editor get offset>x r> r>
+ [ editor get offset>x ] 2dip
editor get offset>x
(draw-selection) ;
: draw-selection ( -- )
- editor get selection-color>> set-color
+ editor get selection-color>> gl-color
editor get selection-start/end
over first [
2dup [
] with each ;
M: grid-lines draw-boundary
- origin get [
- -0.5 -0.5 0.0 glTranslated
- color>> set-color [
- dup grid set
- dup rect-dim half-gap v- grid-dim set
- compute-grid
- { 0 1 } draw-grid-lines
- { 1 0 } draw-grid-lines
- ] with-scope
- ] with-translation ;
+ color>> gl-color [
+ dup grid set
+ dup rect-dim half-gap v- grid-dim set
+ compute-grid
+ { 0 1 } draw-grid-lines
+ { 1 0 } draw-grid-lines
+ ] with-scope ;
: title-theme ( gadget -- gadget )
{ 1 0 } >>orientation
- T{ gradient f {
+ {
T{ rgba f 0.65 0.65 1.0 1.0 }
T{ rgba f 0.65 0.45 1.0 1.0 }
- } } >>interior ;
+ } <gradient> >>interior ;
: <title-label> ( text -- label ) <label> title-theme ;
: <title-bar> ( title quot -- gadget )
<frame>
- swap dup [ <close-box> @left grid-add ] [ drop ] if
+ swap [ <close-box> @left grid-add ] when*
swap <title-label> @center grid-add ;
TUPLE: closable-gadget < frame content ;
[ font>> open-font ] [ text>> ] bi text-dim ;
M: label draw-gadget*
- [ color>> set-color ]
+ [ color>> gl-color ]
[ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
M: label gadget-text* label-string % ;
M: list draw-gadget*
origin get [
- dup color>> set-color
- selected-rect [ rect-extent gl-fill-rect ] when*
+ dup color>> gl-color
+ selected-rect [
+ dup loc>> [
+ dim>> gl-fill-rect
+ ] with-translation
+ ] when*
] with-translation ;
M: list focusable-child* drop t ;
] if ;
: select-gadget ( gadget list -- )
- swap over children>> index
+ tuck children>> index
[ swap select-index ] [ drop ] if* ;
: clamp-loc ( point max -- point )
>r clip get over intersects? r> [ drop ] if ; inline
M: gadget draw-selection ( loc gadget -- )
- swap offset-rect [ rect-extent gl-fill-rect ] if-fits ;
+ swap offset-rect [
+ dup loc>> [
+ dim>> gl-fill-rect
+ ] with-translation
+ ] if-fits ;
M: node draw-selection ( loc node -- )
2dup value>> swap offset-rect [
M: pane draw-gadget*
dup gadget-selection? [
- dup selection-color>> set-color
+ dup selection-color>> gl-color
origin get over rect-loc v- swap selected-children
[ draw-selection ] with each
] [
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
models models.range models.compose
-combinators math.vectors classes.tuple math.geometry.rect ;
+combinators math.vectors classes.tuple math.geometry.rect
+combinators.short-circuit ;
IN: ui.gadgets.scrollers
TUPLE: scroller < frame viewport x y follows ;
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
- swap over model>> <viewport> >>viewport
+ tuck model>> <viewport> >>viewport
dup viewport>> @center grid-add ;
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
: relative-scroll-rect ( rect gadget scroller -- newrect )
viewport>> gadget-child relative-loc offset-rect ;
-: find-scroller* ( gadget -- scroller )
- dup find-scroller dup [
- 2dup viewport>> gadget-child
- swap child? [ nip ] [ 2drop f ] if
- ] [
- 2drop f
- ] if ;
+: find-scroller* ( gadget -- scroller/f )
+ dup find-scroller
+ { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
+ 2&& ;
: scroll>rect ( rect gadget -- )
dup find-scroller* dup [
: selection-color ( -- color ) light-purple ;
-: plain-gradient
- T{ gradient f {
+: plain-gradient ( -- gradient )
+ {
T{ gray f 0.94 1.0 }
T{ gray f 0.83 1.0 }
T{ gray f 0.83 1.0 }
T{ gray f 0.62 1.0 }
- } } ;
+ } <gradient> ;
-: rollover-gradient
- T{ gradient f {
+: rollover-gradient ( -- gradient )
+ {
T{ gray f 1.0 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 0.75 1.0 }
- } } ;
+ } <gradient> ;
-: pressed-gradient
- T{ gradient f {
+: pressed-gradient ( -- gradient )
+ {
T{ gray f 0.75 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 1.0 1.0 }
- } } ;
+ } <gradient> ;
-: selected-gradient
- T{ gradient f {
+: selected-gradient ( -- gradient )
+ {
T{ gray f 0.65 1.0 }
T{ gray f 0.8 1.0 }
T{ gray f 0.8 1.0 }
T{ gray f 1.0 1.0 }
- } } ;
+ } <gradient> ;
-: lowered-gradient
- T{ gradient f {
+: lowered-gradient ( -- gradient )
+ {
T{ gray f 0.37 1.0 }
T{ gray f 0.43 1.0 }
T{ gray f 0.5 1.0 }
- } } ;
+ } <gradient> ;
: sans-serif-font { "sans-serif" plain 12 } ;
} ;
HELP: <polygon>
-{ $values { "color" "a color specifier" } { "points" "a sequence of points" } }
+{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "polygon" polygon } }
{ $description "Creates a new instance of " { $link polygon } "." } ;
HELP: <polygon-gadget>
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien arrays hashtables io kernel math namespaces opengl
-opengl.gl opengl.glu sequences strings io.styles vectors
-combinators math.vectors ui.gadgets colors
-math.order math.geometry.rect ;
+USING: accessors alien alien.c-types arrays hashtables io kernel
+math namespaces opengl opengl.gl opengl.glu sequences strings
+io.styles vectors combinators math.vectors ui.gadgets colors
+math.order math.geometry.rect locals ;
IN: ui.render
SYMBOL: clip
: init-clip ( clip-rect rect -- )
GL_SCISSOR_TEST glEnable
[ rect-intersect ] keep
- rect-dim dup { 0 1 } v* viewport-translation set
+ dim>> dup { 0 1 } v* viewport-translation set
{ 0 0 } over gl-viewport
- 0 swap first2 0 gluOrtho2D
+ -0.5 swap first2 [ 0.5 - ] [ 0.5 + ] bi* 0.5 gluOrtho2D
clip set
do-clip ;
GL_SMOOTH glShadeModel
GL_BLEND glEnable
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
+ GL_VERTEX_ARRAY glEnableClientState
init-matrices
init-clip
! white gl-clear is broken w.r.t window resizing
! Linux/PPC Radeon 9200
- white set-color
- clip get rect-extent gl-fill-rect ;
+ white gl-color
+ clip get dim>> gl-fill-rect ;
GENERIC: draw-gadget* ( gadget -- )
: (draw-gadget) ( gadget -- )
[
dup translate
- dup dup interior>> draw-interior
+ dup interior>> [
+ origin get [ dupd draw-interior ] with-translation
+ ] when*
dup draw-gadget*
dup visible-children [ draw-gadget ] each
- dup boundary>> draw-boundary
+ dup boundary>> [
+ origin get [ dupd draw-boundary ] with-translation
+ ] when*
+ drop
] with-scope ;
: >absolute ( rect -- rect )
[ [ (draw-gadget) ] with-clipping ]
} cond ;
-! Pen paint properties
-M: f draw-interior 2drop ;
-M: f draw-boundary 2drop ;
+! A pen that caches vertex arrays, etc
+TUPLE: caching-pen last-dim ;
+
+GENERIC: recompute-pen ( gadget pen -- )
+
+: compute-pen ( gadget pen -- )
+ 2dup [ dim>> ] [ last-dim>> ] bi* = [
+ 2drop
+ ] [
+ [ swap dim>> >>last-dim drop ] [ recompute-pen ] 2bi
+ ] if ;
! Solid fill/border
-TUPLE: solid color ;
+TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
-C: <solid> solid
+: <solid> ( color -- solid ) solid new swap >>color ;
+
+M: solid recompute-pen
+ swap dim>>
+ [ (fill-rect-vertices) >>interior-vertices ]
+ [ (rect-vertices) >>boundary-vertices ]
+ bi drop ;
+
+<PRIVATE
! Solid pen
-: (solid) ( gadget paint -- loc dim )
- color>> set-color rect-dim >r origin get dup r> v+ ;
+: (solid) ( gadget pen -- )
+ [ compute-pen ] [ color>> gl-color ] bi ;
+
+PRIVATE>
-M: solid draw-interior (solid) gl-fill-rect ;
+M: solid draw-interior
+ [ (solid) ] [ interior-vertices>> gl-vertex-pointer ] bi
+ (gl-fill-rect) ;
-M: solid draw-boundary (solid) gl-rect ;
+M: solid draw-boundary
+ [ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
+ (gl-rect) ;
! Gradient pen
-TUPLE: gradient colors ;
+TUPLE: gradient < caching-pen colors last-vertices last-colors ;
-C: <gradient> gradient
+: <gradient> ( colors -- gradient ) gradient new swap >>colors ;
+
+<PRIVATE
+
+:: gradient-vertices ( direction dim colors -- seq )
+ direction dim v* dim over v- swap
+ colors length dup 1- v/n [ v*n ] with map
+ [ dup rot v+ 2array ] with map
+ concat concat >c-float-array ;
+
+: gradient-colors ( colors -- seq )
+ [ color>raw 4array dup 2array ] map concat concat >c-float-array ;
+
+M: gradient recompute-pen ( gadget gradient -- )
+ tuck
+ [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi*
+ [ gradient-vertices >>last-vertices ]
+ [ gradient-colors >>last-colors ] bi
+ drop ;
+
+: draw-gradient ( colors -- )
+ GL_COLOR_ARRAY [
+ [ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
+ ] do-enabled-client-state ;
+
+PRIVATE>
M: gradient draw-interior
- origin get [
- over orientation>>
- swap colors>>
- rot rect-dim
- gl-gradient
- ] with-translation ;
+ {
+ [ compute-pen ]
+ [ last-vertices>> gl-vertex-pointer ]
+ [ last-colors>> gl-color-pointer ]
+ [ colors>> draw-gradient ]
+ } cleave ;
! Polygon pen
-TUPLE: polygon color points ;
+TUPLE: polygon color vertex-array count ;
-C: <polygon> polygon
+: <polygon> ( color points -- polygon )
+ [ concat >c-float-array ] [ length ] bi polygon boa ;
-: draw-polygon ( polygon quot -- )
- origin get [
- >r dup color>> set-color points>> r> call
- ] with-translation ; inline
+: draw-polygon ( polygon mode -- )
+ swap
+ [ color>> gl-color ]
+ [ vertex-array>> gl-vertex-pointer ]
+ [ 0 swap count>> glDrawArrays ]
+ tri ;
M: polygon draw-boundary
- [ gl-poly ] draw-polygon drop ;
+ GL_LINE_LOOP draw-polygon drop ;
M: polygon draw-interior
- [ gl-fill-poly ] draw-polygon drop ;
+ dup count>> 2 > GL_POLYGON GL_LINES ?
+ draw-polygon drop ;
: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
deploy-math? get "Rational and complex number support" <checkbox> add-gadget
deploy-threads? get "Threading support" <checkbox> add-gadget
- deploy-random? get "Random number generator support" <checkbox> add-gadget
+ deploy-unicode? get "Unicode character literal support" <checkbox> add-gadget
deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
listener>> input>> interactor-busy? ;
: listener-input ( string -- )
- get-workspace listener>> input>> set-editor-string ;
+ get-workspace listener>> input>>
+ [ set-editor-string ] [ request-focus ] bi ;
: (call-listener) ( quot listener -- )
input>> interactor-call ;
{ $heading "Implementation" }
"Workspaces are instances of " { $link workspace } "." ;
-ARTICLE: "ui-tools" "UI development tools"
+ARTICLE: "ui-tools" "UI developer tools"
"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
$nl
"To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."
IN: unix.groups
HELP: all-groups
-{ $values
-
- { "seq" sequence } }
+{ $values { "seq" sequence } }
{ $description "Returns a sequence of " { $link group } " tuples that are platform-dependent and field for field complete with the Unix " { $link group } " structure." } ;
HELP: effective-group-id
-{ $values
-
- { "string" string } }
+{ $values { "string" string } }
{ $description "Returns the effective group id for the current user." } ;
HELP: effective-group-name
-{ $values
-
- { "string" string } }
+{ $values { "string" string } }
{ $description "Returns the effective group name for the current user." } ;
HELP: group
{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
HELP: real-group-id
-{ $values
-
- { "id" integer } }
+{ $values { "id" integer } }
{ $description "Returns the real group id for the current user." } ;
HELP: real-group-name
-{ $values
-
- { "string" string } }
+{ $values { "string" string } }
{ $description "Returns the real group name for the current user." } ;
HELP: set-effective-group
{ "string/id" "a string or a group id" } { "quot" quotation } }
{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
-ARTICLE: "unix.groups" "unix.groups"
+ARTICLE: "unix.groups" "Unix groups"
"The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
+$nl
"Listing all groups:"
{ $subsection all-groups }
"Returning a passwd tuple:"
[ ] [ effective-group-name [ ] with-effective-group ] unit-test
[ ] [ effective-group-id [ ] with-effective-group ] unit-test
+
+[ ] [ [ ] with-group-cache ] unit-test
FUNCTION: int statfs ( char* path, statfs* buf ) ;
TUPLE: linux32-file-system-info < file-system-info
-type bsize blocks bfree bavail files ffree fsid
-namelen frsize spare ;
+bsize blocks bfree bavail files ffree fsid namelen
+frsize spare ;
M: linux >file-system-info ( struct -- statfs )
[ \ linux32-file-system-info new ] dip
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
TUPLE: linux64-file-system-info < file-system-info
-type bsize blocks bfree bavail files ffree fsid
-namelen frsize spare ;
+bsize blocks bfree bavail files ffree fsid namelen
+frsize spare ;
M: linux >file-system-info ( struct -- statfs )
[ \ linux64-file-system-info new ] dip
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types combinators kernel io.files unix.stat
+USING: alien.c-types combinators kernel unix.stat
math accessors system unix io.backend layouts vocabs.loader
sequences csv io.streams.string io.encodings.utf8 namespaces
unix.statfs io.files ;
] with-scope
[ mtab-csv>mtab-entry ] map ;
-M: linux mounted
+M: linux file-systems
parse-mtab [
[ mount-point>> file-system-info ] keep
{
block-size io-size blocks blocks-free blocks-available files
files-free file-system-id owner type-id flags filesystem-subtype ;
-M: macosx mounted ( -- array )
+M: macosx file-systems ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error
[ *void* ] dip
"statfs64" heap-size [ * memory>byte-array ] keep group
kernel math.order sorting ;
IN: unix.statfs
-TUPLE: file-system-info root-directory total-free-size total-size ;
-
HOOK: >file-system-info os ( struct -- statfs )
-HOOK: mounted os ( -- array )
-
os {
{ linux [ "unix.statfs.linux" require ] }
{ macosx [ "unix.statfs.macosx" require ] }
IN: unix.users
HELP: all-users
-{ $values
-
- { "seq" sequence } }
+{ $values { "seq" sequence } }
{ $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
HELP: effective-username
-{ $values
-
- { "string" string } }
+{ $values { "string" string } }
{ $description "Returns the effective username for the current user." } ;
HELP: effective-user-id
-{ $values
-
- { "id" integer } }
+{ $values { "id" integer } }
{ $description "Returns the effective username id for the current user." } ;
HELP: new-passwd
-{ $values
-
- { "passwd" passwd } }
+{ $values { "passwd" passwd } }
{ $description "Creates a new passwd tuple dependent on the operating system." } ;
HELP: passwd
{ $description "A platform-specific tuple correspding to every field from the Unix passwd struct. BSD passwd structures have four extra slots: " { $slot "change" } ", " { $slot "class" } "," { $slot "expire" } ", " { $slot "fields" } "." } ;
-HELP: passwd-cache
-{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-passwd-cache } "." } ;
+HELP: user-cache
+{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-user-cache } "." } ;
HELP: passwd>new-passwd
{ $values
{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
HELP: real-username
-{ $values
-
- { "string" string } }
+{ $values { "string" string } }
{ $description "The real username of the current user." } ;
HELP: real-user-id
-{ $values
-
- { "id" integer } }
+{ $values { "id" integer } }
{ $description "The real user id of the current user." } ;
HELP: set-effective-user
-{ $values
- { "string/id" "a string or a user id" } }
+{ $values { "string/id" "a string or a user id" } }
{ $description "Sets the current effective user given a username or a user id." } ;
HELP: set-real-user
-{ $values
- { "string/id" "a string or a user id" } }
+{ $values { "string/id" "a string or a user id" } }
{ $description "Sets the current real user given a username or a user id." } ;
HELP: user-passwd
{ "string/id" "a string or a uid" } { "quot" quotation } }
{ $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
-HELP: with-passwd-cache
+HELP: with-user-cache
{ $values
{ "quot" quotation } }
-{ $description "Iterates over the password file using library calls and creates a cache in the " { $link passwd-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
+{ $description "Iterates over the password file using library calls and creates a cache in the " { $link user-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
HELP: with-real-user
{ $values
set-effective-user
} related-words
-ARTICLE: "unix.users" "unix.users"
+ARTICLE: "unix.users" "Unix users"
"The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
+$nl
"Listing all users:"
{ $subsection all-users }
"Returning a passwd tuple:"
[ ] [ effective-username [ ] with-effective-user ] unit-test
[ ] [ effective-user-id [ ] with-effective-user ] unit-test
+
+[ ] [ [ ] with-user-cache ] unit-test
[ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce
] with-pwent ;
-SYMBOL: passwd-cache
+SYMBOL: user-cache
-: with-passwd-cache ( quot -- )
+: with-user-cache ( quot -- )
all-users [ [ uid>> ] keep ] H{ } map>assoc
- passwd-cache swap with-variable ; inline
+ user-cache rot with-variable ; inline
GENERIC: user-passwd ( obj -- passwd )
M: integer user-passwd ( id -- passwd/f )
- passwd-cache get
+ user-cache get
[ at ] [ getpwuid passwd>new-passwd ] if* ;
M: string user-passwd ( string -- passwd/f )
! FUNCTION: GetDllDirectoryA
! FUNCTION: GetDllDirectoryW
! FUNCTION: GetDriveTypeA
-! FUNCTION: GetDriveTypeW
+FUNCTION: UINT GetDriveTypeW ( LPCTSTR lpRootPathName ) ;
+ALIAS: GetDriveType GetDriveTypeW
FUNCTION: void* GetEnvironmentStringsW ( ) ;
! FUNCTION: GetEnvironmentStringsA
ALIAS: GetEnvironmentStrings GetEnvironmentStringsW
! FUNCTION: GetLocaleInfoA
! FUNCTION: GetLocaleInfoW
! FUNCTION: GetLocalTime
-! FUNCTION: GetLogicalDrives
+FUNCTION: DWORD GetLogicalDrives ( ) ;
! FUNCTION: GetLogicalDriveStringsA
! FUNCTION: GetLogicalDriveStringsW
! FUNCTION: GetLongPathNameA
! FUNCTION: GetVolumeNameForVolumeMountPointW
! FUNCTION: GetVolumePathNameA
! FUNCTION: GetVolumePathNamesForVolumeNameA
-! FUNCTION: GetVolumePathNamesForVolumeNameW
+FUNCTION: BOOL GetVolumePathNamesForVolumeNameW ( LPCTSTR lpszVolumeName, LPTSTR lpszVolumePathNames, DWORD cchBufferLength, PDWORD lpcchReturnLength ) ;
+ALIAS: GetVolumePathNamesForVolumeName GetVolumePathNamesForVolumeNameW
+
! FUNCTION: GetVolumePathNameW
! FUNCTION: GetWindowsDirectoryA
FUNCTION: UINT GetWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
GCC_VERSION=`$CC --version`
check_ret gcc
if [[ $GCC_VERSION == *3.3.* ]] ; then
- $ECHO "bad!"
$ECHO "You have a known buggy version of gcc (3.3)"
$ECHO "Install gcc 3.4 or higher and try again."
exit 3
+ elif [[ $GCC_VERSION == *4.3.* ]] ; then
+ MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate"
fi
$ECHO "ok."
}
*FreeBSD*) OS=freebsd;;
*OpenBSD*) OS=openbsd;;
*DragonFly*) OS=dragonflybsd;;
- SunOS) OS=solaris;;
+ SunOS) OS=solaris;;
esac
}
$ECHO "WORD: $WORD"
$ECHO "OS, ARCH, or WORD is empty. Please report this."
- echo $MAKE_TARGET
+ echo $MAKE_TARGET
exit 5
fi
}
set_build_info() {
check_os_arch_word
- MAKE_TARGET=$OS-$ARCH-$WORD
- MAKE_IMAGE_TARGET=$ARCH.$WORD
- BOOT_IMAGE=boot.$ARCH.$WORD.image
if [[ $OS == macosx && $ARCH == ppc ]] ; then
- MAKE_IMAGE_TARGET=$OS-$ARCH
- MAKE_TARGET=$OS-$ARCH
- BOOT_IMAGE=boot.macosx-ppc.image
- fi
- if [[ $OS == linux && $ARCH == ppc ]] ; then
- MAKE_IMAGE_TARGET=$OS-$ARCH
- MAKE_TARGET=$OS-$ARCH
- BOOT_IMAGE=boot.linux-ppc.image
+ MAKE_IMAGE_TARGET=macosx-ppc
+ MAKE_TARGET=macosx-ppc
+ elif [[ $OS == linux && $ARCH == ppc ]] ; then
+ MAKE_IMAGE_TARGET=linux-ppc
+ MAKE_TARGET=linux-ppc
+ elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
+ MAKE_IMAGE_TARGET=winnt-x86.64
+ MAKE_TARGET=winnt-x86-64
+ elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
+ MAKE_IMAGE_TARGET=unix-x86.64
+ MAKE_TARGET=$OS-x86-64
+ else
+ MAKE_IMAGE_TARGET=$ARCH.$WORD
+ MAKE_TARGET=$OS-$ARCH-$WORD
fi
+ BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image
}
parse_build_info() {
check_ret cd
}
+check_makefile_exists() {
+ if [[ ! -e "Makefile" ]] ; then
+ echo ""
+ echo "***Makefile not found***"
+ echo "You are likely in the wrong directory."
+ echo "Run this script from your factor directory:"
+ echo " ./build-support/factor.sh"
+ exit 6
+ fi
+}
+
invoke_make() {
- $MAKE $*
- check_ret $MAKE
+ check_makefile_exists
+ $MAKE $MAKE_OPTS $*
+ check_ret $MAKE
}
make_clean() {
8 num-tags set
3 tag-bits set
-18 num-types set
+17 num-types set
H{
{ fixnum BIN: 000 }
{ byte-array 10 }
{ callstack 11 }
{ string 12 }
- { tuple-layout 13 }
+ { word 13 }
{ quotation 14 }
{ dll 15 }
{ alien 16 }
- { word 17 }
} assoc-union type-numbers set
"resource:basis/cpu/" architecture get {
{ "x86.32" "x86/32" }
- { "x86.64" "x86/64" }
+ { "winnt-x86.64" "x86/64/winnt" }
+ { "unix-x86.64" "x86/64/unix" }
{ "linux-ppc" "ppc/linux" }
{ "macosx-ppc" "ppc/macosx" }
{ "arm" "arm" }
H{ } clone new-classes set
H{ } clone changed-definitions set
H{ } clone changed-generics set
+H{ } clone remake-generics set
H{ } clone forgotten-definitions set
H{ } clone root-cache set
H{ } clone source-files set
"io.files"
"io.files.private"
"io.streams.c"
+ "locals.backend"
"kernel"
"kernel.private"
"math"
"alien" "alien" create register-builtin
"word" "words" create register-builtin
"byte-array" "byte-arrays" create register-builtin
-"tuple-layout" "classes.tuple.private" create register-builtin
! For predicate classes
"predicate-instance?" "classes.predicate" create drop
"callstack" "kernel" create { } define-builtin
-"tuple-layout" "classes.tuple.private" create {
- { "hashcode" { "fixnum" "math" } read-only }
- { "class" { "word" "words" } initial: t read-only }
- { "size" { "fixnum" "math" } read-only }
- { "superclasses" { "array" "arrays" } initial: { } read-only }
- { "echelon" { "fixnum" "math" } read-only }
-} define-builtin
-
"tuple" "kernel" create
[ { } define-builtin ]
[ define-tuple-layout ]
{ "fixnum-bitor" "math.private" }
{ "fixnum-bitxor" "math.private" }
{ "fixnum-bitnot" "math.private" }
+ { "fixnum-mod" "math.private" }
+ { "fixnum-shift-fast" "math.private" }
{ "fixnum<" "math.private" }
{ "fixnum<=" "math.private" }
{ "fixnum>" "math.private" }
{ "eq?" "kernel" }
{ "tag" "kernel.private" }
{ "slot" "slots.private" }
+ { "get-local" "locals.backend" }
+ { "drop-locals" "locals.backend" }
} [ make-sub-primitive ] assoc-each
! Primitive words
{ "fixnum-" "math.private" }
{ "fixnum*" "math.private" }
{ "fixnum/i" "math.private" }
- { "fixnum-mod" "math.private" }
{ "fixnum/mod" "math.private" }
{ "fixnum-shift" "math.private" }
- { "fixnum-shift-fast" "math.private" }
{ "bignum=" "math.private" }
{ "bignum+" "math.private" }
{ "bignum-" "math.private" }
{ "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" }
{ "<tuple>" "classes.tuple.private" }
- { "<tuple-layout>" "classes.tuple.private" }
{ "profiling" "tools.profiler.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }
1 exit
] if
] %
-] [ ] make bootstrap-boot-quot set
+] [ ] make
+bootstrap-boot-quot set
: 2cache ( key1 key2 assoc quot -- value )\r
>r >r 2array r> [ first2 ] r> compose cache ; inline\r
\r
+GENERIC: valid-class? ( obj -- ? )\r
+\r
+M: class valid-class? drop t ;\r
+M: anonymous-union valid-class? members>> [ valid-class? ] all? ;\r
+M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;\r
+M: anonymous-complement valid-class? class>> valid-class? ;\r
+M: word valid-class? drop f ;\r
+\r
DEFER: (class<=)\r
\r
: class<= ( first second -- ? )\r
class-or-cache get [ (class-or) ] 2cache ;\r
\r
: superclass<= ( first second -- ? )\r
- >r superclass r> class<= ;\r
+ swap superclass dup [ swap class<= ] [ 2drop f ] if ;\r
\r
: left-anonymous-union<= ( first second -- ? )\r
>r members>> r> [ class<= ] curry all? ;\r
\r
: (class<=) ( first second -- -1/0/1 )\r
2dup eq? [ 2drop t ] [\r
- [ normalize-class ] bi@ {\r
- { [ dup empty-intersection? ] [ 2drop t ] }\r
- { [ over empty-union? ] [ 2drop t ] }\r
- { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }\r
- { [ over anonymous-union? ] [ left-anonymous-union<= ] }\r
- { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }\r
- { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }\r
- { [ dup anonymous-union? ] [ right-anonymous-union<= ] }\r
- { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }\r
- { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }\r
- { [ over superclass ] [ superclass<= ] }\r
- [ 2drop f ]\r
- } cond\r
+ 2dup superclass<= [ 2drop t ] [\r
+ [ normalize-class ] bi@ {\r
+ { [ dup empty-intersection? ] [ 2drop t ] }\r
+ { [ over empty-union? ] [ 2drop t ] }\r
+ { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }\r
+ { [ over anonymous-union? ] [ left-anonymous-union<= ] }\r
+ { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }\r
+ { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }\r
+ { [ dup anonymous-union? ] [ right-anonymous-union<= ] }\r
+ { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }\r
+ { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }\r
+ [ 2drop f ]\r
+ } cond\r
+ ] if\r
] if ;\r
\r
M: anonymous-union (classes-intersect?)\r
USING: alien arrays definitions generic assocs hashtables io
-kernel math namespaces parser prettyprint sequences strings
-tools.test vectors words quotations classes
+io.streams.string kernel math namespaces parser prettyprint
+sequences strings tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
-classes.algebra vectors definitions source-files
-compiler.units kernel.private sorting vocabs ;
+classes.algebra vectors definitions source-files compiler.units
+kernel.private sorting vocabs memory eval accessors ;
IN: classes.tests
[ t ] [ 3 object instance? ] unit-test
implementors-map get keys
[ natural-sort ] bi@ =
] unit-test
+
+! Minor leak
+[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval ] unit-test
+[ ] [ f \ word set-global ] unit-test
+[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval ] unit-test
+[ ] [ "IN: classes.tests FORGET: forget-me" eval ] unit-test
+[ 0 ] [
+ [ word? ] instances
+ [ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count
+] unit-test
+
+! Long-standing problem
+USE: multiline
+
+! So the user has some code...
+[ ] [
+ <" IN: classes.test.a
+ GENERIC: g ( a -- b )
+ TUPLE: x ;
+ M: x g ;
+ TUPLE: z < x ;"> <string-reader>
+ "class-intersect-no-method-a" parse-stream drop
+] unit-test
+
+! Note that q inlines M: x g ;
+[ ] [
+ <" IN: classes.test.b
+ USE: classes.test.a
+ USE: kernel
+ : q ( -- b ) z new g ;"> <string-reader>
+ "class-intersect-no-method-b" parse-stream drop
+] unit-test
+
+! Now, the user removes the z class and adds a method,
+[ ] [
+ <" IN: classes.test.a
+ GENERIC: g ( a -- b )
+ TUPLE: x ;
+ M: x g ;
+ TUPLE: j ;
+ M: j g ;"> <string-reader>
+ "class-intersect-no-method-a" parse-stream drop
+] unit-test
+
+! And changes the definition of q
+[ ] [
+ <" IN: classes.test.b
+ USE: classes.test.a
+ USE: kernel
+ : q ( -- b ) j new g ;"> <string-reader>
+ "class-intersect-no-method-b" parse-stream drop
+] unit-test
+
+! Similar problem, but with anonymous classes
+[ ] [
+ <" IN: classes.test.c
+ USE: kernel
+ GENERIC: g ( a -- b )
+ M: object g ;
+ TUPLE: z ;"> <string-reader>
+ "class-intersect-no-method-c" parse-stream drop
+] unit-test
+
+[ ] [
+ <" IN: classes.test.d
+ USE: classes.test.c
+ USE: kernel
+ : q ( a -- b ) dup z? [ g ] unless ;"> <string-reader>
+ "class-intersect-no-method-d" parse-stream drop
+] unit-test
+
+! Now, the user removes the z class and adds a method,
+[ ] [
+ <" IN: classes.test.c
+ USE: kernel
+ GENERIC: g ( a -- b )
+ M: object g ;
+ TUPLE: j ;
+ M: j g ;"> <string-reader>
+ "class-intersect-no-method-c" parse-stream drop
+] unit-test
+
+TUPLE: forgotten-predicate-test ;
+
+[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
+[ f ] [ \ forgotten-predicate-test? predicate? ] unit-test
SYMBOL: implementors-map
-PREDICATE: class < word
- "class" word-prop ;
+PREDICATE: class < word "class" word-prop ;
: classes ( -- seq ) implementors-map get keys ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
+M: predicate reset-word
+ [ call-next-method ] [ { "predicating" } reset-props ] bi ;
+
: define-predicate ( class quot -- )
- >r "predicate" word-prop first
- r> (( object -- ? )) define-declared ;
+ [ "predicate" word-prop first ] dip
+ (( object -- ? )) define-declared ;
: superclass ( class -- super )
#! Output f for non-classes to work with algebra code
] H{ } make-assoc ;
: (define-class) ( word props -- )
- >r
- dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
- dup reset-class
- dup deferred? [ dup define-symbol ] when
- dup redefined
- dup props>>
- r> assoc-union >>props
+ [
+ dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
+ dup reset-class
+ dup deferred? [ dup define-symbol ] when
+ dup redefined
+ dup props>>
+ ] dip assoc-union >>props
dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
[ implementors-map- ]
[ update-map- ]
[ reset-class ]
- } cleave ;
+ } cleave
+ reset-caches ;
M: class class-forgotten
nip forget-class ;
: update-classes/new ( mixin -- )
class-usages
[ [ update-class ] each ]
- [ implementors [ make-generic ] each ] bi ;
+ [ implementors [ remake-generic ] each ] bi ;
: add-mixin-instance ( class mixin -- )
#! Note: we call update-classes on the new member, not the
--- /dev/null
+USING: math tools.test classes.algebra ;
+IN: classes.predicate
+
+PREDICATE: negative < integer 0 < ;
+PREDICATE: positive < integer 0 > ;
+
+[ t ] [ negative integer class< ] unit-test
+[ t ] [ positive integer class< ] unit-test
+[ f ] [ integer negative class< ] unit-test
+[ f ] [ integer positive class< ] unit-test
+[ f ] [ negative negative class< ] unit-test
+[ f ] [ positive negative class< ] unit-test
+
+GENERIC: abs ( n -- n )
+M: integer abs ;
+M: negative abs -1 * ;
+M: positive abs ;
+
+[ 10 ] [ -10 abs ] unit-test
+[ 10 ] [ 10 abs ] unit-test
+[ 0 ] [ 0 abs ] unit-test
"}"
} "\n" join eval
] unit-test
+
+[ T{ parsing-corner-case f 3 } ] [
+ {
+ "USE: classes.tuple.parser.tests"
+ "T{ parsing-corner-case"
+ " { x 3 }"
+ "}"
+ } "\n" join eval
+] unit-test
+
+[ T{ parsing-corner-case f 3 } ] [
+ {
+ "USE: classes.tuple.parser.tests"
+ "T{ parsing-corner-case {"
+ " x 3 }"
+ "}"
+ } "\n" join eval
+] unit-test
+
+
+[
+ {
+ "USE: classes.tuple.parser.tests T{ parsing-corner-case"
+ " { x 3 }"
+ } "\n" join eval
+] [ error>> unexpected-eof? ] must-fail-with
+
+[
+ {
+ "USE: classes.tuple.parser.tests T{ parsing-corner-case {"
+ " x 3 }"
+ } "\n" join eval
+] [ error>> unexpected-eof? ] must-fail-with
dup check-duplicate-slots
3dup check-slot-shadowing ;
-: parse-slot-value ( -- )
- scan scan-object 2array , scan "}" assert= ;
-
ERROR: bad-literal-tuple ;
+: parse-slot-value ( -- )
+ scan scan-object 2array , scan {
+ { f [ unexpected-eof ] }
+ { "}" [ ] }
+ [ bad-literal-tuple ]
+ } case ;
+
: (parse-slot-values) ( -- )
parse-slot-value
scan {
+ { f [ unexpected-eof ] }
{ "{" [ (parse-slot-values) ] }
{ "}" [ ] }
[ bad-literal-tuple ]
{ $list
{ { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
{ { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
- { { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
+ { { $snippet "\"tuple-layout\"" } " - an array with the tuple size and superclasses encoded in a format amneable to fast method dispatch" }
} } ;
HELP: define-tuple-predicate
{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
HELP: <tuple> ( layout -- tuple )
-{ $values { "layout" tuple-layout } { "tuple" tuple } }
+{ $values { "layout" "a tuple layout array" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple )
-{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
+{ $values { "..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
HELP: new
[ t ] [
T{ size-test } tuple-size
- size-test tuple-layout size>> =
+ size-test tuple-layout second =
] unit-test
GENERIC: <yo-momma>
test-laptop-slot-values
-[ laptop ] [
- "laptop" get 1 slot
- dup echelon>> swap
- superclasses>> nth
-] unit-test
-
[ "TUPLE: laptop < computer battery ;" ] [
[ \ laptop see ] with-string-writer string-lines second
] unit-test
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
-M: tuple class 1 slot 2 slot { word } declare ;
-
ERROR: not-a-tuple object ;
: check-tuple ( object -- tuple )
"layout" word-prop ;
: layout-of ( tuple -- layout )
- 1 slot { tuple-layout } declare ; inline
+ 1 slot { array } declare ; inline
+
+M: tuple class layout-of 2 slot { word } declare ;
: tuple-size ( tuple -- size )
- layout-of size>> ; inline
+ layout-of second ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
- class>> prefix ;
+ first prefix ;
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
2drop f
] if ; inline
-: tuple-instance? ( object class echelon -- ? )
- #! 4 slot == superclasses>>
+: tuple-instance-1? ( object class -- ? )
+ swap dup tuple? [
+ layout-of 7 slot eq?
+ ] [ 2drop f ] if ; inline
+
+: tuple-instance? ( object class offset -- ? )
rot dup tuple? [
- layout-of 4 slot { array } declare
- 2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if
+ layout-of
+ 2dup 1 slot fixnum<=
+ [ swap slot eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline
+: layout-class-offset ( echelon -- n )
+ 2 * 5 + ;
+
+: echelon-of ( class -- n )
+ tuple-layout third ;
+
: define-tuple-predicate ( class -- )
- dup dup tuple-layout echelon>>
- [ tuple-instance? ] 2curry define-predicate ;
+ dup dup echelon-of {
+ { 1 [ [ tuple-instance-1? ] curry ] }
+ [ layout-class-offset [ tuple-instance? ] 2curry ]
+ } case define-predicate ;
: class-size ( class -- n )
superclasses [ "slots" word-prop length ] sigma ;
define-accessors ;
: make-tuple-layout ( class -- layout )
- [ ]
- [ [ superclass class-size ] [ "slots" word-prop length ] bi + ]
- [ superclasses dup length 1- ] tri
- <tuple-layout> ;
+ [
+ {
+ [ , ]
+ [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
+ [ superclasses length 1- , ]
+ [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
+ } cleave
+ ] { } make ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
[ first3 update-slot ] with map ;
: permute-slots ( old-values layout -- new-values )
- [ class>> all-slots ] [ outdated-tuples get at ] bi
+ [ first all-slots ] [ outdated-tuples get at ] bi
compute-slot-permutation
apply-slot-permutation ;
: update-tuple ( tuple -- newtuple )
[ tuple-slots ] [ layout-of ] bi
- [ permute-slots ] [ class>> ] bi
+ [ permute-slots ] [ first ] bi
slots>tuple ;
: outdated-tuple? ( tuple assoc -- ? )
M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
- dup tuple-layout echelon>> tuple-instance? ;
+ dup echelon-of layout-class-offset tuple-instance? ;
M: tuple-class (flatten-class) dup set ;
2dup key? [ over redefine-error ] when conjoin ;
: (remember-definition) ( definition loc assoc -- )
- >r over set-where r> add-once ;
+ [ over set-where ] dip add-once ;
: remember-definition ( definition loc -- )
new-definitions get first (remember-definition) ;
: remember-class ( class loc -- )
- over new-definitions get first key? [ dup redefine-error ] when
+ [ dup new-definitions get first key? [ dup redefine-error ] when ] dip
new-definitions get second (remember-definition) ;
: forward-reference? ( word -- ? )
SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
+SYMBOL: remake-generics-hook
: dependency>= ( how1 how2 -- ? )
[
compiled-generic-crossref get at ;
: (compiled-generic-usages) ( generic class -- assoc )
- dup class? [
- [ compiled-generic-usage ] dip
- [ classes-intersect? nip ] curry assoc-filter
- ] [ 2drop f ] if ;
+ [ compiled-generic-usage ] dip
+ [
+ 2dup [ valid-class? ] both?
+ [ classes-intersect? ] [ 2drop f ] if nip
+ ] curry assoc-filter ;
: compiled-generic-usages ( assoc -- assocs )
[ (compiled-generic-usages) ] { } assoc>map ;
: call-recompile-hook ( -- )
to-recompile recompile-hook get call ;
+: call-remake-generics-hook ( -- )
+ remake-generics-hook get call ;
+
: call-update-tuples-hook ( -- )
update-tuples-hook get call ;
[ delete-compiled-xref ] each ;
: finish-compilation-unit ( -- )
+ call-remake-generics-hook
call-recompile-hook
call-update-tuples-hook
unxref-forgotten-definitions
[
H{ } clone changed-definitions set
H{ } clone changed-generics set
+ H{ } clone remake-generics set
H{ } clone outdated-tuples set
H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
[
H{ } clone changed-definitions set
H{ } clone changed-generics set
+ H{ } clone remake-generics set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
H{ } clone new-classes set
SYMBOL: flushed-dependency
SYMBOL: called-dependency
+<PRIVATE
+
+: set-in-unit ( value key assoc -- )
+ [ set-at ] [ no-compilation-unit ] if* ;
+
+PRIVATE>
+
SYMBOL: changed-definitions
: changed-definition ( defspec -- )
- inlined-dependency swap changed-definitions get
- [ set-at ] [ no-compilation-unit ] if* ;
+ inlined-dependency swap changed-definitions get set-in-unit ;
SYMBOL: changed-generics
: changed-generic ( class generic -- )
- changed-generics get
- [ set-at ] [ no-compilation-unit ] if* ;
+ changed-generics get set-in-unit ;
+
+SYMBOL: remake-generics
+
+: remake-generic ( generic -- )
+ dup remake-generics get set-in-unit ;
SYMBOL: new-classes
: new-class ( word -- )
- dup new-classes get
- [ set-at ] [ no-compilation-unit ] if* ;
+ dup new-classes get set-in-unit ;
: new-class? ( word -- ? )
new-classes get key? ;
USING: help.markup help.syntax words classes classes.algebra
definitions kernel alien sequences math quotations
-generic.standard generic.math combinators ;
+generic.standard generic.math combinators prettyprint ;
IN: generic
ARTICLE: "method-order" "Method precedence"
"Low-level method constructor:"
{ $subsection <method> }
"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
-{ $subsection method-spec } ;
+{ $subsection method-spec }
+{ $see-also see see-methods } ;
ARTICLE: "method-combination" "Custom method combination"
"Abstractly, a generic word can be thought of as a big chain of type conditional tests applied to the top of the stack, with methods as the bodies of each test. The " { $emphasis "method combination" } " is this control flow glue between the set of methods, and several aspects of it can be customized:"
USING: accessors words kernel sequences namespaces make assocs
hashtables definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects combinators
-sets ;
+sets compiler.units ;
IN: generic
! Method combination protocol
[ dup "combination" word-prop perform-combination ]
bi ;
+[
+ remake-generics get keys
+ [ generic? ] filter [ make-generic ] each
+] remake-generics-hook set-global
+
: method ( class generic -- method/f )
"methods" word-prop at ;
: with-methods ( class generic quot -- )
[ drop changed-generic ]
[ [ "methods" word-prop ] dip call ]
- [ drop make-generic drop ]
+ [ drop remake-generic drop ]
3tri ; inline
: method-word-name ( class word -- string )
M: sequence update-methods ( class seq -- )
implementors [
- [ changed-generic ] [ make-generic drop ] 2bi
+ [ changed-generic ] [ remake-generic drop ] 2bi
] with each ;
: define-generic ( word combination -- )
over "methods" word-prop values forget-all
over H{ } clone "methods" set-word-prop
dupd define-default-method
- ] if make-generic ;
+ ] if remake-generic ;
M: generic subwords
[
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
: create-method-in ( class generic -- method )
- create-method f set-word dup save-location ;
+ create-method dup set-word dup save-location ;
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
: with-method-definition ( quot -- parsed )
[
- >r
- [ "method-class" word-prop current-class set ]
- [ "method-generic" word-prop current-generic set ]
- [ ] tri
- r> call
+ [
+ [ "method-class" word-prop current-class set ]
+ [ "method-generic" word-prop current-generic set ]
+ [ ] tri
+ ] dip call
] with-scope ; inline
: (M:) ( method def -- )
USING: classes.private generic.standard.engines namespaces make
arrays assocs sequences.private quotations kernel.private
math slots.private math.private kernel accessors words
-layouts ;
+layouts sorting sequences ;
IN: generic.standard.engines.tag
TUPLE: lo-tag-dispatch-engine methods ;
] if ;
M: lo-tag-dispatch-engine engine>quot
- methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
+ methods>> engines>quots*
+ [ >r lo-tag-number r> ] assoc-map
[
picker % [ tag ] % [
+ >alist sort-keys reverse
linear-dispatch-quot
] [
num-tags get direct-dispatch-quot
: num-hi-tags ( -- n ) num-types get num-tags get - ;
: hi-tag-number ( class -- n )
- "type" word-prop num-tags get - ;
+ "type" word-prop ;
: hi-tag-quot ( -- quot )
- [ 0 slot ] num-tags get [ fixnum-fast ] curry compose ;
+ \ hi-tag def>> ;
M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
picker % hi-tag-quot % [
linear-dispatch-quot
] [
+ num-tags get , \ fixnum-fast ,
+ [ >r num-tags get - r> ] assoc-map
num-hi-tags direct-dispatch-quot
] if-small? %
] [ ] make ;
quotations arrays definitions ;
IN: generic.standard.engines.tuple
+: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline
+
+: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline
+
+: tuple-layout% ( -- )
+ [ { tuple } declare 1 slot { array } declare ] % ; inline
+
+: tuple-layout-echelon% ( -- )
+ [ 4 slot ] % ; inline
+
TUPLE: echelon-dispatch-engine n methods ;
C: <echelon-dispatch-engine> echelon-dispatch-engine
-TUPLE: trivial-tuple-dispatch-engine methods ;
+TUPLE: trivial-tuple-dispatch-engine n methods ;
C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
TUPLE: tuple-dispatch-engine echelons ;
: push-echelon ( class method assoc -- )
- >r swap dup "layout" word-prop echelon>> r>
+ [ swap dup "layout" word-prop third ] dip
[ ?set-at ] change-at ;
: echelon-sort ( assoc -- assoc' )
\ <tuple-dispatch-engine> convert-methods ;
M: trivial-tuple-dispatch-engine engine>quot
- methods>> engines>quots* linear-dispatch-quot ;
+ [ n>> ] [ methods>> ] bi dup assoc-empty? [
+ 2drop default get [ drop ] prepend
+ ] [
+ [
+ [ nth-superclass% ]
+ [ engines>quots* linear-dispatch-quot % ] bi*
+ ] [ ] make
+ ] if ;
-: hash-methods ( methods -- buckets )
+: hash-methods ( n methods -- buckets )
>alist V{ } clone [ hashcode 1array ] distribute-buckets
- [ <trivial-tuple-dispatch-engine> ] map ;
+ [ <trivial-tuple-dispatch-engine> ] with map ;
-: word-hashcode% ( -- ) [ 1 slot ] % ;
-
-: class-hash-dispatch-quot ( methods -- quot )
+: class-hash-dispatch-quot ( n methods -- quot )
[
\ dup ,
- word-hashcode%
- hash-methods [ engine>quot ] map hash-dispatch-quot %
+ [ drop nth-hashcode% ]
+ [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi
] [ ] make ;
: engine-word-name ( -- string )
dup generic get "tuple-dispatch-generic" set-word-prop ;
: define-engine-word ( quot -- word )
- >r <engine-word> dup r> define ;
-
-: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
-
-: tuple-layout-superclasses% ( -- )
- [
- { tuple } declare
- 1 slot { tuple-layout } declare
- 4 slot { array } declare
- ] % ; inline
+ [ <engine-word> dup ] dip define ;
: tuple-dispatch-engine-body ( engine -- quot )
[
picker %
- tuple-layout-superclasses%
- [ n>> array-nth% ]
- [
- methods>> [
- <trivial-tuple-dispatch-engine> engine>quot
- ] [
- class-hash-dispatch-quot
- ] if-small? %
- ] bi
+ tuple-layout%
+ [ n>> ] [ methods>> ] bi
+ [ <trivial-tuple-dispatch-engine> engine>quot ]
+ [ class-hash-dispatch-quot ]
+ if-small? %
] [ ] make ;
M: echelon-dispatch-engine engine>quot
methods>> dup assoc-empty?
[ drop default get ] [ values first engine>quot ] if
] [
- [
- picker %
- tuple-layout-superclasses%
- [ n>> array-nth% ]
- [
- methods>> [
- <trivial-tuple-dispatch-engine> engine>quot
- ] [
- class-hash-dispatch-quot
- ] if-small? %
- ] bi
- ] [ ] make
+ tuple-dispatch-engine-body
] if ;
-: >=-case-quot ( alist -- quot )
- default get [ drop ] prepend swap
+: >=-case-quot ( default alist -- quot )
+ [ [ drop ] prepend ] dip
[
[ [ dup ] swap [ fixnum>= ] curry compose ]
[ [ drop ] prepose ]
] assoc-map
alist>quot ;
-: tuple-layout-echelon% ( -- )
+: simplify-echelon-alist ( default alist -- default' alist' )
+ dup empty? [
+ dup first first 1 <= [
+ nip unclip second swap
+ simplify-echelon-alist
+ ] when
+ ] unless ;
+
+: echelon-case-quot ( alist -- quot )
+ #! We don't have to test for echelon 1 since all tuple
+ #! classes are at least at depth 1 in the inheritance
+ #! hierarchy.
+ default get swap simplify-echelon-alist
[
- { tuple } declare
- 1 slot { tuple-layout } declare
- 5 slot
- ] % ; inline
+ [
+ picker %
+ tuple-layout%
+ tuple-layout-echelon%
+ >=-case-quot %
+ ] [ ] make
+ ] unless-empty ;
M: tuple-dispatch-engine engine>quot
[
- picker %
- tuple-layout-echelon%
[
tuple assumed set
- echelons>> dup empty? [
- unclip-last
+ echelons>> unclip-last
+ [
[
- [
- engine>quot define-engine-word
+ engine>quot
+ over 0 = [
+ define-engine-word
[ remember-engine ] [ 1quotation ] bi
- dup default set
- ] assoc-map
- ]
- [ first2 engine>quot 2array ] bi*
- suffix
- ] unless
+ ] unless
+ dup default set
+ ] assoc-map
+ ]
+ [ first2 engine>quot 2array ] bi*
+ suffix
] with-scope
- >=-case-quot %
+ echelon-case-quot %
] [ ] make ;
{ $examples
"A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
{ $code
- "G: build-string 1 standard-combination ;"
+ "GENERIC# build-string 1 ( elt str -- )"
"M: string build-string swap push-all ;"
"M: integer build-string push ;"
}
[ 1quotation ] [ extra-values \ drop <repetition> ] bi*
prepend [ ] like ;
+: <standard-engine> ( word -- engine )
+ object bootstrap-word assumed set {
+ [ generic set ]
+ [ "engines" word-prop forget-all ]
+ [ V{ } clone "engines" set-word-prop ]
+ [
+ "methods" word-prop
+ [ generic get mangle-method ] assoc-map
+ [ find-default default set ]
+ [ <big-dispatch-engine> ]
+ bi
+ ]
+ } cleave ;
+
: single-combination ( word -- quot )
- [
- object bootstrap-word assumed set {
- [ generic set ]
- [ "engines" word-prop forget-all ]
- [ V{ } clone "engines" set-word-prop ]
- [
- "methods" word-prop
- [ generic get mangle-method ] assoc-map
- [ find-default default set ]
- [ <big-dispatch-engine> ]
- bi engine>quot
- ]
- } cleave
- ] with-scope ;
+ [ <standard-engine> engine>quot ] with-scope ;
ERROR: inconsistent-next-method class generic ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
-accessors ;
+sequences.private accessors ;
IN: grouping
-TUPLE: abstract-groups { seq read-only } { n read-only } ;
+<PRIVATE
+
+TUPLE: chunking-seq { seq read-only } { n read-only } ;
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
GENERIC: group@ ( n groups -- from to seq )
-M: abstract-groups nth group@ subseq ;
+M: chunking-seq set-nth group@ <slice> 0 swap copy ;
-M: abstract-groups set-nth group@ <slice> 0 swap copy ;
+M: chunking-seq like drop { } like ;
-M: abstract-groups like drop { } like ;
+INSTANCE: chunking-seq sequence
-INSTANCE: abstract-groups sequence
+MIXIN: subseq-chunking
-TUPLE: groups < abstract-groups ;
+M: subseq-chunking nth group@ subseq ;
-: <groups> ( seq n -- groups )
- groups new-groups ; inline
+MIXIN: slice-chunking
+
+M: slice-chunking nth group@ <slice> ;
+
+M: slice-chunking nth-unsafe group@ slice boa ;
+
+TUPLE: abstract-groups < chunking-seq ;
-M: groups length
+M: abstract-groups length
[ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
-M: groups set-length
+M: abstract-groups set-length
[ n>> * ] [ seq>> ] bi set-length ;
-M: groups group@
+M: abstract-groups group@
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
-TUPLE: sliced-groups < groups ;
+TUPLE: abstract-clumps < chunking-seq ;
+
+M: abstract-clumps length
+ [ seq>> length ] [ n>> ] bi - 1+ ;
+
+M: abstract-clumps set-length
+ [ n>> + 1- ] [ seq>> ] bi set-length ;
+
+M: abstract-clumps group@
+ [ n>> over + ] [ seq>> ] bi ;
+
+PRIVATE>
+
+TUPLE: groups < abstract-groups ;
+
+: <groups> ( seq n -- groups )
+ groups new-groups ; inline
+
+INSTANCE: groups subseq-chunking
+
+TUPLE: sliced-groups < abstract-groups ;
: <sliced-groups> ( seq n -- groups )
sliced-groups new-groups ; inline
-M: sliced-groups nth group@ <slice> ;
+INSTANCE: sliced-groups slice-chunking
-TUPLE: clumps < abstract-groups ;
+TUPLE: clumps < abstract-clumps ;
: <clumps> ( seq n -- clumps )
clumps new-groups ; inline
-M: clumps length
- [ seq>> length ] [ n>> ] bi - 1+ ;
-
-M: clumps set-length
- [ n>> + 1- ] [ seq>> ] bi set-length ;
-
-M: clumps group@
- [ n>> over + ] [ seq>> ] bi ;
+INSTANCE: clumps subseq-chunking
-TUPLE: sliced-clumps < clumps ;
+TUPLE: sliced-clumps < abstract-clumps ;
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline
-M: sliced-clumps nth group@ <slice> ;
+INSTANCE: sliced-clumps slice-chunking
: group ( seq n -- array ) <groups> { } like ;
ARTICLE: "io.encodings" "I/O encodings"
"Bytes can't be understood in isolation as text. They must be interpreted under a certain encoding. Factor provides utilities for dealing with encoded text by declaring that a stream has a particular encoding, and utilities to encode and decode strings."
-{ $subsection "encodings-constructors" }
{ $subsection "encodings-descriptors" }
+{ $subsection "encodings-constructors" }
+{ $subsection "io.encodings.string" }
+"New types of encodings can be defined:"
{ $subsection "encodings-protocol" } ;
ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
M: encoder stream-write1
>encoder< encode-char ;
-: decoder-write ( string stream encoding -- )
+: encoder-write ( string stream encoding -- )
[ encode-char ] 2curry each ;
M: encoder stream-write
- >encoder< decoder-write ;
+ >encoder< encoder-write ;
M: encoder dispose stream>> dispose ;
-USING: help.markup help.syntax io strings
- io.backend io.files.private quotations ;
+USING: help.markup help.syntax io strings arrays io.backend
+io.files.private quotations ;
IN: io.files
ARTICLE: "file-streams" "Reading and writing files"
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
+HELP: file-systems
+{ $values { "array" array } }
+{ $description "Returns an array of " { $link file-system-info } " objects returned by iterating the mount points and calling " { $link file-system-info } " on each." } ;
+
HELP: file-system-info
{ $values
{ "path" "a pathname string" }
! File-system
+HOOK: file-systems os ( -- array )
+
TUPLE: file-system-info device-name mount-point type free-space ;
HOOK: file-system-info os ( path -- file-system-info )
HELP: loop
{ $values
{ "pred" quotation } }
-{ $description "Calls the quotation repeatedly until the output is true." }
+ { $description "Calls the quotation repeatedly until it outputs " { $link f } "." }
{ $examples "Loop until we hit a zero:"
{ $unchecked-example "USING: kernel random math io ; "
" [ \"hi\" write bl 10 random zero? not ] loop"
compose compose ; inline
! Booleans
-: not ( obj -- ? ) f t ? ; inline
+: not ( obj -- ? ) [ f ] [ t ] if ; inline
: and ( obj1 obj2 -- ? ) over ? ; inline
-: >boolean ( obj -- ? ) t f ? ; inline
+: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
: or ( obj1 obj2 -- ? ) dupd ? ; inline
<PRIVATE
-: hi-tag ( obj -- n ) 0 slot ; inline
-
: declare ( spec -- ) drop ;
+: hi-tag ( obj -- n ) { hi-tag } declare 0 slot ; inline
+
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>
[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
+[ 4420880996869850977 ] [ 13262642990609552931 3 /i ] unit-test
[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
+[ 0 -1 ] [ -1 -268435456 >bignum /mod ] unit-test
[ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test
+[ 8 530505719624382123 ] [ 13262642990609552931 1591517158873146351 /mod ] unit-test
+[ 8 ] [ 13262642990609552931 1591517158873146351 /i ] unit-test
+[ 530505719624382123 ] [ 13262642990609552931 1591517158873146351 mod ] unit-test
[ -351382792 ] [ -43922849 3 shift ] unit-test
HELP: with-scope
{ $values { "quot" quotation } }
-{ $description "Calls the quotation in a new namespace. Any variables set by the quotation are discarded when it returns." } ;
+{ $description "Calls the quotation in a new namespace. Any variables set by the quotation are discarded when it returns." }
+{ $examples
+ { $example "USING: math namespaces prettyprint ;" "IN: scratchpad" "SYMBOL: x" "0 x set" "[ x [ 5 + ] change x get . ] with-scope x get ." "5\n0" }
+} ;
HELP: with-variable
{ $values { "value" object } { "key" "a variable, by convention a symbol" } { "quot" quotation } }
{ $subsection POSTPONE: PRIVATE> }
{ $subsection "vocabulary-search-errors" }
{ $subsection "vocabulary-search-shadow" }
-{ $see-also "words" } ;
+{ $see-also "words" "qualified" } ;
ARTICLE: "reading-ahead" "Reading ahead"
"Parsing words can consume input:"
] [
error>> staging-violation?
] must-fail-with
+
+! Bogus error message
+DEFER: blah
+
+[ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ]
+[ error>> error>> def>> \ blah eq? ] must-fail-with
] keep
] { } map>assoc ;
-TUPLE: no-word-error name ;
+ERROR: no-word-error name ;
: no-word ( name -- newword )
- dup no-word-error boa
+ dup \ no-word-error boa
swap words-named [ forward-reference? not ] filter
word-restarts throw-restarts
dup vocabulary>> (use+) ;
HELP: unclip-slice
{ $values { "seq" sequence } { "rest-slice" slice } { "first" object } }
-{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
+{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." }
+{ $examples { $example "USING: math.order prettyprint sequences ;" "{ 3 -1 -10 5 7 } unclip-slice [ min ] reduce ." "-10" } } ;
HELP: unclip-last
{ $values { "seq" sequence } { "butlast" sequence } { "last" object } }
{ { $snippet "\"specializer\"" } { $link "hints" } }
- { { { $snippet "\"intrinsics\"" } ", " { $snippet "\"if-intrinsics\"" } } { $link "generator" } }
-
{ { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" }
}
"Properties which are defined for classes only:"
M: word reset-word
{
- "unannotated-def"
- "parsing" "inline" "recursive" "foldable" "flushable"
- "predicating"
- "reading" "writing"
- "reader" "writer"
- "constructing"
- "declared-effect" "constructor-quot" "delimiter"
+ "unannotated-def" "parsing" "inline" "recursive"
+ "foldable" "flushable" "reading" "writing" "reader"
+ "writer" "declared-effect" "delimiter"
} reset-props ;
GENERIC: subwords ( word -- seq )
dup "forgotten" word-prop [ drop ] [
[ delete-xref ]
[ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
- [ t "forgotten" set-word-prop ]
+ [ [ reset-word ] [ t "forgotten" set-word-prop ] bi ]
tri
] if ;
M: word hashcode*
- nip 1 slot { fixnum } declare ;
+ nip 1 slot { fixnum } declare ; foldable
M: word literalize <wrapper> ;
--- /dev/null
+IN: advice
+USING: help.markup help.syntax tools.annotations words coroutines ;
+
+HELP: make-advised
+{ $values { "word" "a word to annotate in preparation of advising" } }
+{ $description "Prepares a word for being advised. This is done by: "
+ { $list
+ { "Annotating it to call the appropriate words before, around, and after the original body " }
+ { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
+ { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
+ }
+}
+{ $see-also advised? annotate } ;
+
+HELP: advised?
+{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
+{ $description "Determines whether or not the given word has any advice on it." } ;
+
+HELP: ad-do-it
+{ $values { "input" "an object" } { "output" "an object" } }
+{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
+{ $see-also coyield } ;
+
+ARTICLE: "advice" "Advice"
+"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
+
+ABOUT: "advice"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences io io.streams.string math tools.test advice math.parser
+parser namespaces multiline eval words assocs ;
+IN: advice.tests
+
+[
+ [ ad-do-it ] must-fail
+
+ : foo "foo" ;
+ \ foo make-advised
+
+ { "bar" "foo" } [
+ [ "bar" ] "barify" \ foo advise-before
+ foo
+ ] unit-test
+
+ { "bar" "foo" "baz" } [
+ [ "baz" ] "bazify" \ foo advise-after
+ foo
+ ] unit-test
+
+ { "foo" "baz" } [
+ "barify" \ foo before remove-advice
+ foo
+ ] unit-test
+
+ : bar ( a -- b ) 1+ ;
+ \ bar make-advised
+
+ { 11 } [
+ [ 2 * ] "double" \ bar advise-before
+ 5 bar
+ ] unit-test
+
+ { 11/3 } [
+ [ 3 / ] "third" \ bar advise-after
+ 5 bar
+ ] unit-test
+
+ { -2 } [
+ [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+ 5 bar
+ ] unit-test
+
+ : add ( a b -- c ) + ;
+ \ add make-advised
+
+ { 10 } [
+ [ [ 2 * ] bi@ ] "double-args" \ add advise-before
+ 2 3 add
+ ] unit-test
+
+ { 21 } [
+ [ 3 * ad-do-it 1- ] "around1" \ add advise-around
+ 2 3 add
+ ] unit-test
+
+! { 9 } [
+! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+! 2 3 add
+! ] unit-test
+
+! { { "around1" "around2" } } [
+! \ add around word-prop keys
+! ] unit-test
+
+ { 5 f } [
+ \ add unadvise
+ 2 3 add \ add advised?
+ ] unit-test
+
+! : quux ( a b -- c ) * ;
+
+! { f t 3+3/4 } [
+! <" USING: advice kernel math ;
+! IN: advice.tests
+! \ quux advised?
+! ADVISE: quux halve before [ 2 / ] bi@ ;
+! \ quux advised?
+! 3 5 quux"> eval
+! ] unit-test
+
+! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
+! <" USING: advice kernel math math.parser io io.streams.string ;
+! IN: advice.tests
+! ADVISE: quux log around
+! 2dup [ number>string write " " write ] bi@
+! ad-do-it
+! dup number>string write ;
+! [ 3 5 quux ] with-string-writer"> eval
+! ] unit-test
+
+] with-scope
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences symbols fry words assocs linked-assocs tools.annotations
+coroutines lexer parser quotations arrays namespaces continuations ;
+IN: advice
+
+SYMBOLS: before after around advised in-advice? ;
+
+: advised? ( word -- ? )
+ advised word-prop ;
+
+DEFER: make-advised
+
+<PRIVATE
+: init-around-co ( quot -- coroutine )
+ \ coreset suffix cocreate ;
+PRIVATE>
+
+: advise ( quot name word loc -- )
+ dup around eq? [ [ init-around-co ] 3dip ] when
+ over advised? [ over make-advised ] unless
+ word-prop set-at ;
+
+: advise-before ( quot name word -- ) before advise ;
+
+: advise-after ( quot name word -- ) after advise ;
+
+: advise-around ( quot name word -- ) around advise ;
+
+: get-advice ( word type -- seq )
+ word-prop values ;
+
+: call-before ( word -- )
+ before get-advice [ call ] each ;
+
+: call-after ( word -- )
+ after get-advice [ call ] each ;
+
+: call-around ( main word -- )
+ t in-advice? [
+ around get-advice tuck
+ [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
+ ] with-variable ;
+
+: remove-advice ( name word loc -- )
+ word-prop delete-at ;
+
+: ad-do-it ( input -- result )
+ in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ;
+
+: make-advised ( word -- )
+ [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
+ [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
+ [ t advised set-word-prop ] tri ;
+
+: unadvise ( word -- )
+ [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
+
+: ADVISE: ! word adname location => word adname quot loc
+ scan-word scan scan-word parse-definition swap [ spin ] dip advise ; parsing
+
+: UNADVISE:
+ scan-word parsed \ unadvise parsed ; parsing
\ No newline at end of file
--- /dev/null
+James Cash
--- /dev/null
+Implmentation of advice/aspects
--- /dev/null
+advice
+aspect
+annotations
: draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
-: display ( -- ) black set-color bitmap> draw-bitmap ;
+: display ( -- ) black gl-color bitmap> draw-bitmap ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
IN: benchmark
: run-benchmark ( vocab -- result )
- [ [ require ] [ [ run ] benchmark ] bi ] curry
- [ error. f ] recover ;
+ [ [ require ] [ [ run ] benchmark ] bi ] curry
+ [ error. f ] recover ;
: run-benchmarks ( -- assoc )
- "benchmark" all-child-vocabs-seq
- [ dup run-benchmark ] { } map>assoc ;
+ "benchmark" all-child-vocabs-seq
+ [ dup run-benchmark ] { } map>assoc ;
: benchmarks. ( assoc -- )
standard-table-style [
USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
+H{
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
- { "stop-after-last-window?" t }
+ { deploy-ui? t }
+ { deploy-io 2 }
+ { deploy-threads? t }
+ { deploy-word-defs? f }
+ { deploy-compiler? t }
+ { deploy-unicode? f }
{ deploy-name "Boids" }
+ { "stop-after-last-window?" t }
+ { deploy-reflection 1 }
}
+++ /dev/null
-
-USING: io.files io.launcher io.encodings.utf8 prettyprint
- builder.util builder.common builder.child builder.release
- builder.report builder.email builder.cleanup ;
-
-IN: builder.build
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: create-build-dir ( -- )
- datestamp >stamp
- build-dir make-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: enter-build-dir ( -- ) build-dir set-current-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: clone-builds-factor ( -- )
- { "git" "clone" builds/factor } to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: record-id ( -- )
- "factor"
- [ git-id "../git-id" utf8 [ . ] with-file-writer ]
- with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: build ( -- )
- reset-status
- create-build-dir
- enter-build-dir
- clone-builds-factor
- record-id
- build-child
- release
- report
- email-report
- cleanup ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: build
\ No newline at end of file
+++ /dev/null
-
-USING: kernel debugger io.files threads calendar
- builder.common
- builder.updates
- builder.build ;
-
-IN: builder
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: build-loop ( -- )
- builds-check
- [
- builds/factor set-current-directory
- new-code-available? [ build ] when
- ]
- try
- 5 minutes sleep
- build-loop ;
-
-MAIN: build-loop
\ No newline at end of file
+++ /dev/null
-
-USING: namespaces debugger io.files io.launcher accessors bootstrap.image
- calendar builder.util builder.common ;
-
-IN: builder.child
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-vm ( -- )
- <process>
- gnu-make >>command
- "../compile-log" >>stdout
- +stdout+ >>stderr
- try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ;
-
-: copy-image ( -- )
- builds-factor-image ".." copy-file-into
- builds-factor-image "." copy-file-into ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: boot-cmd ( -- cmd )
- { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
-
-: boot ( -- )
- <process>
- boot-cmd >>command
- +closed+ >>stdin
- "../boot-log" >>stdout
- +stdout+ >>stderr
- 60 minutes >>timeout
- try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
-
-: test ( -- )
- <process>
- test-cmd >>command
- +closed+ >>stdin
- "../test-log" >>stdout
- +stdout+ >>stderr
- 240 minutes >>timeout
- try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (build-child) ( -- )
- make-clean
- make-vm status-vm on
- copy-image
- boot status-boot on
- test status-test on
- status on ;
-
-: build-child ( -- )
- "factor" set-current-directory
- [ (build-child) ] try
- ".." set-current-directory ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel namespaces io.files io.launcher bootstrap.image
- builder.util builder.common ;
-
-IN: builder.cleanup
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builder-debug
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
-
-: delete-child-factor ( -- )
- build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ;
-
-: cleanup ( -- )
- builder-debug get f =
- [
- "test-log" delete-file
- delete-child-factor
- compress-image
- ]
- when ;
-
+++ /dev/null
-
-USING: kernel namespaces sequences splitting
- io io.files io.launcher io.encodings.utf8 prettyprint
- vars builder.util ;
-
-IN: builder.common
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: upload-to-factorcode
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builds-dir
-
-: builds ( -- path )
- builds-dir get
- home "/builds" append
- or ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: stamp
-
-: builds/factor ( -- path ) builds "factor" append-path ;
-: build-dir ( -- path ) builds stamp> append-path ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prepare-build-machine ( -- )
- builds make-directory
- builds
- [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
- with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: status-vm
-SYMBOL: status-boot
-SYMBOL: status-test
-SYMBOL: status-build
-SYMBOL: status-release
-SYMBOL: status
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: reset-status ( -- )
- { status-vm status-boot status-test status-build status-release status }
- [ off ]
- each ;
+++ /dev/null
-
-USING: kernel namespaces accessors smtp builder.util builder.common ;
-
-IN: builder.email
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builder-from
-SYMBOL: builder-recipients
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
-
-: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
-
-: email-report ( -- )
- <email>
- builder-from get >>from
- builder-recipients get >>to
- subject >>subject
- "report" file>string >>body
- send-email ;
-
+++ /dev/null
-
-USING: kernel combinators system sequences io.files io.launcher prettyprint
- builder.util
- builder.common ;
-
-IN: builder.release.archive
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: base-name ( -- string )
- { "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
-
-: extension ( -- extension )
- {
- { [ os winnt? ] [ ".zip" ] }
- { [ os macosx? ] [ ".dmg" ] }
- { [ os unix? ] [ ".tar.gz" ] }
- }
- cond ;
-
-: archive-name ( -- string ) base-name extension append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
-
-! : macosx-archive-cmd ( -- cmd )
-! { "hdiutil" "create"
-! "-srcfolder" "factor"
-! "-fs" "HFS+"
-! "-volname" "factor"
-! archive-name } ;
-
-: macosx-archive-cmd ( -- cmd )
- { "mkdir" "dmg-root" } try-process
- { "cp" "-r" "factor" "dmg-root" } try-process
- { "hdiutil" "create"
- "-srcfolder" "dmg-root"
- "-fs" "HFS+"
- "-volname" "factor"
- archive-name } to-strings try-process
- { "rm" "-rf" "dmg-root" } try-process
- { "true" } ;
-
-: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: archive-cmd ( -- cmd )
- {
- { [ os windows? ] [ windows-archive-cmd ] }
- { [ os macosx? ] [ macosx-archive-cmd ] }
- { [ os unix? ] [ unix-archive-cmd ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-archive ( -- ) archive-cmd to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: releases ( -- path )
- builds "releases" append-path
- dup exists? not
- [ dup make-directory ]
- when ;
-
-: save-archive ( -- ) archive-name releases move-file-into ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel system namespaces sequences prettyprint io.files io.launcher
- bootstrap.image
- builder.util
- builder.common ;
-
-IN: builder.release.branch
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: branch-name ( -- string ) "clean-" platform append ;
-
-: refspec ( -- string ) "master:" branch-name append ;
-
-: push-to-clean-branch ( -- )
- { "git" "push" "factorcode.org:/git/factor.git" refspec }
- to-strings
- try-process ;
-
-: upload-clean-image ( -- )
- {
- "scp"
- my-boot-image-name
- { "factorcode.org:/var/www/factorcode.org/newsite/images/clean/" platform }
- }
- to-strings
- try-process ;
-
-: (update-clean-branch) ( -- )
- "factor"
- [
- push-to-clean-branch
- upload-clean-image
- ]
- with-directory ;
-
-: update-clean-branch ( -- )
- upload-to-factorcode get
- [ (update-clean-branch) ]
- when ;
+++ /dev/null
-
-USING: kernel debugger system namespaces sequences splitting combinators
- io io.files io.launcher prettyprint bootstrap.image
- combinators.cleave
- builder.util
- builder.common
- builder.release.branch
- builder.release.tidy
- builder.release.archive
- builder.release.upload ;
-
-IN: builder.release
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (release) ( -- )
- update-clean-branch
- tidy
- make-archive
- upload
- save-archive
- status-release on ;
-
-: clean-build? ( -- ? )
- { "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ;
-
-: release ( -- ) [ clean-build? [ (release) ] when ] try ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel system io.files io.launcher builder.util ;
-
-IN: builder.release.tidy
-
-: common-files ( -- seq )
- {
- "boot.x86.32.image"
- "boot.x86.64.image"
- "boot.macosx-ppc.image"
- "boot.linux-ppc.image"
- "vm"
- "temp"
- "logs"
- ".git"
- ".gitignore"
- "Makefile"
- "unmaintained"
- "build-support"
- } ;
-
-: remove-common-files ( -- )
- { "rm" "-rf" common-files } to-strings try-process ;
-
-: remove-factor-app ( -- )
- os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
-
-: tidy ( -- )
- "factor" [ remove-factor-app remove-common-files ] with-directory ;
+++ /dev/null
-
-USING: kernel namespaces make sequences arrays io io.files
- builder.util
- builder.common
- builder.release.archive ;
-
-IN: builder.release.upload
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: upload-host
-
-SYMBOL: upload-username
-
-SYMBOL: upload-directory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: remote-location ( -- dest )
- upload-directory get platform append ;
-
-: remote-archive-name ( -- dest )
- remote-location "/" archive-name 3append ;
-
-: temp-archive-name ( -- dest )
- remote-archive-name ".incomplete" append ;
-
-: upload-command ( -- args )
- "scp"
- archive-name
- [ upload-username get % "@" % upload-host get % ":" % temp-archive-name % ] "" make
- 3array ;
-
-: rename-command ( -- args )
- [
- "ssh" ,
- upload-host get ,
- "-l" ,
- upload-username get ,
- "mv" ,
- temp-archive-name ,
- remote-archive-name ,
- ] { } make ;
-
-: upload-temp-file ( -- )
- upload-command [ "Error uploading binary to factorcode" print ] run-or-bail ;
-
-: rename-temp-file ( -- )
- rename-command [ "Error renaming binary on factorcode" print ] run-or-bail ;
-
-: upload ( -- )
- upload-to-factorcode get
- [ upload-temp-file rename-temp-file ]
- when ;
+++ /dev/null
-
-USING: kernel namespaces debugger system io io.files io.sockets
- io.encodings.utf8 prettyprint benchmark
- builder.util builder.common ;
-
-IN: builder.report
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (report) ( -- )
-
- "Build machine: " write host-name print
- "CPU: " write cpu .
- "OS: " write os .
- "Build directory: " write build-dir print
- "git id: " write "git-id" eval-file print nl
-
- status-vm get f = [ "compile-log" cat "vm compile error" throw ] when
- status-boot get f = [ "boot-log" 100 cat-n "Boot error" throw ] when
- status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when
-
- "Boot time: " write "boot-time" eval-file milli-seconds>time print
- "Load time: " write "load-time" eval-file milli-seconds>time print
- "Test time: " write "test-time" eval-file milli-seconds>time print nl
-
- "Did not pass load-everything: " print "load-everything-vocabs" cat
-
- "Did not pass test-all: " print "test-all-vocabs" cat
- "test-failures" cat
-
- "help-lint results:" print "help-lint" cat
-
- "Benchmarks: " print "benchmarks" eval-file benchmarks. ;
-
-: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel namespaces assocs
- io.files io.encodings.utf8 prettyprint
- help.lint
- benchmark
- tools.time
- bootstrap.stage2
- tools.test tools.vocabs
- builder.util ;
-
-IN: builder.test
-
-: do-load ( -- )
- try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
-
-: do-tests ( -- )
- run-all-tests
- [ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
- [ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
- bi ;
-
-: do-help-lint ( -- )
- "" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
-
-: do-benchmarks ( -- )
- run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ;
-
-: do-all ( -- )
- bootstrap-time get "../boot-time" utf8 [ . ] with-file-writer
- [ do-load ] benchmark "../load-time" utf8 [ . ] with-file-writer
- [ do-tests ] benchmark "../test-time" utf8 [ . ] with-file-writer
- do-help-lint
- do-benchmarks ;
-
-MAIN: do-all
\ No newline at end of file
+++ /dev/null
-
-USING: kernel io.launcher bootstrap.image bootstrap.image.download
- builder.util builder.common ;
-
-IN: builder.updates
-
-: git-pull-cmd ( -- cmd )
- {
- "git"
- "pull"
- "--no-summary"
- "git://factorcode.org/git/factor.git"
- "master"
- } ;
-
-: updates-available? ( -- ? )
- git-id
- git-pull-cmd try-process
- git-id
- = not ;
-
-: new-image-available? ( -- ? )
- my-boot-image-name need-new-image?
- [ download-my-image t ]
- [ f ]
- if ;
-
-: new-code-available? ( -- ? )
- updates-available?
- new-image-available?
- or ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel words namespaces classes parser continuations
- io io.files io.launcher io.sockets
- math math.parser
- system
- combinators sequences splitting quotations arrays strings tools.time
- sequences.deep accessors assocs.lib
- io.encodings.utf8
- combinators.cleave calendar calendar.format eval ;
-
-IN: builder.util
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: minutes>ms ( min -- ms ) 60 * 1000 * ;
-
-: file>string ( file -- string ) utf8 file-contents ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: to-strings
-
-: to-string ( obj -- str )
- dup class
- {
- { \ string [ ] }
- { \ quotation [ call ] }
- { \ word [ execute ] }
- { \ fixnum [ number>string ] }
- { \ array [ to-strings concat ] }
- }
- case ;
-
-: to-strings ( seq -- str )
- dup [ string? ] all?
- [ ]
- [ [ to-string ] map flatten ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: host-name* ( -- name ) host-name "." split first ;
-
-: datestamp ( -- string )
- now
- { year>> month>> day>> hour>> minute>> } <arr>
- [ pad-00 ] map "-" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: milli-seconds>time ( n -- string )
- 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
-
-: eval-file ( file -- obj ) utf8 file-contents eval ;
-
-: cat ( file -- ) utf8 file-contents print ;
-
-: run-or-bail ( desc quot -- )
- [ [ try-process ] curry ]
- [ [ throw ] compose ]
- bi*
- recover ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: bootstrap.image bootstrap.image.download io.streams.null ;
-
-: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: longer? ( seq seq -- ? ) [ length ] bi@ > ;
-
-: maybe-tail* ( seq n -- seq )
- 2dup longer?
- [ tail* ]
- [ drop ]
- if ;
-
-: cat-n ( file n -- )
- [ utf8 file-lines ] [ ] bi*
- maybe-tail*
- [ print ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: prettyprint
-
-: to-file ( object file -- ) utf8 [ . ] with-file-writer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
-
-: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gnu-make ( -- string )
- os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-id ( -- id )
- { "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
- " " split second ;
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ deploy-compiler? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-name "Bunny" }
{ deploy-word-props? f }
-USING: accessors alien.c-types arrays combinators destructors http.client
-io io.encodings.ascii io.files kernel math math.matrices math.parser
-math.vectors opengl opengl.capabilities opengl.gl sequences sequences.lib
-splitting vectors words ;
+USING: accessors alien.c-types arrays combinators destructors
+http.client io io.encodings.ascii io.files kernel math
+math.matrices math.parser math.vectors opengl
+opengl.capabilities opengl.gl opengl.demo-support sequences
+sequences.lib splitting vectors words ;
IN: bunny.model
: numbers ( str -- seq )
USING: arrays bunny.model bunny.cel-shaded continuations
destructors kernel math multiline opengl opengl.shaders
-opengl.framebuffers opengl.gl opengl.capabilities sequences
-ui.gadgets combinators accessors ;
+opengl.framebuffers opengl.gl opengl.demo-support
+opengl.capabilities sequences ui.gadgets combinators accessors ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
--- /dev/null
+Sampo Vuori
--- /dev/null
+! Cairo "Hello World" demo
+! Copyright (c) 2007 Sampo Vuori
+! License: http://factorcode.org/license.txt
+!
+! This example is an adaptation of the following cairo sample code:
+! http://cairographics.org/samples/text/
+
+
+USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
+ ui.gadgets opengl.gl accessors ;
+
+IN: cairo-demo
+
+
+: make-image-array ( -- array )
+ 384 256 4 * * <byte-array> ;
+
+: convert-array-to-surface ( array -- cairo_surface_t )
+ CAIRO_FORMAT_ARGB32 384 256 over 4 *
+ cairo_image_surface_create_for_data ;
+
+
+TUPLE: cairo-demo-gadget < gadget image-array cairo-t ;
+
+M: cairo-demo-gadget draw-gadget* ( gadget -- )
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
+ image-array>> glDrawPixels ;
+
+: create-surface ( gadget -- cairo_surface_t )
+ make-image-array [ swap (>>image-array) ] keep
+ convert-array-to-surface ;
+
+: init-cairo ( gadget -- cairo_t )
+ create-surface cairo_create ;
+
+M: cairo-demo-gadget pref-dim* drop { 384 256 0 } ;
+
+: draw-hello-world ( gadget -- )
+ cairo-t>>
+ dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face
+ dup 90.0 cairo_set_font_size
+ dup 10.0 135.0 cairo_move_to
+ dup "Hello" cairo_show_text
+ dup 70.0 165.0 cairo_move_to
+ dup "World" cairo_text_path
+ dup 0.5 0.5 1 cairo_set_source_rgb
+ dup cairo_fill_preserve
+ dup 0 0 0 cairo_set_source_rgb
+ dup 2.56 cairo_set_line_width
+ dup cairo_stroke
+ dup 1 0.2 0.2 0.6 cairo_set_source_rgba
+ dup 10.0 135.0 5.12 0 pi 2 * cairo_arc
+ dup cairo_close_path
+ dup 70.0 165.0 5.12 0 pi 2 * cairo_arc
+ cairo_fill ;
+
+M: cairo-demo-gadget graft* ( gadget -- )
+ dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
+
+M: cairo-demo-gadget ungraft* ( gadget -- )
+ cairo-t>> cairo_destroy ;
+
+: <cairo-demo-gadget> ( -- gadget )
+ cairo-demo-gadget new-gadget ;
+
+: run ( -- )
+ [
+ <cairo-demo-gadget> "Hello World from Factor!" open-window
+ ] with-ui ;
+
+MAIN: run
--- /dev/null
+Sampo Vuori
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cairo.ffi kernel accessors sequences
+namespaces fry continuations destructors ;
+IN: cairo
+
+TUPLE: cairo-t alien ;
+C: <cairo-t> cairo-t
+M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
+
+TUPLE: cairo-surface-t alien ;
+C: <cairo-surface-t> cairo-surface-t
+M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
+
+: check-cairo ( cairo_status_t -- )
+ dup CAIRO_STATUS_SUCCESS = [ drop ]
+ [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
+
+SYMBOL: cairo
+: cr ( -- cairo ) cairo get ;
+
+: (with-cairo) ( cairo-t quot -- )
+ >r alien>> cairo r> [ cr cairo_status check-cairo ]
+ compose with-variable ; inline
+
+: with-cairo ( cairo quot -- )
+ >r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
+
+: (with-surface) ( cairo-surface-t quot -- )
+ >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
+
+: with-surface ( cairo_surface quot -- )
+ >r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
+
+: with-cairo-from-surface ( cairo_surface quot -- )
+ '[ cairo_create _ with-cairo ] with-surface ; inline
--- /dev/null
+! Copyright (c) 2007 Sampo Vuori
+! Copyright (c) 2008 Matthew Willis
+!
+! Adapted from cairo.h, version 1.5.14
+! License: http://factorcode.org/license.txt
+
+USING: system combinators alien alien.syntax kernel
+alien.c-types accessors sequences arrays ui.gadgets ;
+
+IN: cairo.ffi
+<< "cairo" {
+ { [ os winnt? ] [ "libcairo-2.dll" ] }
+ { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
+ { [ os unix? ] [ "libcairo.so.2" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: cairo
+
+FUNCTION: int cairo_version ( ) ;
+FUNCTION: char* cairo_version_string ( ) ;
+
+TYPEDEF: int cairo_bool_t
+
+! I am leaving these and other void* types as opaque structures
+TYPEDEF: void* cairo_t
+TYPEDEF: void* cairo_surface_t
+
+C-STRUCT: cairo_matrix_t
+ { "double" "xx" }
+ { "double" "yx" }
+ { "double" "xy" }
+ { "double" "yy" }
+ { "double" "x0" }
+ { "double" "y0" } ;
+
+TYPEDEF: void* cairo_pattern_t
+
+TYPEDEF: void* cairo_destroy_func_t
+: cairo-destroy-func ( quot -- callback )
+ >r "void" { "void*" } "cdecl" r> alien-callback ; inline
+
+! See cairo.h for details
+C-STRUCT: cairo_user_data_key_t
+ { "int" "unused" } ;
+
+TYPEDEF: int cairo_status_t
+C-ENUM:
+ CAIRO_STATUS_SUCCESS
+ CAIRO_STATUS_NO_MEMORY
+ CAIRO_STATUS_INVALID_RESTORE
+ CAIRO_STATUS_INVALID_POP_GROUP
+ CAIRO_STATUS_NO_CURRENT_POINT
+ CAIRO_STATUS_INVALID_MATRIX
+ CAIRO_STATUS_INVALID_STATUS
+ CAIRO_STATUS_NULL_POINTER
+ CAIRO_STATUS_INVALID_STRING
+ CAIRO_STATUS_INVALID_PATH_DATA
+ CAIRO_STATUS_READ_ERROR
+ CAIRO_STATUS_WRITE_ERROR
+ CAIRO_STATUS_SURFACE_FINISHED
+ CAIRO_STATUS_SURFACE_TYPE_MISMATCH
+ CAIRO_STATUS_PATTERN_TYPE_MISMATCH
+ CAIRO_STATUS_INVALID_CONTENT
+ CAIRO_STATUS_INVALID_FORMAT
+ CAIRO_STATUS_INVALID_VISUAL
+ CAIRO_STATUS_FILE_NOT_FOUND
+ CAIRO_STATUS_INVALID_DASH
+ CAIRO_STATUS_INVALID_DSC_COMMENT
+ CAIRO_STATUS_INVALID_INDEX
+ CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
+ CAIRO_STATUS_TEMP_FILE_ERROR
+ CAIRO_STATUS_INVALID_STRIDE ;
+
+TYPEDEF: int cairo_content_t
+: CAIRO_CONTENT_COLOR HEX: 1000 ;
+: CAIRO_CONTENT_ALPHA HEX: 2000 ;
+: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
+
+TYPEDEF: void* cairo_write_func_t
+: cairo-write-func ( quot -- callback )
+ >r "cairo_status_t" { "void*" "uchar*" "int" }
+ "cdecl" r> alien-callback ; inline
+
+TYPEDEF: void* cairo_read_func_t
+: cairo-read-func ( quot -- callback )
+ >r "cairo_status_t" { "void*" "uchar*" "int" }
+ "cdecl" r> alien-callback ; inline
+
+! Functions for manipulating state objects
+FUNCTION: cairo_t*
+cairo_create ( cairo_surface_t* target ) ;
+
+FUNCTION: cairo_t*
+cairo_reference ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_destroy ( cairo_t* cr ) ;
+
+FUNCTION: uint
+cairo_get_reference_count ( cairo_t* cr ) ;
+
+FUNCTION: void*
+cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_save ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_restore ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_push_group ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pop_group ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_pop_group_to_source ( cairo_t* cr ) ;
+
+! Modify state
+TYPEDEF: int cairo_operator_t
+C-ENUM:
+ CAIRO_OPERATOR_CLEAR
+
+ CAIRO_OPERATOR_SOURCE
+ CAIRO_OPERATOR_OVER
+ CAIRO_OPERATOR_IN
+ CAIRO_OPERATOR_OUT
+ CAIRO_OPERATOR_ATOP
+
+ CAIRO_OPERATOR_DEST
+ CAIRO_OPERATOR_DEST_OVER
+ CAIRO_OPERATOR_DEST_IN
+ CAIRO_OPERATOR_DEST_OUT
+ CAIRO_OPERATOR_DEST_ATOP
+
+ CAIRO_OPERATOR_XOR
+ CAIRO_OPERATOR_ADD
+ CAIRO_OPERATOR_SATURATE ;
+
+FUNCTION: void
+cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ;
+
+FUNCTION: void
+cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ;
+
+FUNCTION: void
+cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ;
+
+FUNCTION: void
+cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ;
+
+FUNCTION: void
+cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ;
+
+FUNCTION: void
+cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
+
+TYPEDEF: int cairo_antialias_t
+C-ENUM:
+ CAIRO_ANTIALIAS_DEFAULT
+ CAIRO_ANTIALIAS_NONE
+ CAIRO_ANTIALIAS_GRAY
+ CAIRO_ANTIALIAS_SUBPIXEL ;
+
+FUNCTION: void
+cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
+
+TYPEDEF: int cairo_fill_rule_t
+C-ENUM:
+ CAIRO_FILL_RULE_WINDING
+ CAIRO_FILL_RULE_EVEN_ODD ;
+
+FUNCTION: void
+cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
+
+FUNCTION: void
+cairo_set_line_width ( cairo_t* cr, double width ) ;
+
+TYPEDEF: int cairo_line_cap_t
+C-ENUM:
+ CAIRO_LINE_CAP_BUTT
+ CAIRO_LINE_CAP_ROUND
+ CAIRO_LINE_CAP_SQUARE ;
+
+FUNCTION: void
+cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
+
+TYPEDEF: int cairo_line_join_t
+C-ENUM:
+ CAIRO_LINE_JOIN_MITER
+ CAIRO_LINE_JOIN_ROUND
+ CAIRO_LINE_JOIN_BEVEL ;
+
+FUNCTION: void
+cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ;
+
+FUNCTION: void
+cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ;
+
+FUNCTION: void
+cairo_set_miter_limit ( cairo_t* cr, double limit ) ;
+
+FUNCTION: void
+cairo_translate ( cairo_t* cr, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_scale ( cairo_t* cr, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_rotate ( cairo_t* cr, double angle ) ;
+
+FUNCTION: void
+cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_identity_matrix ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: void
+cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ;
+
+FUNCTION: void
+cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: void
+cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
+
+! Path creation functions
+FUNCTION: void
+cairo_new_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_move_to ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: void
+cairo_new_sub_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_line_to ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: void
+cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ;
+
+FUNCTION: void
+cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
+
+FUNCTION: void
+cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
+
+FUNCTION: void
+cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ;
+
+FUNCTION: void
+cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ;
+
+FUNCTION: void
+cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ;
+
+FUNCTION: void
+cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+FUNCTION: void
+cairo_close_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+! Painting functions
+FUNCTION: void
+cairo_paint ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ;
+
+FUNCTION: void
+cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ;
+
+FUNCTION: void
+cairo_stroke ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_stroke_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_fill ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_fill_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_copy_page ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_show_page ( cairo_t* cr ) ;
+
+! Insideness testing
+FUNCTION: cairo_bool_t
+cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: cairo_bool_t
+cairo_in_fill ( cairo_t* cr, double x, double y ) ;
+
+! Rectangular extents
+FUNCTION: void
+cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+FUNCTION: void
+cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+! Clipping
+FUNCTION: void
+cairo_reset_clip ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+C-STRUCT: cairo_rectangle_t
+ { "double" "x" }
+ { "double" "y" }
+ { "double" "width" }
+ { "double" "height" } ;
+
+C-STRUCT: cairo_rectangle_list_t
+ { "cairo_status_t" "status" }
+ { "cairo_rectangle_t*" "rectangles" }
+ { "int" "num_rectangles" } ;
+
+FUNCTION: cairo_rectangle_list_t*
+cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ;
+
+! Font/Text functions
+
+TYPEDEF: void* cairo_scaled_font_t
+
+TYPEDEF: void* cairo_font_face_t
+
+C-STRUCT: cairo_glyph_t
+ { "ulong" "index" }
+ { "double" "x" }
+ { "double" "y" } ;
+
+C-STRUCT: cairo_text_extents_t
+ { "double" "x_bearing" }
+ { "double" "y_bearing" }
+ { "double" "width" }
+ { "double" "height" }
+ { "double" "x_advance" }
+ { "double" "y_advance" } ;
+
+C-STRUCT: cairo_font_extents_t
+ { "double" "ascent" }
+ { "double" "descent" }
+ { "double" "height" }
+ { "double" "max_x_advance" }
+ { "double" "max_y_advance" } ;
+
+TYPEDEF: int cairo_font_slant_t
+C-ENUM:
+ CAIRO_FONT_SLANT_NORMAL
+ CAIRO_FONT_SLANT_ITALIC
+ CAIRO_FONT_SLANT_OBLIQUE ;
+
+TYPEDEF: int cairo_font_weight_t
+C-ENUM:
+ CAIRO_FONT_WEIGHT_NORMAL
+ CAIRO_FONT_WEIGHT_BOLD ;
+
+TYPEDEF: int cairo_subpixel_order_t
+C-ENUM:
+ CAIRO_SUBPIXEL_ORDER_DEFAULT
+ CAIRO_SUBPIXEL_ORDER_RGB
+ CAIRO_SUBPIXEL_ORDER_BGR
+ CAIRO_SUBPIXEL_ORDER_VRGB
+ CAIRO_SUBPIXEL_ORDER_VBGR ;
+
+TYPEDEF: int cairo_hint_style_t
+C-ENUM:
+ CAIRO_HINT_STYLE_DEFAULT
+ CAIRO_HINT_STYLE_NONE
+ CAIRO_HINT_STYLE_SLIGHT
+ CAIRO_HINT_STYLE_MEDIUM
+ CAIRO_HINT_STYLE_FULL ;
+
+TYPEDEF: int cairo_hint_metrics_t
+C-ENUM:
+ CAIRO_HINT_METRICS_DEFAULT
+ CAIRO_HINT_METRICS_OFF
+ CAIRO_HINT_METRICS_ON ;
+
+TYPEDEF: void* cairo_font_options_t
+
+FUNCTION: cairo_font_options_t*
+cairo_font_options_create ( ) ;
+
+FUNCTION: cairo_font_options_t*
+cairo_font_options_copy ( cairo_font_options_t* original ) ;
+
+FUNCTION: void
+cairo_font_options_destroy ( cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_options_status ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
+
+FUNCTION: cairo_bool_t
+cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
+
+FUNCTION: ulong
+cairo_font_options_hash ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ;
+
+FUNCTION: cairo_antialias_t
+cairo_font_options_get_antialias ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ;
+
+FUNCTION: cairo_subpixel_order_t
+cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ;
+
+FUNCTION: cairo_hint_style_t
+cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ;
+
+FUNCTION: cairo_hint_metrics_t
+cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
+
+! This interface is for dealing with text as text, not caring about the
+! font object inside the the cairo_t.
+
+FUNCTION: void
+cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
+
+FUNCTION: void
+cairo_set_font_size ( cairo_t* cr, double size ) ;
+
+FUNCTION: void
+cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ;
+
+FUNCTION: cairo_font_face_t*
+cairo_get_font_face ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_scaled_font_t*
+cairo_get_scaled_font ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_show_text ( cairo_t* cr, char* utf8 ) ;
+
+FUNCTION: void
+cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
+
+FUNCTION: void
+cairo_text_path ( cairo_t* cr, char* utf8 ) ;
+
+FUNCTION: void
+cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
+
+FUNCTION: void
+cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ;
+
+! Generic identifier for a font style
+
+FUNCTION: cairo_font_face_t*
+cairo_font_face_reference ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: void
+cairo_font_face_destroy ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: uint
+cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_face_status ( cairo_font_face_t* font_face ) ;
+
+TYPEDEF: int cairo_font_type_t
+C-ENUM:
+ CAIRO_FONT_TYPE_TOY
+ CAIRO_FONT_TYPE_FT
+ CAIRO_FONT_TYPE_WIN32
+ CAIRO_FONT_TYPE_QUARTZ ;
+
+FUNCTION: cairo_font_type_t
+cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: void*
+cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+! Portable interface to general font features.
+
+FUNCTION: cairo_scaled_font_t*
+cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_scaled_font_t*
+cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void
+cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: uint
+cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_status_t
+cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_font_type_t
+cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void*
+cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
+
+FUNCTION: cairo_font_face_t*
+cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ;
+
+! Query functions
+
+FUNCTION: cairo_operator_t
+cairo_get_operator ( cairo_t* cr ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_get_source ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_tolerance ( cairo_t* cr ) ;
+
+FUNCTION: cairo_antialias_t
+cairo_get_antialias ( cairo_t* cr ) ;
+
+FUNCTION: cairo_bool_t
+cairo_has_current_point ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: cairo_fill_rule_t
+cairo_get_fill_rule ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_line_width ( cairo_t* cr ) ;
+
+FUNCTION: cairo_line_cap_t
+cairo_get_line_cap ( cairo_t* cr ) ;
+
+FUNCTION: cairo_line_join_t
+cairo_get_line_join ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_miter_limit ( cairo_t* cr ) ;
+
+FUNCTION: int
+cairo_get_dash_count ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ;
+
+FUNCTION: void
+cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_get_target ( cairo_t* cr ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_get_group_target ( cairo_t* cr ) ;
+
+TYPEDEF: int cairo_path_data_type_t
+C-ENUM:
+ CAIRO_PATH_MOVE_TO
+ CAIRO_PATH_LINE_TO
+ CAIRO_PATH_CURVE_TO
+ CAIRO_PATH_CLOSE_PATH ;
+
+! NEED TO DO UNION HERE
+C-STRUCT: cairo_path_data_t-point
+ { "double" "x" }
+ { "double" "y" } ;
+
+C-STRUCT: cairo_path_data_t-header
+ { "cairo_path_data_type_t" "type" }
+ { "int" "length" } ;
+
+C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
+
+C-STRUCT: cairo_path_t
+ { "cairo_status_t" "status" }
+ { "cairo_path_data_t*" "data" }
+ { "int" "num_data" } ;
+
+FUNCTION: cairo_path_t*
+cairo_copy_path ( cairo_t* cr ) ;
+
+FUNCTION: cairo_path_t*
+cairo_copy_path_flat ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ;
+
+FUNCTION: void
+cairo_path_destroy ( cairo_path_t* path ) ;
+
+! Error status queries
+
+FUNCTION: cairo_status_t
+cairo_status ( cairo_t* cr ) ;
+
+FUNCTION: char*
+cairo_status_to_string ( cairo_status_t status ) ;
+
+! Surface manipulation
+
+FUNCTION: cairo_surface_t*
+cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_surface_reference ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_finish ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_destroy ( cairo_surface_t* surface ) ;
+
+FUNCTION: uint
+cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_status ( cairo_surface_t* surface ) ;
+
+TYPEDEF: int cairo_surface_type_t
+C-ENUM:
+ CAIRO_SURFACE_TYPE_IMAGE
+ CAIRO_SURFACE_TYPE_PDF
+ CAIRO_SURFACE_TYPE_PS
+ CAIRO_SURFACE_TYPE_XLIB
+ CAIRO_SURFACE_TYPE_XCB
+ CAIRO_SURFACE_TYPE_GLITZ
+ CAIRO_SURFACE_TYPE_QUARTZ
+ CAIRO_SURFACE_TYPE_WIN32
+ CAIRO_SURFACE_TYPE_BEOS
+ CAIRO_SURFACE_TYPE_DIRECTFB
+ CAIRO_SURFACE_TYPE_SVG
+ CAIRO_SURFACE_TYPE_OS2
+ CAIRO_SURFACE_TYPE_WIN32_PRINTING
+ CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ;
+
+FUNCTION: cairo_surface_type_t
+cairo_surface_get_type ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_content_t
+cairo_surface_get_content ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
+
+FUNCTION: void*
+cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_surface_flush ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_mark_dirty ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ;
+
+FUNCTION: void
+cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ;
+
+FUNCTION: void
+cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ;
+
+FUNCTION: void
+cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ;
+
+FUNCTION: void
+cairo_surface_copy_page ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_show_page ( cairo_surface_t* surface ) ;
+
+! Image-surface functions
+
+TYPEDEF: int cairo_format_t
+C-ENUM:
+ CAIRO_FORMAT_ARGB32
+ CAIRO_FORMAT_RGB24
+ CAIRO_FORMAT_A8
+ CAIRO_FORMAT_A1
+ CAIRO_FORMAT_RGB16_565 ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create ( cairo_format_t format, int width, int height ) ;
+
+FUNCTION: int
+cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
+
+FUNCTION: uchar*
+cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_format_t
+cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_from_png ( char* filename ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
+
+! Pattern creation functions
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_rgb ( double red, double green, double blue ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_reference ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_pattern_destroy ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: uint
+cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_status ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void*
+cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+TYPEDEF: int cairo_pattern_type_t
+C-ENUM:
+ CAIRO_PATTERN_TYPE_SOLID
+ CAIRO_PATTERN_TYPE_SURFACE
+ CAIRO_PATTERN_TYPE_LINEAR
+ CAIRO_PATTERN_TYPE_RADIA ;
+
+FUNCTION: cairo_pattern_type_t
+cairo_pattern_get_type ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ;
+
+FUNCTION: void
+cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ;
+
+FUNCTION: void
+cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
+
+TYPEDEF: int cairo_extend_t
+C-ENUM:
+ CAIRO_EXTEND_NONE
+ CAIRO_EXTEND_REPEAT
+ CAIRO_EXTEND_REFLECT
+ CAIRO_EXTEND_PAD ;
+
+FUNCTION: void
+cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
+
+FUNCTION: cairo_extend_t
+cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
+
+TYPEDEF: int cairo_filter_t
+C-ENUM:
+ CAIRO_FILTER_FAST
+ CAIRO_FILTER_GOOD
+ CAIRO_FILTER_BEST
+ CAIRO_FILTER_NEAREST
+ CAIRO_FILTER_BILINEAR
+ CAIRO_FILTER_GAUSSIAN ;
+
+FUNCTION: void
+cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ;
+
+FUNCTION: cairo_filter_t
+cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ;
+
+! Matrix functions
+
+FUNCTION: void
+cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ;
+
+FUNCTION: void
+cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ;
+
+FUNCTION: void
+cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ;
+
+FUNCTION: cairo_status_t
+cairo_matrix_invert ( cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ;
+
+FUNCTION: void
+cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ;
+
+FUNCTION: void
+cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ;
+
+! Functions to be used while debugging (not intended for use in production code)
+FUNCTION: void
+cairo_debug_reset_static_data ( ) ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences math opengl.gadgets kernel
+byte-arrays cairo.ffi cairo io.backend
+ui.gadgets accessors opengl.gl
+arrays fry classes ;
+
+IN: cairo.gadgets
+
+: width>stride ( width -- stride ) 4 * ;
+
+: copy-cairo ( dim quot -- byte-array )
+ >r first2 over width>stride
+ [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
+ [ cairo_image_surface_create_for_data ] 3bi
+ r> with-cairo-from-surface ; inline
+
+TUPLE: cairo-gadget < texture-gadget ;
+
+: <cairo-gadget> ( dim -- gadget )
+ cairo-gadget new-gadget
+ swap >>dim ;
+
+M: cairo-gadget cache-key* [ dim>> ] [ class ] bi 2array ;
+
+: render-cairo ( dim quot -- bytes format )
+ >r 2^-bounds r> copy-cairo GL_BGRA ; inline
+
+GENERIC: render-cairo* ( gadget -- )
+
+M: cairo-gadget render*
+ [ dim>> dup ] [ '[ _ render-cairo* ] ] bi
+ render-cairo render-bytes* ;
+
+! maybe also texture>png
+! : cairo>png ( gadget path -- )
+! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
+! [ height>> ] tri over width>stride
+! cairo_image_surface_create_for_data
+! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
+
+: copy-surface ( surface -- )
+ cr swap 0 0 cairo_set_source_surface
+ cr cairo_paint ;
+
+TUPLE: png-gadget < texture-gadget path ;
+: <png> ( path -- gadget )
+ png-gadget new-gadget
+ swap >>path ;
+
+M: png-gadget render*
+ path>> normalize-path cairo_image_surface_create_from_png
+ [ cairo_image_surface_get_width ]
+ [ cairo_image_surface_get_height 2array dup 2^-bounds ]
+ [ [ copy-surface ] curry copy-cairo ] tri
+ GL_BGRA render-bytes* ;
+
+M: png-gadget cache-key* path>> ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis
+! See http://factorcode.org/license.txt for BSD license.
+!
+! these samples are a subset of the samples on
+! http://cairographics.org/samples/
+USING: cairo cairo.ffi locals math.constants math
+io.backend kernel alien.c-types libc namespaces
+cairo.gadgets ui.gadgets accessors ;
+
+IN: cairo.samples
+
+TUPLE: arc-gadget < cairo-gadget ;
+M:: arc-gadget render-cairo* ( gadget -- )
+ [let | xc [ 128.0 ]
+ yc [ 128.0 ]
+ radius [ 100.0 ]
+ angle1 [ pi 1/4 * ]
+ angle2 [ pi ] |
+ cr 10.0 cairo_set_line_width
+ cr xc yc radius angle1 angle2 cairo_arc
+ cr cairo_stroke
+
+ ! draw helping lines
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 6.0 cairo_set_line_width
+
+ cr xc yc 10.0 0 2 pi * cairo_arc
+ cr cairo_fill
+
+ cr xc yc radius angle1 angle1 cairo_arc
+ cr xc yc cairo_line_to
+ cr xc yc radius angle2 angle2 cairo_arc
+ cr xc yc cairo_line_to
+ cr cairo_stroke
+ ] ;
+
+TUPLE: clip-gadget < cairo-gadget ;
+M: clip-gadget render-cairo* ( gadget -- )
+ drop
+ cr 128 128 76.8 0 2 pi * cairo_arc
+ cr cairo_clip
+ cr cairo_new_path
+
+ cr 0 0 256 256 cairo_rectangle
+ cr cairo_fill
+ cr 0 1 0 cairo_set_source_rgb
+ cr 0 0 cairo_move_to
+ cr 256 256 cairo_line_to
+ cr 256 0 cairo_move_to
+ cr 0 256 cairo_line_to
+ cr 10 cairo_set_line_width
+ cr cairo_stroke ;
+
+TUPLE: clip-image-gadget < cairo-gadget ;
+M:: clip-image-gadget render-cairo* ( gadget -- )
+ [let* | png [ "resource:misc/icons/Factor_128x128.png"
+ normalize-path cairo_image_surface_create_from_png ]
+ w [ png cairo_image_surface_get_width ]
+ h [ png cairo_image_surface_get_height ] |
+ cr 128 128 76.8 0 2 pi * cairo_arc
+ cr cairo_clip
+ cr cairo_new_path
+
+ cr 192.0 w / 192.0 h / cairo_scale
+ cr png 32 32 cairo_set_source_surface
+ cr cairo_paint
+ png cairo_surface_destroy
+ ] ;
+
+TUPLE: dash-gadget < cairo-gadget ;
+M:: dash-gadget render-cairo* ( gadget -- )
+ [let | dashes [ { 50 10 10 10 } >c-double-array ]
+ ndash [ 4 ] |
+ cr dashes ndash -50 cairo_set_dash
+ cr 10 cairo_set_line_width
+ cr 128.0 25.6 cairo_move_to
+ cr 230.4 230.4 cairo_line_to
+ cr -102.4 0 cairo_rel_line_to
+ cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
+ cr cairo_stroke
+ ] ;
+
+TUPLE: gradient-gadget < cairo-gadget ;
+M:: gradient-gadget render-cairo* ( gadget -- )
+ [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
+ radial [ 115.2 102.4 25.6 102.4 102.4 128.0
+ cairo_pattern_create_radial ] |
+ pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+ pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+ cr 0 0 256 256 cairo_rectangle
+ cr pat cairo_set_source
+ cr cairo_fill
+ pat cairo_pattern_destroy
+
+ radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+ radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+ cr radial cairo_set_source
+ cr 128.0 128.0 76.8 0 2 pi * cairo_arc
+ cr cairo_fill
+ radial cairo_pattern_destroy
+ ] ;
+
+TUPLE: text-gadget < cairo-gadget ;
+M: text-gadget render-cairo* ( gadget -- )
+ drop
+ cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
+ cairo_select_font_face
+ cr 50 cairo_set_font_size
+ cr 10 135 cairo_move_to
+ cr "Hello" cairo_show_text
+
+ cr 70 165 cairo_move_to
+ cr "factor" cairo_text_path
+ cr 0.5 0.5 1 cairo_set_source_rgb
+ cr cairo_fill_preserve
+ cr 0 0 0 cairo_set_source_rgb
+ cr 2.56 cairo_set_line_width
+ cr cairo_stroke
+
+ ! draw helping lines
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 10 135 5.12 0 2 pi * cairo_arc
+ cr cairo_close_path
+ cr 70 165 5.12 0 2 pi * cairo_arc
+ cr cairo_fill ;
+
+TUPLE: utf8-gadget < cairo-gadget ;
+M: utf8-gadget render-cairo* ( gadget -- )
+ drop
+ cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
+ cairo_select_font_face
+ cr 50 cairo_set_font_size
+ "cairo_text_extents_t" malloc-object
+ cr "日本語" pick cairo_text_extents
+ cr over
+ [ cairo_text_extents_t-width 2 / ]
+ [ cairo_text_extents_t-x_bearing ] bi +
+ 128 swap - pick
+ [ cairo_text_extents_t-height 2 / ]
+ [ cairo_text_extents_t-y_bearing ] bi +
+ 128 swap - cairo_move_to
+ free
+ cr "日本語" cairo_show_text
+
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 6 cairo_set_line_width
+ cr 128 0 cairo_move_to
+ cr 0 256 cairo_rel_line_to
+ cr 0 128 cairo_move_to
+ cr 256 0 cairo_rel_line_to
+ cr cairo_stroke ;
+
+ USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
+ : samples ( -- )
+ {
+ arc-gadget clip-gadget clip-image-gadget dash-gadget
+ gradient-gadget text-gadget utf8-gadget
+ }
+ [ new-gadget { 256 256 } >>dim gadget. ] each ;
+
+ MAIN: samples
--- /dev/null
+Cairo graphics library binding
--- /dev/null
+! Copyright (C) 2008 Doug Coleman, Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays kernel math namespaces
+opengl.gl sequences math.vectors ui graphics.bitmap graphics.viewer
+models opengl.framebuffers ui.gadgets.worlds ui.gadgets fry alien.syntax ;
+IN: cap
+
+: screenshot-array ( world -- byte-array )
+ dim>> product 3 * <byte-array> ;
+
+: gl-screenshot ( gadget -- byte-array )
+ [
+ GL_BACK glReadBuffer
+ GL_PACK_ALIGNMENT 4 glPixelStorei
+ 0 0
+ ] dip
+ [ dim>> first2 GL_BGR GL_UNSIGNED_BYTE ]
+ [ screenshot-array ] bi
+ [ glReadPixels ] keep ;
+
+: screenshot ( window -- bitmap )
+ [ gl-screenshot ]
+ [ dim>> first2 ] bi
+ bgr>bitmap ;
+
+: save-screenshot ( window path -- )
+ [ screenshot ] dip save-bitmap ;
+
+: screenshot. ( window -- )
+ [ screenshot <graphics-gadget> ] [ title>> ] bi open-window ;
SELF-SLOTS: hsva
-: clear-color ( color -- ) set-clear-color GL_COLOR_BUFFER_BIT glClear ;
+: clear-color ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: push-color ( -- ) self> color-stack> push self> clone >self ;
-: pop-color ( -- ) color-stack> pop dup >self set-color ;
+: pop-color ( -- ) color-stack> pop dup >self gl-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: circle ( -- )
- self> set-color
+ self> gl-color
gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
: triangle ( -- )
- self> set-color
+ self> gl-color
GL_POLYGON glBegin
0 0.577 glVertex2d
0.5 -0.289 glVertex2d
glEnd ;
: square ( -- )
- self> set-color
+ self> gl-color
GL_POLYGON glBegin
-0.5 0.5 glVertex2d
0.5 0.5 glVertex2d
set-initial-color
- self> set-color
+ self> gl-color
start-shape> call
Chris Double
Clemens F. Hofreither
+James Cash
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
USING: help.markup help.syntax ;
IN: coroutines
HELP: coterminate
{ $values { "v" "an object" } }
{ $description "Terminate the current coroutine, leaving the value v on the stack when control is passed to the " { $link coresume } " caller. Resuming a terminated coroutine is a no-op." }
-{ $see-also coyield }
+{ $see-also coyield coreset }
+;
+
+HELP: coreset
+{ $values { "v" "an object" } }
+{ $description "Reset the current coroutine, leaving the value v on the stack when control is passed to the " { $link coresume } " caller. When the coroutine is resumed, it will continue at the beginning of the coroutine." }
+{ $see-also coyield coterminate }
;
HELP: current-coro
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
! See http://factorcode.org/license.txt for BSD license.
IN: coroutines.tests
USING: coroutines kernel sequences prettyprint tools.test math ;
[ [ coyield* ] each ] cocreate ;
{ "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume >r dup *coresume >r *coresume r> r> ] unit-test
+
+{ 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test
\ No newline at end of file
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel hashtables namespaces make continuations quotations
accessors ;
SYMBOL: current-coro
-TUPLE: coroutine resumecc exitcc ;
+TUPLE: coroutine resumecc exitcc originalcc ;
: cocreate ( quot -- co )
coroutine new
[ swapd , , \ bind ,
"Coroutine has terminated illegally." , \ throw ,
] [ ] make
- >>resumecc ;
+ [ >>resumecc ] [ >>originalcc ] bi ;
: coresume ( v co -- result )
[
>>exitcc
resumecc>> call
#! At this point, the coroutine quotation must have terminated
- #! normally (without calling coyield or coterminate). This shouldn't happen.
+ #! normally (without calling coyield, coreset, or coterminate). This shouldn't happen.
f over
] callcc1 2nip ;
current-coro get
[ ] >>resumecc
exitcc>> continue-with ;
+
+: coreset ( v -- )
+ current-coro get dup
+ originalcc>> >>resumecc
+ exitcc>> continue-with ;
\ No newline at end of file
ERROR: ftp-error got expected ;
: ftp-assert ( ftp-response n -- )
- 2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
+ 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
: ftp-login ( ftp-client -- )
read-response 220 ftp-assert
dupd '[
_ [ ftp-login ] [ @ ] bi
ftp-quit drop
- ] >r ftp-connect r> with-stream ; inline
+ ] [ ftp-connect ] dip with-stream ; inline
M: ftp-client ftp-download ( path ftp-client -- )
[
[ drop parent-directory ftp-cwd drop ]
- [ >r file-name r> ftp-get drop ] 2bi
+ [ [ file-name ] dip ftp-get drop ] 2bi
] with-ftp-client ;
M: string ftp-download ( path string -- )
: ftp-ipv4 1 ; inline
: ftp-ipv6 2 ; inline
-
: ch>type ( ch -- type )
{
{ CHAR: d [ +directory+ ] }
} case ;
: file-info>string ( file-info name -- string )
- >r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ]
- [ size>> number>string 15 CHAR: \s pad-left ] bi r>
- 3array " " join ;
+ [
+ [
+ [ type>> type>ch 1string ]
+ [ drop "rwx------" append ] bi
+ ]
+ [ size>> number>string 15 CHAR: \s pad-left ] bi
+ ] dip 3array " " join ;
: directory-list ( -- seq )
"" directory-files
namespaces make sequences ftp io.unix.launcher.parser
unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads
-continuations math concurrency.promises byte-arrays ;
+continuations math concurrency.promises byte-arrays sequences.lib
+hexdump ;
IN: ftp.server
SYMBOL: client
TUPLE: ftp-get path ;
: <ftp-get> ( path -- obj )
- ftp-get new swap >>path ;
+ ftp-get new
+ swap >>path ;
TUPLE: ftp-put path ;
: <ftp-put> ( path -- obj )
- ftp-put new swap >>path ;
+ ftp-put new
+ swap >>path ;
TUPLE: ftp-list ;
: handle-USER ( ftp-command -- )
[
- tokenized>> second client get swap >>user drop
+ tokenized>> second client get (>>user)
331 "Please specify the password." server-response
] [
2drop "bad USER" ftp-error
: handle-PASS ( ftp-command -- )
[
- tokenized>> second client get swap >>password drop
+ tokenized>> second client get (>>password)
230 "Login successful" server-response
] [
2drop "PASS error" ftp-error
: handle-PWD ( obj -- )
drop
- 257 current-directory get "\"" swap "\"" 3append server-response ;
+ 257 current-directory get "\"" "\"" surround server-response ;
: handle-SYST ( obj -- )
drop
215 "UNIX Type: L8" server-response ;
: if-command-promise ( quot -- )
- >r client get command-promise>> r>
+ [ client get command-promise>> ] dip
[ "Establish an active or passive connection first" ftp-error ] if* ;
: handle-STOR ( obj -- )
[
tokenized>> second
- [ >r <ftp-put> r> fulfill ] if-command-promise
+ [ [ <ftp-put> ] dip fulfill ] if-command-promise
] [
2drop
] recover ;
rot
[ file-name ] [
" " swap file-info size>> number>string
- "(" " bytes)." swapd 3append append
+ "(" " bytes)." surround append
] bi 3append server-response ;
: transfer-incoming-file ( path -- )
: handle-LIST ( obj -- )
drop
- [ >r <ftp-list> r> fulfill ] if-command-promise ;
+ [ [ <ftp-list> ] dip fulfill ] if-command-promise ;
: handle-SIZE ( obj -- )
[
expect-connection
[
"Entering Passive Mode (127,0,0,1," %
- port>bytes [ number>string ] bi@ "," swap 3append %
+ port>bytes [ number>string ] bi@ "," splice %
")" %
] "" make 227 swap server-response ;
set-current-directory
250 "Directory successully changed." server-response
] [
- not-a-directory throw
+ not-a-directory
] if
] [
2drop
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slides help.markup math arrays hashtables namespaces
+sequences kernel sequences parser memoize io.encodings.binary
+locals kernel.private tools.vocabs.browser assocs quotations
+urls peg.ebnf tools.vocabs tools.annotations tools.crossref
+help.topics math.functions compiler.tree.optimizer
+compiler.cfg.optimizer fry ;
+IN: galois-talk
+
+: galois-slides
+{
+ { $slide "Factor!"
+ { $url "http://factorcode.org" }
+ "Development started in 2003"
+ "Open source (BSD license)"
+ "Influenced by Forth, Lisp, and Smalltalk"
+ "Blurs the line between language and library"
+ "Interactive development"
+ }
+ { $slide "Words and the stack"
+ "Stack based, dynamically typed"
+ { $code "{ 1 1 3 4 4 8 9 9 } dup duplicates diff ." }
+ "Words: named code snippets"
+ { $code ": remove-duplicates ( seq -- seq' )" " dup duplicates diff ;" }
+ { $code "{ 1 1 3 4 4 8 9 9 } remove-duplicates ." }
+ }
+ { $slide "Vocabularies"
+ "Vocabularies: named sets of words"
+ { $link "vocab-index" }
+ { { $link POSTPONE: USING: } " loads dependencies" }
+ "Source, docs, tests in one place"
+ }
+ { $slide "Interactive development"
+ "Programming is hard, let's play tetris"
+ { $vocab-link "tetris" }
+ "Tetris is hard too... let's cheat"
+ "Factor workflow: change code, F2, test, repeat"
+ }
+ { $slide "Quotations"
+ "Quotation: unnamed block of code"
+ "Combinators: words taking quotations"
+ { $code "10 dup 0 < [ 1 - ] [ 1 + ] if ." }
+ { $code "{ -1 1 -2 0 3 } [ 0 max ] map ." }
+ "Partial application:"
+ { $code ": clamp ( seq n -- seq' ) '[ _ max ] map ;" "{ -1 1 -2 0 3 } 0 clamp" }
+ }
+ { $slide "Object system"
+ "CLOS with single dispatch"
+ "A tuple is a user-defined class which holds named values."
+ { $code
+ "TUPLE: rectangle width height ;"
+ "TUPLE: circle radius ;"
+ }
+ }
+ { $slide "Object system"
+ "Constructing instances:"
+ { $code "rectangle new" }
+ { $code "rectangle boa" }
+ "Let's encapsulate:"
+ { $code
+ ": <rectangle> ( w h -- r ) rectangle boa ;"
+ ": <circle> ( r -- c ) circle boa ;"
+ }
+ }
+ { $slide "Object system"
+ "Generic words and methods"
+ { $code "GENERIC: area ( shape -- n )" }
+ "Two methods:"
+ { $code
+ "USE: math.constants"
+ ""
+ "M: rectangle area"
+ " [ width>> ] [ height>> ] bi * ;"
+ ""
+ "M: circle area radius>> sq pi * ;"
+ }
+ }
+ { $slide "Object system"
+ "We can compute areas now."
+ { $code "100 20 <rectangle> area ." }
+ { $code "3 <circle> area ." }
+ }
+ { $slide "Object system"
+ "Object system handles dynamic redefinition very well"
+ { $code "TUPLE: person name age occupation ;" }
+ "Make an instance..."
+ }
+ { $slide "Object system"
+ "Let's add a new slot:"
+ { $code "TUPLE: person name age address occupation ;" }
+ "Fill it in with inspector..."
+ "Change the order:"
+ { $code "TUPLE: person name occupation address ;" }
+ }
+ { $slide "Object system"
+ "How does it work?"
+ "Objects are not hashtables; slot access is very fast"
+ "Redefinition walks the heap; expensive but rare"
+ }
+ { $slide "Object system"
+ "Supports \"duck typing\""
+ "Two tuples can have a slot with the same name"
+ "Code that uses accessors will work on both"
+ "Accessors are auto-generated generic words"
+ }
+ { $slide "Object system"
+ "Predicate classes"
+ { $code
+ "PREDICATE: positive < integer 0 > ;"
+ "PREDICATE: negative < integer 0 < ;"
+ ""
+ "GENERIC: abs ( n -- )"
+ ""
+ "M: positive abs ;"
+ "M: negative abs -1 * ;"
+ "M: integer abs ;"
+ }
+ }
+ { $slide "Object system"
+ "More: inheritance, type declarations, read-only slots, union, intersection, singleton classes, reflection"
+ "Object system is entirely implemented in Factor"
+ }
+ { $slide "The parser"
+ "All data types have a literal syntax"
+ "Literal hashtables and arrays are very useful in data-driven code"
+ "\"Code is data\" because quotations are objects (enables Lisp-style macros)"
+ { $code "H{ { \"cookies\" 12 } { \"milk\" 10 } }" }
+ "Libraries can define new parsing words"
+ }
+ { $slide "Example: regexp"
+ { $vocab-link "regexp" }
+ "Pre-compiles regexp at parse time"
+ "Implemented with library code"
+ { $code "USE: regexp" }
+ { $code "\"ababbc\" \"[ab]+c\" <regexp> matches? ." }
+ { $code "\"ababbc\" R/ [ab]+c/ matches? ." }
+ }
+ { $slide "Example: memoization"
+ { "Memoization with " { $link POSTPONE: MEMO: } }
+ { $code
+ ": fib ( m -- n )"
+ " dup 1 > ["
+ " [ 1 - fib ] [ 2 - fib ] bi +"
+ " ] when ;"
+ }
+ "Very slow! Let's profile it..."
+ }
+ { $slide "Example: memoization"
+ { "Let's use " { $link POSTPONE: : } " instead of " { $link POSTPONE: MEMO: } }
+ { $code
+ "MEMO: fib ( m -- n )"
+ " dup 1 > ["
+ " [ 1 - fib ] [ 2 - fib ] bi +"
+ " ] when ;"
+ }
+ "Much faster"
+ }
+ { $slide "Meta-circularity"
+ { { $link POSTPONE: MEMO: } " is just a library word" }
+ { "But so is " { $link POSTPONE: : } }
+ "Factor's parser is written in Factor"
+ { "All syntax is just parsing words: " { $link POSTPONE: [ } ", " { $link POSTPONE: " } }
+ }
+ { $slide "Extensible syntax, DSLs"
+ "Most parsing words fall in one of two categories"
+ "First category: literal syntax for new data types"
+ "Second category: defining new types of words"
+ "Some parsing words are more complicated"
+ }
+ { $slide "Example: printf"
+ { { $link POSTPONE: EBNF: } ": a complex parsing word" }
+ "Implements a custom syntax for expressing parsers: like OMeta!"
+ { "Example: " { $vocab-link "printf-example" } }
+ { $code "\"vegan\" \"cheese\" \"%s is not %s\\n\" printf" }
+ { $code "5 \"Factor\" \"%s is %d years old\\n\" printf" }
+ }
+ { $slide "Example: simple web browser"
+ { $vocab-link "webkit-demo" }
+ "Demonstrates Cocoa binding"
+ "Let's deploy a stand-alone binary with the deploy tool"
+ "Deploy tool generates binaries with no external dependencies"
+ }
+ { $slide "Locals and lexical scope"
+ "Sometimes, there's no good stack solution to a problem"
+ "Or, you're porting existing code in a quick-and-dirty way"
+ "Our solution: implement named locals as a DSL in Factor"
+ "Influenced by Scheme and Lisp"
+ }
+ { $slide "Locals and lexical scope"
+ { "Define lambda words with " { $link POSTPONE: :: } }
+ { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+ "Mutable bindings with correct semantics"
+ { "Named inputs for quotations with " { $link POSTPONE: [| } }
+ "Full closures"
+ }
+ { $slide "Locals and lexical scope"
+ "Combinator with 5 parameters!"
+ { $code
+ ":: branch ( a b neg zero pos -- )"
+ " a b = zero [ a b < neg pos if ] if ; inline"
+ }
+ "Unwieldy with the stack"
+ }
+ { $slide "Locals and lexical scope"
+ { $code
+ ": check-drinking-age ( age -- )"
+ " 21"
+ " [ \"You're underage!\" print ]"
+ " [ \"Grats, you're now legal\" print ]"
+ " [ \"Go get hammered\" print ]"
+ " branch ;"
+ }
+ }
+ { $slide "Locals and lexical scope"
+ "Locals are entirely implemented in Factor"
+ "Example of compile-time meta-programming"
+ "No performance penalty -vs- using the stack"
+ "In the base image, only 59 words out of 13,000 use locals"
+ }
+ { $slide "More about partial application"
+ { { $link POSTPONE: '[ } " is \"fry syntax\"" }
+ { $code "'[ _ + ] == [ + ] curry" }
+ { $code "'[ @ t ] == [ t ] compose" }
+ { $code "'[ _ nth @ ] == [ [ nth ] curry ] dip compose" }
+ { $code "'[ [ _ ] dip nth ] == [ [ ] curry dip nth ] curry" }
+ { "Fry and locals desugar to " { $link curry } ", " { $link compose } }
+ }
+ { $slide "Help system"
+ "Help markup is just literal data"
+ { "Look at the help for " { $link T{ link f + } } }
+ "These slides are built with the help system and a custom style sheet"
+ { $vocab-link "galois-talk" }
+ }
+ { $slide "Why stack-based?"
+ "Because nobody else is doing it"
+ "Interesting properties: concatenation is composition, chaining functions together, \"fluent\" interfaces, new combinators"
+ { $vocab-link "smtp-example" }
+ { $code
+ "{ \"chicken\" \"beef\" \"pork\" \"turkey\" }"
+ "[ 5 short head ] map ."
+ }
+ }
+ { $slide "Implementation"
+ "VM: garbage collection, bignums, ..."
+ "Bootstrap image: parser, hashtables, object system, ..."
+ "Non-optimizing compiler"
+ "Stage 2 bootstrap: optimizing compiler, UI, ..."
+ "Full image contains machine code"
+ }
+ { $slide "Compiler"
+ { "Let's look at " { $vocab-link "benchmark.mandel" } }
+ "A naive implementation would be very slow"
+ "Combinators, partial application"
+ "Boxed complex numbers"
+ "Boxed floats"
+ { "Redundancy in " { $link absq } " and " { $link sq } }
+ }
+ { $slide "Compiler: high-level optimizer"
+ "High-level SSA IR"
+ "Type inference (classes, intervals, arrays with a fixed length, literals, ...)"
+ "Escape analysis and tuple unboxing"
+ }
+ { $slide "Compiler: high-level optimizer"
+ "Loop index becomes a fixnum, complex numbers unboxed, generic arithmetic inlined, higher-order code become first-order..."
+ { $code "[ c pixel ] optimized." }
+ }
+ { $slide "Compiler: low-level optimizer"
+ "Low-level SSA IR"
+ "Alias analysis"
+ "Value numbering"
+ "Linear scan register allocation"
+ }
+ { $slide "Compiler: low-level optimizer"
+ "Redundant stack operations eliminated, intermediate floats unboxed..."
+ { $code "[ c pixel ] test-mr mr." }
+ }
+ { $slide "Garbage collection"
+ "All roots are identified precisely"
+ "Generational copying for data"
+ "Mark sweep for native code"
+ }
+ { $slide "Project infrastructure"
+ { $url "http://factorcode.org" }
+ { $url "http://concatenative.org" }
+ { $url "http://docs.factorcode.org" }
+ { $url "http://planet.factorcode.org" }
+ "Uses our HTTP server, SSL, DB, Atom libraries..."
+ }
+ { $slide "Project infrastructure"
+ "Build farm, written in Factor"
+ "12 platforms"
+ "Builds Factor and all libraries, runs tests, makes binaries"
+ "Saves us from the burden of making releases by hand"
+ "Maintains stability"
+ }
+ { $slide "Community"
+ "#concatenative irc.freenode.net: 50-60 members"
+ "factor-talk@lists.sf.net: 180 subscribers"
+ "About 30 people have code in the Factor repository"
+ "Easy to get started: binaries, lots of docs, friendly community..."
+ }
+ { $slide "That's all, folks"
+ "It is hard to cover everything in a single talk"
+ "Factor has many cool things that I didn't talk about"
+ "Questions?"
+ }
+} ;
+
+: galois-talk ( -- ) galois-slides slides-window ;
+
+MAIN: galois-talk
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slides help.markup math arrays hashtables namespaces
+sequences kernel sequences parser memoize io.encodings.binary
+locals kernel.private tools.vocabs.browser assocs quotations
+urls peg.ebnf tools.vocabs tools.annotations tools.crossref
+help.topics math.functions compiler.tree.optimizer
+compiler.cfg.optimizer fry ;
+IN: google-tech-talk
+
+: google-slides
+{
+ { $slide "Factor!"
+ { $url "http://factorcode.org" }
+ "Development started in 2003"
+ "Open source (BSD license)"
+ "First result for \"Factor\" on Google :-)"
+ "Influenced by Forth, Lisp, and Smalltalk (but don't worry if you don't know them)"
+ }
+ { $slide "Language overview"
+ "Words operate on a stack"
+ "Functional"
+ "Object-oriented"
+ "Rich collections library"
+ "Rich input/output library"
+ "Optional named local variables"
+ "Extensible syntax"
+ }
+ { $slide "Example: factorial"
+ "Lame example, but..."
+ { $code "USE: math.ranges" ": factorial ( n -- n! )" " 1 [a,b] product ;" }
+ { $code "100 factorial ." }
+ }
+ { $slide "Example: sending an e-mail"
+ { $vocab-link "smtp-example" }
+ "Demonstrates basic stack syntax and tuple slot setters"
+ }
+ { $slide "Functional programming"
+ "Code is data in Factor"
+ { { $snippet "[ ... ]" } " is a block of code pushed on the stack" }
+ { "We call them " { $emphasis "quotations" } }
+ { "Words which take quotations as input are called " { $emphasis "combinators" } }
+ }
+ { $slide "Functional programming"
+ { $code "10 dup 0 < [ 1 - ] [ 1 + ] if ." }
+ { $code "10 [ \"Hello Googlers!\" print ] times" }
+ { $code
+ "USING: io.encodings.ascii unicode.case ;"
+ "{ \"tomato\" \"orange\" \"banana\" }"
+ "\"out.txt\" ascii ["
+ " [ >upper print ] each"
+ "] with-file-writer"
+ }
+ }
+ { $slide "Object system: motivation"
+ "Encapsulation, polymorphism, inheritance"
+ "Smalltalk, Python, Java approach: methods inside classes"
+ "Often the \"message sending\" metaphor is used to describe such systems"
+ }
+ { $slide "Object system: motivation"
+ { $code
+ "class Rect {"
+ " int x, y;"
+ " int area() { ... }"
+ " int perimeter() { ... }"
+ "}"
+ ""
+ "class Circle {"
+ " int radius;"
+ " int area() { ... }"
+ " int perimeter() { ... }"
+ "}"
+ }
+ }
+ { $slide "Object system: motivation"
+ "Classical functional language approach: functions switch on a type"
+ { $code
+ "data Shape = Rect w h | Circle r"
+ ""
+ "area s = s of"
+ " (Rect w h) = ..."
+ "| (Circle r) = ..."
+ ""
+ "perimeter s = s of"
+ " (Rect w h) = ..."
+ "| (Circle r) = ..."
+ }
+ }
+ { $slide "Object system: motivation"
+ "First approach: hard to extend existing types with new operations (open classes, etc are a hack)"
+ "Second approach: hard to extend existing operations with new types"
+ "Common Lisp Object System (CLOS): decouples classes from methods."
+ "Factor's object system is a simplified CLOS"
+ }
+ { $slide "Object system"
+ "A tuple is a user-defined class which holds named values."
+ { $code
+ "TUPLE: rectangle width height ;"
+ "TUPLE: circle radius ;"
+ }
+ }
+ { $slide "Object system"
+ "Constructing instances:"
+ { $code "rectangle new" }
+ { $code "rectangle boa" }
+ "Let's encapsulate:"
+ { $code
+ ": <rectangle> ( w h -- r ) rectangle boa ;"
+ ": <circle> ( r -- c ) circle boa ;"
+ }
+ }
+ { $slide "Object system"
+ "Generic words and methods"
+ { $code "GENERIC: area ( shape -- n )" }
+ "Two methods:"
+ { $code
+ "USE: math.constants"
+ ""
+ "M: rectangle area"
+ " [ width>> ] [ height>> ] bi * ;"
+ ""
+ "M: circle area radius>> sq pi * ;"
+ }
+ }
+ { $slide "Object system"
+ "We can compute areas now."
+ { $code "100 20 <rectangle> area ." }
+ { $code "3 <circle> area ." }
+ }
+ { $slide "Object system"
+ "New operation, existing types:"
+ { $code
+ "GENERIC: perimeter ( shape -- n )"
+ ""
+ "M: rectangle perimeter"
+ " [ width>> ] [ height>> ] bi + 2 * ;"
+ ""
+ "M: circle perimeter"
+ " radius>> 2 * pi * ;"
+ }
+ }
+ { $slide "Object system"
+ "We can compute perimeters now."
+ { $code "100 20 <rectangle> perimeter ." }
+ { $code "3 <circle> perimeter ." }
+ }
+ { $slide "Object system"
+ "New type, extending existing operations:"
+ { $code
+ "TUPLE: triangle base height ;"
+ ""
+ ": <triangle> ( b h -- t ) triangle boa ;"
+ ""
+ "M: triangle area"
+ " [ base>> ] [ height>> ] bi * 2 / ;"
+ }
+ }
+ { $slide "Object system"
+ "New type, extending existing operations:"
+ { $code
+ ": hypotenuse ( x y -- z ) [ sq ] bi@ + sqrt ;"
+ ""
+ "M: triangle perimeter"
+ " [ base>> ] [ height>> ] bi"
+ " [ + ] [ hypotenuse ] 2bi + ;"
+ }
+ }
+ { $slide "Object system"
+ "We can ask an object if its a rectangle:"
+ { $code "70 65 <rectangle> rectangle? ." }
+ { $code "13 <circle> rectangle? ." }
+ { "How do we tell if something is a " { $emphasis "shape" } "?" }
+ }
+ { $slide "Object system"
+ "We define a mixin class for shapes, and add our existing data types as instances:"
+ { $code
+ "MIXIN: shape"
+ "INSTANCE: rectangle shape"
+ "INSTANCE: circle shape"
+ "INSTANCE: triangle shape"
+ }
+ }
+ { $slide "Object system"
+ "Now, we can ask objects if they are shapes or not:"
+ { $code "13 <circle> shape? ." }
+ { $code "3.14 shape? ." }
+ }
+ { $slide "Object system"
+ "Or put methods on shapes:"
+ { $code
+ "GENERIC: tell-me ( obj -- )"
+ ""
+ "M: shape tell-me"
+ " \"My area is \" write area . ;"
+ ""
+ "M: integer tell-me"
+ " \"I am \" write"
+ " even? \"even\" \"odd\" ? print ;"
+ }
+ }
+ { $slide "Object system"
+ "Let's test our new generic word:"
+ { $code "13 <circle> tell-me" }
+ { $code "103 76 <rectangle> tell-me" }
+ { $code "101 tell-me" }
+ { { $link integer } ", " { $link array } ", and others area built-in classes" }
+ }
+ { $slide "Object system"
+ "Anyone can define new shapes..."
+ { $code
+ "TUPLE: parallelogram ... ;"
+ ""
+ "INSTANCE: parallelogram shape"
+ ""
+ "M: parallelogram area ... ;"
+ ""
+ "M: parallelogram perimeter ... ;"
+ }
+ }
+ { $slide "Object system"
+ "More: inheritance, type declarations, read-only slots, predicate, intersection, singleton classes, reflection"
+ "Object system is entirely implemented in Factor: 2184 lines"
+ { { $vocab-link "generic" } ", " { $vocab-link "classes" } ", " { $vocab-link "slots" } }
+ }
+ { $slide "Collections"
+ "Sequences (arrays, vector, strings, ...)"
+ "Associative mappings (hashtables, ...)"
+ { "More: deques, heaps, purely functional structures, disjoint sets, and more: "
+ { $link T{ vocab-tag f "collections" } } }
+ }
+ { $slide "Sequences"
+ { "Protocol: " { $link length } ", " { $link set-length } ", " { $link nth } ", " { $link set-nth } }
+ { "Combinators: " { $link each } ", " { $link map } ", " { $link filter } ", " { $link produce } ", and more: " { $link "sequences-combinators" } }
+ { "Utilities: " { $link append } ", " { $link reverse } ", " { $link first } ", " { $link second } ", ..." }
+ }
+ { $slide "Example: bin packing"
+ { "We have " { $emphasis "m" } " objects and " { $emphasis "n" } " bins, and we want to distribute these objects as evenly as possible." }
+ { $vocab-link "distribute-example" }
+ "Demonstrates various sequence utilities and vector words"
+ { $code "20 13 distribute ." }
+ }
+ { $slide "Unicode strings"
+ "Strings are sequences of 21-bit Unicode code points"
+ "Efficient implementation: ASCII byte string unless it has chars > 127"
+ "If a byte char has high bit set, the remaining 14 bits come from auxilliary vector"
+ }
+ { $slide "Unicode strings"
+ "Unicode-aware case conversion, char classes, collation, word breaks, and so on..."
+ { $code "USE: unicode.case" "\"ß\" >upper ." }
+ }
+ { $slide "Unicode strings"
+ "All external byte I/O is encoded/decoded"
+ "ASCII, UTF8, UTF16, EBCDIC..."
+ { $code "USE: io.encodings.utf8" "\"document.txt\" utf8" "[ readln ] with-file-reader" }
+ { "Binary I/O is supported as well with the " { $link binary } " encoding" }
+ }
+ { $slide "Associative mappings"
+ { "Protocol: " { $link assoc-size } ", " { $link at* } ", " { $link set-at } ", " { $link delete-at } }
+ { "Combinators: " { $link assoc-each } ", " { $link assoc-map } ", " { $link assoc-filter } ", and more: " { $link "assocs-combinators" } }
+ { "Utilities: " { $link at } ", " { $link key? } ", ..." }
+ }
+ ! { $slide "Example: soundex"
+ ! { $vocab-link "soundex" }
+ ! "From Wikipedia: \"Soundex is a phonetic algorithm for indexing names by sound, as pronounced in English.\""
+ ! "Factored into many small words, uses sequence and assoc operations, no explicit loops"
+ ! }
+ { $slide "Locals and lexical scope"
+ "Sometimes, there's no good stack solution to a problem"
+ "Or, you're porting existing code in a quick-and-dirty way"
+ "Our solution: implement named locals as a DSL in Factor"
+ "Influenced by Scheme and Lisp"
+ }
+ { $slide "Locals and lexical scope"
+ { "Define lambda words with " { $link POSTPONE: :: } }
+ { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+ "Mutable bindings with correct semantics"
+ { "Named inputs for quotations with " { $link POSTPONE: [| } }
+ "Full closures"
+ }
+ { $slide "Locals and lexical scope"
+ "Two examples:"
+ { $vocab-link "lambda-quadratic" }
+ { $vocab-link "closures-example" }
+ }
+ { $slide "Locals and lexical scope"
+ "Locals are entirely implemented in Factor: 477 lines"
+ "Example of compile-time meta-programming"
+ "No performance penalty -vs- using the stack"
+ "In the base image, only 59 words out of 13,000 use locals"
+ }
+ { $slide "The parser"
+ "All data types have a literal syntax"
+ "Literal hashtables and arrays are very useful in data-driven code"
+ "\"Code is data\" because quotations are objects (enables Lisp-style macros)"
+ { $code "H{ { \"cookies\" 12 } { \"milk\" 10 } }" }
+ "Libraries can define new parsing words"
+ }
+ { $slide "The parser"
+ { "Example: URLs define a " { $link POSTPONE: URL" } " word" }
+ { $code "URL\" http://paste.factorcode.org/paste?id=81\"" }
+ }
+ { $slide "Example: memoization"
+ { "Memoization with " { $link POSTPONE: MEMO: } }
+ { $code
+ ": fib ( m -- n )"
+ " dup 1 > ["
+ " [ 1 - fib ] [ 2 - fib ] bi +"
+ " ] when ;"
+ }
+ "Very slow! Let's profile it..."
+ }
+ { $slide "Example: memoization"
+ { "Let's use " { $link POSTPONE: : } " instead of " { $link POSTPONE: MEMO: } }
+ { $code
+ "MEMO: fib ( m -- n )"
+ " dup 1 > ["
+ " [ 1 - fib ] [ 2 - fib ] bi +"
+ " ] when ;"
+ }
+ "Much faster"
+ }
+ { $slide "Meta-circularity"
+ { { $link POSTPONE: MEMO: } " is just a library word" }
+ { "But so is " { $link POSTPONE: : } }
+ "Factor's parser is written in Factor"
+ { "All syntax is just parsing words: " { $link POSTPONE: [ } ", " { $link POSTPONE: " } }
+ }
+ { $slide "Extensible syntax, DSLs"
+ "Most parsing words fall in one of two categories"
+ "First category: literal syntax for new data types"
+ "Second category: defining new types of words"
+ "Some parsing words are more complicated"
+ }
+ { $slide "Parser expression grammars"
+ { { $link POSTPONE: EBNF: } ": a complex parsing word" }
+ "Implements a custom syntax for expressing parsers"
+ { "Example: " { $vocab-link "printf-example" } }
+ { $code "\"vegan\" \"cheese\" \"%s is not %s\\n\" printf" }
+ { $code "5 \"Factor\" \"%s is %d years old\\n\" printf" }
+ }
+ { $slide "Input/output library"
+ "One of Factor's strongest points: portable, full-featured, efficient"
+ { $vocab-link "io.files" }
+ { $vocab-link "io.launcher" }
+ { $vocab-link "io.monitors" }
+ { $vocab-link "io.mmap" }
+ { $vocab-link "http.client" }
+ "... and so on"
+ }
+ { $slide "Example: file system monitors"
+ { $code
+ "USE: io.monitors"
+ ""
+ ": forever ( quot -- ) '[ @ t ] loop ; inline"
+ ""
+ "\"/tmp\" t <monitor>"
+ "'[ _ next-change . . ] forever"
+ }
+ }
+ { $slide "Example: time server"
+ { $vocab-link "time-server" }
+ { "Demonstrates " { $vocab-link "io.servers.connection" } " vocabulary, threads" }
+ }
+ { $slide "Example: what is my IP?"
+ { $vocab-link "webapps.ip" }
+ "Simple web app, defines a single action, use an XHTML template"
+ "Web framework supports more useful features: sessions, SSL, form validation, ..."
+ }
+ { $slide "Example: Yahoo! web search"
+ { $vocab-link "yahoo" }
+ { "Demonstrates " { $vocab-link "http.client" } ", " { $vocab-link "xml" } }
+ }
+ { $slide "Example: simple web browser"
+ { $vocab-link "webkit-demo" }
+ "Demonstrates Cocoa binding"
+ "Let's deploy a stand-alone binary with the deploy tool"
+ "Deploy tool generates binaries with no external dependencies"
+ }
+ { $slide "Example: environment variables"
+ { $vocab-link "environment" }
+ "Hooks are generic words which dispatch on dynamically-scoped variables"
+ { "Implemented in an OS-specific way: " { $vocab-link "environment.unix" } ", " { $vocab-link "environment.winnt" } }
+ }
+ { $slide "Example: environment variables"
+ "Implementations use C FFI"
+ "Call C functions, call function pointers, call Factor from C, structs, floats, ..."
+ "No need to write C wrapper code"
+ }
+ { $slide "Implementation"
+ "VM: 12,000 lines of C"
+ "Generational garbage collection"
+ "core: 9,000 lines of Factor"
+ "Optimizing native code compiler for x86, PowerPC"
+ "basis: 80,000 lines of Factor"
+ }
+ { $slide "Compiler"
+ { "Let's look at " { $vocab-link "benchmark.mandel" } }
+ "A naive implementation would be very slow"
+ "Combinators, currying, partial application"
+ "Boxed complex numbers"
+ "Boxed floats"
+ { "Redundancy in " { $link absq } " and " { $link sq } }
+ }
+ { $slide "Compiler: front-end"
+ "Builds high-level tree SSA IR"
+ "Stack code with uniquely-named values"
+ "Inlines combinators and calls to quotations"
+ { $code "USING: compiler.tree.builder compiler.tree.debugger ;" "[ c pixel ] build-tree nodes>quot ." }
+ }
+ { $slide "Compiler: high-level optimizer"
+ "12 optimization passes"
+ { $link optimize-tree }
+ "Some passes collect information, others use the results of past analysis to rewrite the code"
+ }
+ { $slide "Compiler: propagation pass"
+ "Propagation pass computes types with type function"
+ { "Example: output type of " { $link + } " depends on the types of inputs" }
+ "Type: can be a class, a numeric interval, array with a certain length, tuple with certain type slots, literal value, ..."
+ "Mandelbrot: we infer that we're working on complex floats"
+ }
+ { $slide "Compiler: propagation pass"
+ "Propagation also supports \"constraints\""
+ { $code "[ dup array? [ first ] when ] optimized." }
+ { $code "[ >fixnum dup 0 < [ 1 + ] when ] optimized." }
+ { $code
+ "["
+ " >fixnum"
+ " dup [ -10 > ] [ 10 < ] bi and"
+ " [ 1 + ] when"
+ "] optimized."
+ }
+ }
+ { $slide "Compiler: propagation pass"
+ "Eliminates method dispatch, inlines method bodies"
+ "Mandelbrot: we infer that integer indices are fixnums"
+ "Mandelbrot: we eliminate generic arithmetic"
+ }
+ { $slide "Compiler: escape analysis"
+ "We identify allocations for tuples which are never returned or passed to other words (except slot access)"
+ { "Partial application with " { $link POSTPONE: '[ } }
+ "Complex numbers"
+ }
+ { $slide "Compiler: escape analysis"
+ { "Virtual sequences: " { $link <slice> } ", " { $link <reversed> } }
+ { $code "[ <reversed> [ . ] each ] optimized." }
+ { "Mandelbrot: we unbox " { $link curry } ", complex number allocations" }
+ }
+ { $slide "Compiler: dead code elimination"
+ "Cleans up the mess from previous optimizations"
+ "After inlining and dispatch elimination, dead code comes up because of unused generality"
+ { "No-ops like " { $snippet "0 +" } ", " { $snippet "1 *" } }
+ "Literals which are never used"
+ "Side-effect-free words whose outputs are dropped"
+ }
+ { $slide "Compiler: low level IR"
+ "Register-based SSA"
+ "Stack operations expand into low-level instructions"
+ { $code "[ 5 ] test-mr mr." }
+ { $code "[ swap ] test-mr mr." }
+ { $code "[ append reverse ] test-mr mr." }
+ }
+ { $slide "Compiler: low-level optimizer"
+ "5 optimization passes"
+ { $link optimize-cfg }
+ "Gets rid of redundancy which is hidden in high-level stack code"
+ }
+ { $slide "Compiler: optimize memory"
+ "First pass optimizes stack and memory operations"
+ { "Example: " { $link 2array } }
+ { { $link <array> } " fills array with initial value" }
+ "What if we immediately store new values into the array?"
+ { $code "\\ 2array test-mr mr." }
+ "Mandelbrot: we optimize stack operations"
+ }
+ { $slide "Compiler: value numbering"
+ "Identifies expressions which are computed more than once in a basic block"
+ "Simplifies expressions with various identities"
+ "Mandelbrot: redundant float boxing and unboxing, redundant arithmetic"
+ }
+ { $slide "Compiler: dead code elimination"
+ "Dead code elimination for low-level IR"
+ "Again, cleans up results of prior optimizations"
+ }
+ { $slide "Compiler: register allocation"
+ "IR assumes an infinite number of registers which are only assigned once"
+ "Real CPUs have a finite set of registers which can be assigned any number of times"
+ "\"Linear scan register allocation with second-chance binpacking\""
+ }
+ { $slide "Compiler: register allocation"
+ "3 steps:"
+ "Compute live intervals"
+ "Allocate registers"
+ "Assign registers and insert spills"
+ }
+ { $slide "Compiler: register allocation"
+ "Step 1: compute live intervals"
+ "We number all instructions consecutively"
+ "A live interval associates a virtual register with a list of usages"
+ }
+ { $slide "Compiler: register allocation"
+ "Step 2: allocate registers"
+ "We scan through sorted live intervals"
+ "If a physical register is available, assign"
+ "Otherwise, find live interval with furthest away use, split it, look at both parts again"
+ }
+ { $slide "Compiler: register allocation"
+ "Step 3: assign registers and insert spills"
+ "Simple IR rewrite step"
+ "After register allocation, one vreg may have several live intervals, and different physical registers at different points in time"
+ "Hence, \"second chance\""
+ { "Mandelbrot: " { $code "[ c pixel ] test-mr mr." } }
+ }
+ { $slide "Compiler: code generation"
+ "Iterate over list of instructions"
+ "Extract tuple slots and call hooks"
+ { $vocab-link "cpu.architecture" }
+ "Finally, we hand the code to the VM"
+ { $code "\\ 2array disassemble" }
+ }
+ { $slide "Garbage collection"
+ "All roots are identified precisely"
+ "Generational copying for data"
+ "Mark sweep for native code"
+ }
+ { $slide "Project infrastructure"
+ { $url "http://factorcode.org" }
+ { $url "http://concatenative.org" }
+ { $url "http://docs.factorcode.org" }
+ { $url "http://planet.factorcode.org" }
+ "Uses our HTTP server, SSL, DB, Atom libraries..."
+ }
+ { $slide "Project infrastructure"
+ "Build farm, written in Factor"
+ "12 platforms"
+ "Builds Factor and all libraries, runs tests, makes binaries"
+ "Saves us from the burden of making releases by hand"
+ "Maintains stability"
+ }
+ { $slide "Community"
+ "#concatenative irc.freenode.net: 50-60 members"
+ "factor-talk@lists.sf.net: 180 subscribers"
+ "About 30 people have code in the Factor repository"
+ "Easy to get started: binaries, lots of docs, friendly community..."
+ }
+ { $slide "Future direction: Factor 1.0"
+ "Continue doing what we're doing:"
+ "Polish off some language features"
+ "Stability"
+ "Performance"
+ "Documentation"
+ "Developer tools"
+ }
+ { $slide "Future direction: Factor 2.0"
+ "Native threads"
+ "Syntax-aware Factor editor"
+ "Embedding Factor in C apps"
+ "Cross-compilation for smaller devices"
+ }
+ { $slide "That's all, folks"
+ "It is hard to cover everything in a single talk"
+ "Factor has many cool things that I didn't talk about"
+ "Put your prejudices aside and give it a shot!"
+ }
+ { $slide "Questions?" }
+} ;
+
+: google-talk ( -- ) google-slides slides-window ;
+
+MAIN: google-talk
io.backend graphics.viewer io io.binary io.files kernel libc
math math.functions namespaces opengl opengl.gl prettyprint
sequences strings ui ui.gadgets.panes io.encodings.binary
-accessors ;
+accessors grouping ;
IN: graphics.bitmap
! Currently can only handle 24bit bitmaps.
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index array ;
-: raw-bitmap>string ( str n -- str )
+: bgr>bitmap ( array height width -- bitmap )
+ bitmap new
+ 2over * 3 * >>size-image
+ swap >>height
+ swap >>width
+ swap [ >>array ] [ >>color-index ] bi
+ 24 >>bit-count ;
+
+: 8bit>array ( bitmap -- array )
+ [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+ [ color-index>> >array ] bi [ swap nth ] with map concat ;
+
+: 4bit>array ( bitmap -- array )
+ [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+ [ color-index>> >array ] bi [ swap nth ] with map concat ;
+
+: raw-bitmap>array ( bitmap -- array )
+ dup bit-count>>
{
{ 32 [ "32bit" throw ] }
- { 24 [ ] }
+ { 24 [ color-index>> ] }
{ 16 [ "16bit" throw ] }
- { 8 [ "8bit" throw ] }
- { 4 [ "4bit" throw ] }
+ { 8 [ 8bit>array ] }
+ { 4 [ 4bit>array ] }
{ 2 [ "2bit" throw ] }
{ 1 [ "1bit" throw ] }
- } case ;
+ } case >byte-array ;
ERROR: bitmap-magic ;
: load-bitmap ( path -- bitmap )
normalize-path binary [
- T{ bitmap } clone
- dup parse-file-header
- dup parse-bitmap-header
- dup parse-bitmap
+ bitmap new
+ dup parse-file-header
+ dup parse-bitmap-header
+ dup parse-bitmap
] with-file-reader
- dup color-index>> over bit-count>>
- raw-bitmap>string >byte-array >>array ;
+ dup raw-bitmap>array >>array ;
: save-bitmap ( bitmap path -- )
binary [
- "BM" write
+ "BM" >byte-array write
dup array>> length 14 + 40 + 4 >le write
0 4 >le write
54 4 >le write
[ bit-count>> 24 or 2 >le write ]
[ compression>> 0 or 4 >le write ]
[ size-image>> 4 >le write ]
- [ x-pels>> 4 >le write ]
- [ y-pels>> 4 >le write ]
- [ color-used>> 4 >le write ]
- [ color-important>> 4 >le write ]
+ [ x-pels>> 0 or 4 >le write ]
+ [ y-pels>> 0 or 4 >le write ]
+ [ color-used>> 0 or 4 >le write ]
+ [ color-important>> 0 or 4 >le write ]
[ rgb-quads>> write ]
[ color-index>> write ]
} cleave
bit-count>> {
! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
+ { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
+ { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
} case
] keep array>> glDrawPixels ;
USING: tools.deploy.config ;
H{
- { deploy-word-defs? f }
- { deploy-random? f }
- { deploy-name "Hello world" }
{ deploy-threads? t }
- { deploy-compiler? t }
{ deploy-math? t }
+ { deploy-name "Hello world" }
{ deploy-c-types? f }
- { deploy-io 1 }
- { deploy-reflection 1 }
+ { deploy-word-props? f }
+ { deploy-io 2 }
{ deploy-ui? t }
{ "stop-after-last-window?" t }
- { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-compiler? t }
+ { deploy-reflection 1 }
}
{ deploy-threads? f }
{ deploy-word-props? f }
{ deploy-reflection 2 }
- { deploy-random? f }
{ deploy-io 2 }
{ deploy-math? f }
{ deploy-ui? f }
[ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
+
+[
+ "Length: 3, 3h\n00000000h: 01 02 03 ...\n" ] [ B{ 1 2 3 } hexdump ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io io.streams.string kernel math math.parser
-namespaces prettyprint sequences splitting grouping strings
-ascii ;
+namespaces sequences splitting grouping strings ascii ;
IN: hexdump
<PRIVATE
: write-header ( len -- )
"Length: " write
- [ unparse write ", " write ]
+ [ number>string write ", " write ]
[ >hex write "h" write nl ] bi ;
: write-offset ( lineno -- )
16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
-: write-hex-digit ( digit -- )
- >hex 2 CHAR: 0 pad-left write ;
+: >hex-digit ( digit -- str )
+ >hex 2 CHAR: 0 pad-left " " append ;
-: write-hex-line ( str n -- )
- write-offset
- dup [ write-hex-digit bl ] each
- 16 over length - 3 * CHAR: \s <string> write
- [ dup printable? [ drop CHAR: . ] unless write1 ] each
- nl ;
+: >hex-digits ( bytes -- str )
+ [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ;
+
+: >ascii ( bytes -- str )
+ [ [ printable? ] keep CHAR: . ? ] "" map-as ;
+
+: write-hex-line ( bytes lineno -- )
+ write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
PRIVATE>
-: hexdump ( seq -- str )
- [
- [ length write-header ]
- [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi
- ] with-string-writer ;
+: hexdump. ( seq -- )
+ [ length write-header ]
+ [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
-: hexdump. ( seq -- ) hexdump write ;
+: hexdump ( seq -- str )
+ [ hexdump. ] with-string-writer ;
\ pick [ >r pick r> =/fail ] define-inverse
\ tuck [ swapd [ =/fail ] keep ] define-inverse
+\ not [ not ] define-inverse
+\ >boolean [ { t f } memq? assure ] define-inverse
+
\ >r [ r> ] define-inverse
\ r> [ >r ] define-inverse
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences float-arrays ;
+USING: accessors alien.c-types jamshred.game jamshred.oint
+jamshred.player jamshred.tunnel kernel math math.constants
+math.functions math.vectors opengl opengl.gl opengl.glu
+opengl.demo-support sequences float-arrays ;
IN: jamshred.gl
: min-vertices 6 ; inline
dup [ / pi 2 * * ] curry map ;
: draw-segment-vertex ( segment theta -- )
- over color>> set-color segment-vertex-and-normal
+ over color>> gl-color segment-vertex-and-normal
gl-normal gl-vertex ;
: draw-vertex-pair ( theta next-segment segment -- )
{ deploy-io 2 }
{ deploy-word-defs? f }
{ deploy-c-types? t }
- { deploy-random? t }
{ deploy-word-props? f }
{ deploy-reflection 1 }
{ deploy-threads? t }
IN: lisp
USING: help.markup help.syntax ;
+HELP: <LISP
+{ $description "parsing word which converts the lisp code between <LISP and LISP> into factor quotations and calls it" }
+{ $see-also lisp-string>factor } ;
+
+HELP: lisp-string>factor
+{ $values { "str" "a string of lisp code" } { "quot" "the quotation the lisp compiles into" } }
+{ $description "Turns a string of lisp into a factor quotation" } ;
ARTICLE: "lisp" "Lisp in Factor"
"This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl
<LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
] unit-test
+ { { 3 3 4 } } [
+ <LISP (defun foo (x y &rest z)
+ (cons (+ x y) z))
+ (foo 1 2 3 4)
+ LISP> cons>seq
+ ] unit-test
+
] with-interactive-vocabs
: macro-expand ( cons -- quot )
uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
-<PRIVATE
-: (expand-macros) ( cons -- cons )
- [ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
-PRIVATE>
-
: expand-macros ( cons -- cons )
- dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ;
-
+ dup list? [ [ expand-macros ] lmap dup car lisp-macro? [ macro-expand expand-macros ] when ] when ;
+
: convert-begin ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
[ '[ { } _ with-datastack drop ] ] map prepend '[ _ [ call ] each ] ;
"set" "lisp" "define-lisp-var" define-primitive
- "(lambda (&rest xs) xs)" lisp-string>factor first "list" lisp-define
- "(defmacro setq (var val) (list (quote set) (list (quote quote) var) val))" lisp-eval
+ "(set 'list (lambda (&rest xs) xs))" lisp-eval
+ "(defmacro setq (var val) (list 'set (list 'quote var) val))" lisp-eval
<" (defmacro defun (name vars &rest body)
- (list (quote setq) name (list (quote lambda) vars body))) "> lisp-eval
+ (list 'setq name (cons 'lambda (cons vars body)))) "> lisp-eval
- "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
+ "(defmacro if (pred tr fl) (list 'cond (list pred tr) (list (quote #t) fl)))" lisp-eval
;
: <LISP
- "LISP>" parse-multiline-string define-lisp-builtins
- lisp-string>factor parsed \ call parsed ; parsing
+ "LISP>" parse-multiline-string "(begin " prepend ")" append define-lisp-builtins
+ lisp-string>factor parsed \ call parsed ; parsing
\ No newline at end of file
}
} [
"(1 (3 4) 2)" lisp-expr
+] unit-test
+
+{ { T{ lisp-symbol { name "quote" } } { 1 2 3 } } } [
+ "'(1 2 3)" lisp-expr cons>seq
+] unit-test
+
+{ { T{ lisp-symbol f "quote" } T{ lisp-symbol f "foo" } } } [
+ "'foo" lisp-expr cons>seq
+] unit-test
+
+{ { 1 2 { T{ lisp-symbol { name "quote" } } { 3 4 } } 5 } } [
+ "(1 2 '(3 4) 5)" lisp-expr cons>seq
] unit-test
\ No newline at end of file
| identifier
| string
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
-list-item = _ ( atom | s-expression ) _ => [[ second ]]
-;EBNF
+list-item = _ ( atom | s-expression | quoted ) _ => [[ second ]]
+quoted = squote list-item => [[ second nil cons "quote" <lisp-symbol> swap cons ]]
+expr = list-item
+;EBNF
\ No newline at end of file
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel system accessors namespaces splitting sequences make
-mason.config ;
+USING: kernel system accessors namespaces splitting sequences
+mason.config bootstrap.image ;
IN: mason.platform
: platform ( -- string )
: gnu-make ( -- string )
target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
+: boot-image-arch ( -- string )
+ target-os get target-cpu get arch ;
+
: boot-image-name ( -- string )
- [
- "boot." %
- target-cpu get "ppc" = [ target-os get % "-" % ] when
- target-cpu get %
- ".image" %
- ] "" make ;
+ "boot." boot-image-arch ".image" 3append ;
] with-scope
] unit-test
-[ { "scp" "boot.x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
+[ { "scp" "boot.unix-x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
[
"joe" image-username set
"blah.com" image-host set
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces continuations debugger sequences fry
-io.files io.launcher mason.common mason.platform
+io.files io.launcher bootstrap.image qualified mason.common
mason.config ;
+FROM: mason.config => target-os ;
IN: mason.release.tidy
: common-files ( -- seq )
+ images [ boot-image-name ] map
{
- "boot.x86.32.image"
- "boot.x86.64.image"
- "boot.macosx-ppc.image"
- "boot.linux-ppc.image"
"vm"
"temp"
"logs"
"unmaintained"
"unfinished"
"build-support"
- } ;
+ }
+ append ;
: remove-common-files ( -- )
common-files [ delete-tree ] each ;
= not ;
: new-image-available? ( -- ? )
- boot-image-name need-new-image? [ download-my-image t ] [ f ] if ;
+ boot-image-name need-new-image?
+ [ boot-image-arch download-image t ] [ f ] if ;
: new-code-available? ( -- ? )
updates-available?
-! Copyright (c) 2007 Samuel Tardieu
+! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions sequences fry ;
IN: math.algebra
: chinese-remainder ( aseq nseq -- x )
- dup product
- [
+ dup product [
'[ _ over / [ swap gcd drop ] keep * * ] 2map sum
] keep rem ; foldable
--- /dev/null
+USING: help.markup help.syntax math ;
+IN: math.analysis
+
+HELP: gamma
+{ $values { "x" number } { "y" number } }
+{ $description "Gamma function; an extension of factorial to real and complex numbers." } ;
+
+HELP: gammaln
+{ $values { "x" number } { "gamma[x]" number } }
+{ $description "An alternative to " { $link gamma } " when gamma(x)'s range varies too widely." } ;
+
+HELP: nth-root
+{ $values { "n" integer } { "x" number } { "y" number } }
+{ $description "Calculates the nth root of a number, such that " { $snippet "y^n=x" } "." } ;
+
+HELP: exp-int
+{ $values { "x" number } { "y" number } }
+{ $description "Exponential integral function." }
+{ $notes "Works only for real values of " { $snippet "x" } " and is accurate to 7 decimal places." } ;
+
+HELP: stirling-fact
+{ $values { "n" integer } { "fact" integer } }
+{ $description "James Stirling's factorial approximation." } ;
+
-! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! Copyright (C) 2008 Doug Coleman, Slava Pestov, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.constants math.functions math.intervals
-math.vectors namespaces sequences combinators.short-circuit ;
+USING: combinators.short-circuit kernel math math.constants math.functions
+ math.vectors sequences ;
IN: math.analysis
<PRIVATE
: gamma-p6
{
2.50662827563479526904 225.525584619175212544 -268.295973841304927459
- 80.9030806934622512966 -5.00757863970517583837 0.0114684895434781459556
+ 80.9030806934622512966 -5.00757863970517583837 0.0114684895434781459556
} ; inline
: gamma-z ( x n -- seq )
: (gamma-lanczos6) ( x -- log[gamma[x+1]] )
#! log(gamma(x+1)
- [ 0.5 + dup gamma-g6 + dup [ log * ] dip - ]
+ [ 0.5 + dup gamma-g6 + [ log * ] keep - ]
[ 6 gamma-z gamma-p6 v. log ] bi + ;
: gamma-lanczos6 ( x -- gamma[x] )
#! gamma(x) = gamma(x+1) / x
- dup (gamma-lanczos6) exp swap / ;
+ [ (gamma-lanczos6) exp ] keep / ;
: gammaln-lanczos6 ( x -- gammaln[x] )
#! log(gamma(x)) = log(gamma(x+1)) - log(x)
- dup (gamma-lanczos6) swap log - ;
+ [ (gamma-lanczos6) ] keep log - ;
: gamma-neg ( gamma[abs[x]] x -- gamma[x] )
dup pi * sin * * pi neg swap / ; inline
#! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
#! gamma(n+1) = n! for n > 0
dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
- drop 1./0.
- ] [
- dup abs gamma-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if
+ drop 1./0.
+ ] [
+ [ abs gamma-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;
: gammaln ( x -- gamma[x] )
#! gammaln(x) is an alternative when gamma(x)'s range
#! varies too widely
dup 0 < [
- drop 1./0.
- ] [
- dup abs gammaln-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if
+ drop 1./0.
+ ] [
+ [ abs gammaln-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;
: nth-root ( n x -- y )
- [ recip ] dip swap ^ ;
+ swap recip ^ ;
! Forth Scientific Library Algorithm #1
!
: stirling-fact ( n -- fact )
[ pi 2 * * sqrt ]
- [ dup e / swap ^ ]
- [ 12 * recip 1 + ]
- tri * * ;
+ [ [ e / ] keep ^ ]
+ [ 12 * recip 1+ ] tri * * ;
+
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq )
- [ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ;
+ [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
: all-permutations ( seq -- seq )
[ length factorial ] keep '[ _ permutation ] map ;
+: each-permutation ( seq quot -- )
+ [ [ length factorial ] keep ] dip
+ '[ _ permutation @ ] each ; inline
+
+: reduce-permutations ( seq initial quot -- result )
+ swapd each-permutation ; inline
+
: inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ;
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: help.markup help.syntax ;
-
+USING: help.markup help.syntax math ;
IN: math.compare
HELP: absmin
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the smaller absolute number with the original sign."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the smaller absolute number with the original sign." } ;
HELP: absmax
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the larger absolute number with the original sign."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the larger absolute number with the original sign." } ;
HELP: posmax
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the most-positive value, or zero if both are negative."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the most-positive value, or zero if both are negative." } ;
HELP: negmin
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the most-negative value, or zero if both are positive."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the most-negative value, or zero if both are positive." } ;
HELP: clamp
-{ $values { "a" "a number" } { "value" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the value when between 'a' and 'b', 'a' if <= 'a', or 'b' if >= 'b'."
-} ;
+{ $values { "a" number } { "value" number } { "b" number } { "x" number } }
+{ $description "Returns the value when between " { $snippet "a" } " and " { $snippet "b" } ", " { $snippet "a" } " if <= " { $snippet "a" } ", or " { $snippet "b" } " if >= " { $snippet "b" } "." } ;
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: kernel math math.functions math.compare tools.test ;
-
+USING: kernel math math.compare math.functions tools.test ;
IN: math.compare.tests
[ -1 ] [ -1 5 absmin ] unit-test
[ 1 ] [ 0 1 2 clamp ] unit-test
[ 2 ] [ 0 3 2 clamp ] unit-test
-
-
-
-! Copyright (C) 2008 John Benediktsson
+! Copyright (C) 2008 John Benediktsson.
! See http://factorcode.org/license.txt for BSD license
-
USING: math math.order kernel ;
+IN: math.compare
-IN: math.compare
-
-: absmin ( a b -- x )
- [ [ abs ] bi@ < ] 2keep ? ;
+: absmin ( a b -- x )
+ [ [ abs ] bi@ < ] 2keep ? ;
-: absmax ( a b -- x )
- [ [ abs ] bi@ > ] 2keep ? ;
+: absmax ( a b -- x )
+ [ [ abs ] bi@ > ] 2keep ? ;
-: posmax ( a b -- x )
- 0 max max ;
+: posmax ( a b -- x )
+ 0 max max ;
-: negmin ( a b -- x )
- 0 min min ;
+: negmin ( a b -- x )
+ 0 min min ;
: clamp ( a value b -- x )
- min max ;
+ min max ;
--- /dev/null
+USING: math math.derivatives tools.test ;
+IN: math.derivatives.test
+
+[ 8 ] [ 4 [ sq ] derivative >integer ] unit-test
+
-USING: kernel continuations combinators sequences math
- math.order math.ranges accessors float-arrays ;
-
+! Copyright (c) 2008 Reginald Keith Ford II, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations combinators sequences math math.order math.ranges
+ accessors float-arrays ;
IN: math.derivatives
TUPLE: state x func h err i j errt fac hh ans a done ;
: a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ;
: check-h ( state -- state )
- dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
+ dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
+
: init-a ( state -- state ) ntab [ ntab <float-array> ] replicate >>a ;
: init-hh ( state -- state ) dup h>> >>hh ;
: init-err ( state -- state ) big >>err ;
! If error is decreased, save the improved answer
: error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ;
+
: save-improved-answer ( state -- state )
- dup err>> >>errt
- dup a[j][i] >>ans ;
+ dup err>> >>errt
+ dup a[j][i] >>ans ;
! If higher order is worse by a significant factor SAFE, then quit early.
: check-safe ( state -- state )
- dup
- [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >=
- [ t >>done ]
- when ;
+ dup [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ]
+ [ err>> safe * ] bi >= [ t >>done ] when ;
+
: x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ;
: x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ;
+
: limit-approx ( state -- val )
- [
- [ [ x+hh ] [ func>> ] bi call ]
- [ [ x-hh ] [ func>> ] bi call ]
- bi -
- ]
- [ hh>> 2.0 * ]
- bi / ;
+ [
+ [ [ x+hh ] [ func>> ] bi call ]
+ [ [ x-hh ] [ func>> ] bi call ] bi -
+ ] [ hh>> 2.0 * ] bi / ;
+
: a[0][0]! ( state -- state )
- { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+ { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+
: a[0][i]! ( state -- state )
- { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+ { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+
: a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ;
+
: new-a[j][i] ( state -- val )
- [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
- [ fac>> 1.0 - ]
- bi / ;
+ [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
+ [ fac>> 1.0 - ] bi / ;
+
: a[j][i]! ( state -- state )
- { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
+ { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
: update-errt ( state -- state )
- dup
- [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
- [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ]
- bi max
- >>errt ;
+ dup [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
+ [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ] bi max >>errt ;
: not-done? ( state -- state ? ) dup done>> not ;
: derive ( state -- state )
- init-a
- check-h
- init-hh
- a[0][0]!
- init-err
- 1 ntab [a,b)
- [
- >>i
- not-done?
- [
- update-hh
- a[0][i]!
- reset-fac
- 1 over i>> [a,b]
- [
- >>j
- a[j][i]!
- update-fac
- update-errt
- error-decreased? [ save-improved-answer ] when
- ]
- each
- check-safe
- ]
- when
- ]
- each ;
+ init-a
+ check-h
+ init-hh
+ a[0][0]!
+ init-err
+ 1 ntab [a,b) [
+ >>i not-done? [
+ update-hh
+ a[0][i]!
+ reset-fac
+ 1 over i>> [a,b] [
+ >>j
+ a[j][i]!
+ update-fac
+ update-errt
+ error-decreased? [ save-improved-answer ] when
+ ] each check-safe
+ ] when
+ ] each ;
: derivative-state ( x func h err -- state )
state new
! h should be small enough to give the correct sgn(f'(x))
! err is the max tolerance of gain in error for a single iteration-
: (derivative) ( x func h err -- ans error )
- derivative-state
- derive
- [ ans>> ]
- [ errt>> ]
- bi ;
+ derivative-state derive [ ans>> ] [ errt>> ] bi ;
-: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
+: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
: derivative-func ( func -- der ) [ derivative ] curry ;
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
- math.ranges sequences accessors ;
+USING: accessors bit-arrays fry kernel lists.lazy math math.functions
+ math.primes.list math.ranges sequences ;
IN: math.erato
<PRIVATE
TUPLE: erato limit bits latest ;
: ind ( n -- i )
- 2/ 1- ; inline
+ 2/ 1- ; inline
: is-prime ( n limit -- bool )
- [ ind ] [ bits>> ] bi* nth ; inline
+ [ ind ] [ bits>> ] bi* nth ; inline
: indices ( n erato -- range )
- limit>> ind over 3 * ind swap rot <range> ;
+ limit>> ind over 3 * ind spin <range> ;
: mark-multiples ( n erato -- )
- over sq over limit>> <=
- [ [ indices ] keep bits>> [ f -rot set-nth ] curry each ] [ 2drop ] if ;
+ 2dup [ sq ] [ limit>> ] bi* <= [
+ [ indices ] keep bits>> '[ _ f -rot set-nth ] each
+ ] [ 2drop ] if ;
: <erato> ( n -- erato )
- dup ind 1+ <bit-array> 1 over set-bits erato boa ;
+ dup ind 1+ <bit-array> dup set-bits 1 erato boa ;
: next-prime ( erato -- prime/f )
- [ 2 + ] change-latest [ latest>> ] keep
- 2dup limit>> <=
- [
- 2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
- ] [
- 2drop f
- ] if ;
+ [ 2 + ] change-latest [ latest>> ] keep
+ 2dup limit>> <= [
+ 2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
+ ] [
+ 2drop f
+ ] if ;
PRIVATE>
: lerato ( n -- lazy-list )
- dup 1000003 < [
- 0 primes-under-million seq>list swap [ <= ] curry lwhile
- ] [
- <erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
- ] if ;
+ dup 1000003 < [
+ 0 primes-under-million seq>list swap '[ _ <= ] lwhile
+ ] [
+ <erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
+ ] if ;
-Sieve of Eratosthene
+Sieve of Eratosthenes
+++ /dev/null
-Hans Schmid
+++ /dev/null
-! Fast Fourier Transform, copyright (C) 2007 Hans Schmid
-! http://dressguardmeister.blogspot.com/2007/01/fft.html
-USING: arrays sequences math math.vectors math.constants
-math.functions kernel splitting grouping columns ;
-IN: math.fft
-
-: n^v ( n v -- w ) [ ^ ] with map ;
-: even ( seq -- seq ) 2 group 0 <column> ;
-: odd ( seq -- seq ) 2 group 1 <column> ;
-DEFER: fft
-: two ( seq -- seq ) fft 2 v/n dup append ;
-: omega ( n -- n' ) recip -2 pi i* * * exp ;
-: twiddle ( seq -- seq ) dup length dup omega swap n^v v* ;
-: (fft) ( seq -- seq ) dup odd two twiddle swap even two v+ ;
-: fft ( seq -- seq ) dup length 1 = [ (fft) ] unless ;
+++ /dev/null
-Fast fourier transform
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
+! Copyright (C) 2008 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel grouping sequences shuffle
math math.functions math.statistics math.vectors ;
-
IN: math.finance
<PRIVATE
-: weighted ( x y a -- z )
- tuck [ * ] [ 1 swap - * ] 2bi* + ;
+: weighted ( x y a -- z )
+ tuck [ * ] [ 1- neg * ] 2bi* + ;
-: a ( n -- a )
- 1 + 2 swap / ;
+: a ( n -- a )
+ 1+ 2 swap / ;
PRIVATE>
: ema ( seq n -- newseq )
- a swap unclip [ [ dup ] 2dip swap rot weighted ] accumulate 2nip ;
+ a swap unclip [ [ dup ] 2dip spin weighted ] accumulate 2nip ;
: sma ( seq n -- newseq )
clump [ mean ] map ;
rot dup ema [ swap ema ] dip v- ;
: momentum ( seq n -- newseq )
- 2dup tail-slice -rot swap [ length ] keep
- [ - neg ] dip swap head-slice v- ;
+ [ tail-slice ] 2keep [ dup length ] dip - head-slice v- ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
+USING: kernel math sequences prettyprint math.parser io
+math.functions ;
IN: math.floating-point
-: float-sign ( float -- ? )
- float>bits -31 shift { 1 -1 } nth ;
+: (double-sign) ( bits -- n ) -63 shift ; inline
+: double-sign ( double -- n ) double>bits (double-sign) ;
-: double-sign ( float -- ? )
- double>bits -63 shift { 1 -1 } nth ;
-
-: float-exponent-bits ( float -- n )
- float>bits -23 shift 8 2^ 1- bitand ;
+: (double-exponent-bits) ( bits -- n )
+ -52 shift 11 2^ 1- bitand ; inline
: double-exponent-bits ( double -- n )
- double>bits -52 shift 11 2^ 1- bitand ;
+ double>bits (double-exponent-bits) ;
-: float-mantissa-bits ( float -- n )
- float>bits 23 2^ 1- bitand ;
+: (double-mantissa-bits) ( double -- n )
+ 52 2^ 1- bitand ;
: double-mantissa-bits ( double -- n )
- double>bits 52 2^ 1- bitand ;
-
-: float-e ( -- float ) 127 ; inline
-: double-e ( -- float ) 1023 ; inline
-
-! : calculate-float ( S M E -- float )
- ! float-e - 2^ * * ; ! bits>float ;
-
-! : calculate-double ( S M E -- frac )
- ! double-e - 2^ swap 52 2^ /f 1+ * * ;
+ double>bits (double-mantissa-bits) ;
+
+: >double ( S E M -- frac )
+ [ 52 shift ] dip
+ [ 63 shift ] 2dip bitor bitor bits>double ;
+
+: >double< ( double -- S E M )
+ double>bits
+ [ (double-sign) ]
+ [ (double-exponent-bits) ]
+ [ (double-mantissa-bits) ] tri ;
+
+: double. ( double -- )
+ double>bits
+ [ (double-sign) .b ]
+ [ (double-exponent-bits) >bin 11 CHAR: 0 pad-left bl print ]
+ [
+ (double-mantissa-bits) >bin 52 CHAR: 0 pad-left
+ 11 [ bl ] times print
+ ] tri ;
-! Copyright © 2008 Reginald Keith Ford II
-! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions
-
+! Copyright (c) 2008 Reginald Keith Ford II.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math arrays sequences sequences.lib ;
-IN: math.function-tools
-: difference-func ( func func -- func ) [ bi - ] 2curry ; inline
-: eval ( x func -- pt ) dupd call 2array ; inline
-: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline
-: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline
+IN: math.function-tools
+
+! Tools for quickly comparing, transforming, and evaluating mathematical functions
+
+: difference-func ( func func -- func )
+ [ bi - ] 2curry ; inline
+
+: eval ( x func -- pt )
+ dupd call 2array ; inline
+
+: eval-inverse ( y func -- pt )
+ dupd call swap 2array ; inline
+
+: eval3d ( x y func -- pt )
+ [ 2dup ] dip call 3array ; inline
+++ /dev/null
-! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/
-USING: sequences math kernel splitting grouping columns ;
-IN: math.haar
-
-: averages ( seq -- seq )
- [ first2 + 2 / ] map ;
-
-: differences ( seq averages -- differences )
- >r 0 <column> r> [ - ] 2map ;
-
-: haar-step ( seq -- differences averages )
- 2 group dup averages [ differences ] keep ;
-
-: haar ( seq -- seq )
- dup length 1 <= [ haar-step haar prepend ] unless ;
+++ /dev/null
-Haar wavelet transform
: cols ( -- n ) 0 nth-row length ;
: skip ( i seq quot -- n )
- over >r find-from drop r> length or ; inline
+ over [ find-from drop ] dip length or ; inline
: first-col ( row# -- n )
#! First non-zero column
0 swap nth-row [ zero? not ] skip ;
: clear-scale ( col# pivot-row i-row -- n )
- >r over r> nth dup zero? [
+ [ over ] dip nth dup zero? [
3drop 0
] [
- >r nth dup zero? r> swap [
+ [ nth dup zero? ] dip swap [
2drop 0
] [
swap / neg
] if ;
: (clear-col) ( col# pivot-row i -- )
- [ [ clear-scale ] 2keep >r n*v r> v+ ] change-row ;
+ [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
: rows-from ( row# -- slice )
rows dup <slice> ;
: clear-col ( col# row# rows -- )
- >r nth-row r> [ >r 2dup r> (clear-col) ] each 2drop ;
+ [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
: do-row ( exchange-with row# -- )
[ exchange-rows ] keep
dup 1+ rows-from clear-col ;
: find-row ( row# quot -- i elt )
- >r rows-from r> find ; inline
+ [ rows-from ] dip find ; inline
: pivot-row ( col# row# -- n )
[ dupd nth-row nth zero? not ] find-row 2nip ;
: (echelon) ( col# row# -- )
over cols < over rows < and [
2dup pivot-row [ over do-row 1+ ] when*
- >r 1+ r> (echelon)
+ [ 1+ ] dip (echelon)
] [
2drop
] if ;
] with-matrix ;
: basis-vector ( row col# -- )
- >r clone r>
+ [ clone ] dip
[ swap nth neg recip ] 2keep
[ 0 spin set-nth ] 2keep
- >r n*v r>
+ [ n*v ] dip
matrix get set-nth ;
: nullspace ( matrix -- seq )
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences math math.functions
-math.vectors math.order ;
+USING: arrays kernel math math.order math.vectors sequences ;
IN: math.matrices
! Matrices
: m.v ( m v -- v ) [ v. ] curry map ;
: m. ( m m -- m ) flip [ swap m.v ] curry map ;
-: mmin ( m -- n ) >r 1/0. r> [ [ min ] each ] each ;
-: mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ;
+: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
+: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ;
<PRIVATE
TUPLE: positive-even-expected n ;
-: (factor-2s) ( r s -- r s )
- dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
-
-: factor-2s ( n -- r s )
- #! factor an integer into s * 2^r
- 0 swap (factor-2s) ;
-
:: (miller-rabin) ( n trials -- ? )
[let | r [ n 1- factor-2s drop ]
s [ n 1- factor-2s nip ]
-! Copyright © 2008 Reginald Keith Ford II
+! Copyright (c) 2008 Reginald Keith Ford II.
! See http://factorcode.org/license.txt for BSD license.
-! Newton's Method of approximating roots
USING: kernel math math.derivatives ;
IN: math.newtons-method
+! Newton's method of approximating roots
+
<PRIVATE
: newton-step ( x function -- x2 )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences vectors math math.vectors
-namespaces make shuffle splitting sequences.lib math.order ;
+USING: arrays kernel make math math.order math.vectors sequences shuffle
+ splitting vectors ;
IN: math.polynomials
! Polynomials are vectors with the highest powers on the right:
<array> 1 [ * ] accumulate nip ;
<PRIVATE
-: 2pad-left ( p p n -- p p ) 0 [ pad-left swap ] 2keep pad-left swap ;
-: 2pad-right ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ;
+
+: 2pad-left ( p p n -- p p ) [ 0 pad-left ] curry bi@ ;
+: 2pad-right ( p p n -- p p ) [ 0 pad-right ] curry bi@ ;
: pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ;
: pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ;
: unempty ( seq -- seq ) [ { 0 } ] when-empty ;
: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
PRIVATE>
+
: p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p )
! convolution
: pextend-conv ( p p -- p p )
- #! extend to: p_m + p_n - 1
+ #! extend to: p_m + p_n - 1
2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
: p* ( p p -- p )
#! Multiply two polynomials.
2unempty pextend-conv <reversed> dup length
[ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
-
+
: p-sq ( p -- p-sq )
dup p* ;
dup V{ 0 } clone p= [
drop nip
] [
- tuck p/mod >r pick p* swap >r swapd p- r> r> (pgcd)
+ tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
] if ;
: pgcd ( p p -- p q )
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lists math math.primes namespaces make
-sequences ;
+USING: arrays kernel lists make math math.primes sequences ;
IN: math.primes.factors
<PRIVATE
: (count) ( n d -- n' )
[ (factor) ] { } make
- [ [ first ] keep length 2array , ] unless-empty ;
+ [ [ first ] [ length ] bi 2array , ] unless-empty ;
: (unique) ( n d -- n' )
[ (factor) ] { } make
[ first , ] unless-empty ;
: (factors) ( quot list n -- )
- dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ;
+ dup 1 > [
+ swap uncons swap [ pick call ] dip swap (factors)
+ ] [ 3drop ] if ;
: (decompose) ( n quot -- seq )
[ lprimes rot (factors) ] { } make ;
dup 2 < [
drop 0
] [
- dup unique-factors dup 1 [ 1- * ] reduce swap product / *
+ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / *
] if ; foldable
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel lists.lazy math math.functions math.miller-rabin
- math.order math.primes.list math.ranges sequences sorting
- binary-search ;
+USING: binary-search combinators kernel lists.lazy math math.functions
+ math.miller-rabin math.primes.list sequences ;
IN: math.primes
<PRIVATE
} cond ; foldable
: primes-between ( low high -- seq )
- primes-upto
- [ 1- next-prime ] dip
- [ natural-search drop ] keep [ length ] keep <slice> ; foldable
+ primes-upto [ 1- next-prime ] dip
+ [ natural-search drop ] [ length ] [ ] tri <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
-: q*a ( u v -- a ) 2q swapd ** >r * r> - ; inline
+: q*a ( u v -- a ) 2q swapd ** [ * ] dip - ; inline
-: q*b ( u v -- b ) 2q >r ** swap r> * + ; inline
+: q*b ( u v -- b ) 2q [ ** swap ] dip * + ; inline
PRIVATE>
: v>q ( v -- q )
#! Turn a 3-vector into a quaternion with real part 0.
- first3 rect> >r 0 swap rect> r> 2array ;
+ first3 rect> [ 0 swap rect> ] dip 2array ;
: q>v ( q -- v )
#! Get the vector part of a quaternion, discarding the real
#! part.
- first2 >r imaginary-part r> >rect 3array ;
+ first2 [ imaginary-part ] dip >rect 3array ;
! Zero
: q0 { 0 0 } ;
! http://www.mathworks.com/access/helpdesk/help/toolbox/aeroblks/euleranglestoquaternions.html
: (euler) ( theta unit -- q )
- >r -0.5 * dup cos c>q swap sin r> n*v v- ;
+ [ -0.5 * dup cos c>q swap sin ] dip n*v v- ;
: euler ( phi theta psi -- q )
[ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ;
-! Copyright © 2008 Reginald Keith Ford II
+! Copyright (c) 2008 Reginald Keith Ford II.
! See http://factorcode.org/license.txt for BSD license.
-! Secant Method of approximating roots
USING: kernel math math.function-tools math.points math.vectors ;
IN: math.secant-method
+! Secant method of approximating roots
+
<PRIVATE
: secant-solution ( x1 x2 function -- solution )
! Copyright (C) 2008 Doug Coleman, Michael Judge.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.analysis math.functions math.vectors sequences
-sequences.lib sorting ;
+USING: arrays kernel math math.analysis math.functions sequences sequences.lib
+ sorting ;
IN: math.statistics
: mean ( seq -- n )
: median ( seq -- n )
#! middle number if odd, avg of two middle numbers if even
- natural-sort dup length dup even? [
- 1- 2 / swap [ nth ] [ [ 1+ ] dip nth ] 2bi + 2 /
+ natural-sort dup length even? [
+ [ midpoint@ dup 1- 2array ] keep nths mean
] [
- 2 / swap nth
+ [ midpoint@ ] keep nth
] if ;
: range ( seq -- n )
: ste ( seq -- x )
#! standard error, standard deviation / sqrt ( length of sequence )
- dup std swap length sqrt / ;
+ [ std ] [ length ] bi sqrt / ;
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y))
- 0 [ [ >r pick r> swap - ] bi@ * + ] 2reduce 2nip ;
+ 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
- * recip >r [ ((r)) ] keep length 1- / r> * ;
+ * recip [ [ ((r)) ] keep length 1- / ] dip * ;
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib kernel math math.functions math.parser namespaces
-sequences splitting grouping combinators.short-circuit ;
+USING: combinators.short-circuit grouping kernel math math.parser namespaces
+ sequences ;
IN: math.text.english
<PRIVATE
SYMBOL: and-needed?
: set-conjunction ( seq -- )
- first { [ dup 100 < ] [ dup 0 > ] } 0&& and-needed? set drop ;
+ first { [ 100 < ] [ 0 > ] } 1&& and-needed? set ;
: negative-text ( n -- str )
0 < "Negative " "" ? ;
] if ;
: 3digits>text ( n -- str )
- dup hundreds-place swap tens-place append ;
+ [ hundreds-place ] [ tens-place ] bi append ;
: text-with-scale ( index seq -- str )
- dupd nth 3digits>text swap
- scale-numbers [
- " " swap 3append
- ] unless-empty ;
+ [ nth 3digits>text ] [ drop scale-numbers ] 2bi
+ [ " " swap 3append ] unless-empty ;
: append-with-conjunction ( str1 str2 -- newstr )
over length zero? [
and-needed? off
] if ;
-: (recombine) ( str index seq -- newstr seq )
+: (recombine) ( str index seq -- newstr )
2dup nth zero? [
- nip
+ 2drop
] [
- [ text-with-scale ] keep
- -rot append-with-conjunction swap
+ text-with-scale append-with-conjunction
] if ;
: recombine ( seq -- str )
dup length 1 = [
first 3digits>text
] [
- dup set-conjunction "" swap
- dup length [ swap (recombine) ] each drop
+ [ set-conjunction "" ] [ length ] [ ] tri
+ [ (recombine) ] curry each
] if ;
: (number>text) ( n -- str )
--- /dev/null
+Hans Schmid
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: math.transforms.fft
+
+HELP: fft
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Fast Fourier transform function." } ;
+
--- /dev/null
+! Copyright (c) 2007 Hans Schmid.
+! See http://factorcode.org/license.txt for BSD license.
+USING: columns grouping kernel math math.constants math.functions math.vectors
+ sequences ;
+IN: math.transforms.fft
+
+! Fast Fourier Transform
+
+<PRIVATE
+
+: n^v ( n v -- w ) [ ^ ] with map ;
+
+: omega ( n -- n' )
+ recip -2 pi i* * * exp ;
+
+: twiddle ( seq -- seq )
+ dup length [ omega ] [ n^v ] bi v* ;
+
+PRIVATE>
+
+DEFER: fft
+
+: two ( seq -- seq )
+ fft 2 v/n dup append ;
+
+<PRIVATE
+
+: even ( seq -- seq ) 2 group 0 <column> ;
+: odd ( seq -- seq ) 2 group 1 <column> ;
+
+: (fft) ( seq -- seq )
+ [ odd two twiddle ] [ even two ] bi v+ ;
+
+PRIVATE>
+
+: fft ( seq -- seq )
+ dup length 1 = [ (fft) ] unless ;
+
--- /dev/null
+Fast fourier transform
--- /dev/null
+Slava Pestov
+Aaron Schaefer
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: math.transforms.haar
+
+HELP: haar
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Haar wavelet transform function." }
+{ $notes "The sequence length should be a power of two." }
+{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 7 1 6 6 3 -5 4 2 } haar ." "{ 3 2 -1 -2 3 0 4 1 }" } } ;
+
+HELP: rev-haar
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Reverse Haar wavelet transform function." }
+{ $notes "The sequence length should be a power of two." }
+{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 3 2 -1 -2 3 0 4 1 } rev-haar ." "{ 7 1 6 6 3 -5 4 2 }" } } ;
+
--- /dev/null
+USING: math.transforms.haar tools.test ;
+IN: math.transforms.haar.tests
+
+[ { 3 2 -1 -2 3 0 4 1 } ] [ { 7 1 6 6 3 -5 4 2 } haar ] unit-test
+[ { 7 1 6 6 3 -5 4 2 } ] [ { 3 2 -1 -2 3 0 4 1 } rev-haar ] unit-test
+
--- /dev/null
+! Copyright (c) 2008 Slava Pestov, Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs columns grouping kernel math math.statistics math.vectors
+ sequences ;
+IN: math.transforms.haar
+
+! Haar Wavelet Transform -- http://dmr.ath.cx/gfx/haar/
+
+<PRIVATE
+
+: averages ( seq -- seq )
+ [ mean ] map ;
+
+: differences ( seq averages -- differences )
+ [ 0 <column> ] dip v- ;
+
+: haar-step ( seq -- differences averages )
+ 2 group dup averages [ differences ] keep ;
+
+: rev-haar-step ( seq -- seq )
+ halves [ v+ ] [ v- ] 2bi zip concat ;
+
+PRIVATE>
+
+: haar ( seq -- seq )
+ dup length 1 <= [ haar-step haar prepend ] unless ;
+
+: rev-haar ( seq -- seq )
+ dup length 2 > [ halves swap rev-haar prepend ] when rev-haar-step ;
+
--- /dev/null
+Haar wavelet transform
--- /dev/null
+Collection of mathematical transforms
USING: tools.deploy.config ;
H{
- { deploy-reflection 1 }
+ { deploy-threads? t }
{ deploy-math? t }
- { deploy-ui? t }
{ deploy-name "Maze" }
- { deploy-compiler? t }
- { deploy-threads? t }
- { deploy-word-defs? f }
{ deploy-c-types? f }
- { deploy-io 1 }
- { "stop-after-last-window?" t }
- { deploy-random? t }
{ deploy-word-props? f }
+ { deploy-io 2 }
+ { deploy-ui? t }
+ { "stop-after-last-window?" t }
+ { deploy-word-defs? f }
+ { deploy-compiler? t }
+ { deploy-reflection 1 }
}
! From http://www.ffconsultancy.com/ocaml/maze/index.html
USING: sequences namespaces math math.vectors opengl opengl.gl
-arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
-math.order math.geometry.rect ;
+opengl.demo-support arrays kernel random ui ui.gadgets
+ui.gadgets.canvas ui.render math.order math.geometry.rect ;
IN: maze
: line-width 8 ;
] if ;
: draw-maze ( n -- )
+ -0.5 0.5 0 glTranslated
line-width 2 - glLineWidth
line-width 2 - glPointSize
1.0 1.0 1.0 1.0 glColor4d
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render ;
IN: nehe.2
TUPLE: nehe2-gadget < gadget ;
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render ;
IN: nehe.3
TUPLE: nehe3-gadget < gadget ;
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render threads accessors ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render threads accessors ;
IN: nehe.4
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
-USING: arrays kernel math opengl opengl.gl opengl.glu ui\r
-ui.gadgets ui.render threads accessors ;\r
+USING: arrays kernel math opengl opengl.gl opengl.glu\r
+opengl.demo-support ui ui.gadgets ui.render threads accessors ;\r
IN: nehe.5\r
\r
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;\r
-USING: arrays kernel math math.functions
-math.order math.vectors namespaces opengl opengl.gl sequences ui
-ui.gadgets ui.gestures ui.render accessors ;
+USING: arrays kernel math math.functions math.order math.vectors
+namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
+ui.render accessors combinators ;
IN: opengl.demo-support
: FOV 2.0 sqrt 1+ ; inline
: drag-yaw-pitch ( -- yaw pitch )
last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
+: gl-vertex ( point -- )
+ dup length {
+ { 2 [ first2 glVertex2d ] }
+ { 3 [ first3 glVertex3d ] }
+ { 4 [ first4 glVertex4d ] }
+ } case ;
+
+: gl-normal ( normal -- ) first3 glNormal3d ;
+
+: do-state ( mode quot -- )
+ swap glBegin call glEnd ; inline
+
+: rect-vertices ( lower-left upper-right -- )
+ GL_QUADS [
+ over first2 glVertex2d
+ dup first pick second glVertex2d
+ dup first2 glVertex2d
+ swap first swap second glVertex2d
+ ] do-state ;
+
demo-gadget H{
{ T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] }
{ T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] }
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
USING: locals math.functions math namespaces
-opengl.gl accessors kernel opengl ui.gadgets
+opengl.gl opengl.demo-support accessors kernel opengl ui.gadgets
fry assocs
destructors sequences ui.render colors ;
IN: opengl.gadgets
-TUPLE: texture-gadget ;
+TUPLE: texture-gadget < gadget ;
GENERIC: render* ( gadget -- texture dims )
GENERIC: cache-key* ( gadget -- key )
: (read-128-ber) ( n -- n )
read1
- [ >r 7 shift r> 7 clear-bit bitor ] keep
+ [ [ 7 shift ] [ 7 clear-bit ] bi* bitor ] keep
7 bit? [ (read-128-ber) ] when ;
: read-128-ber ( -- n )
USING: kernel namespaces arrays sequences grouping
alien.c-types
math math.vectors math.geometry.rect
- opengl.gl opengl.glu opengl generalizations vars
+ opengl.gl opengl.glu opengl.demo-support opengl generalizations vars
combinators.cleave colors ;
IN: processing.shapes
: fill-mode ( -- )
GL_FRONT_AND_BACK GL_FILL glPolygonMode
- fill-color> set-color ;
+ fill-color> gl-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: stroke-mode ( -- )
GL_FRONT_AND_BACK GL_LINE glPolygonMode
- stroke-color> set-color ;
+ stroke-color> gl-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ellipse ( center dim -- )
GL_FRONT_AND_BACK GL_FILL glPolygonMode
- [ stroke-color> set-color gl-ellipse ]
- [ fill-color> set-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
+ [ stroke-color> gl-color gl-ellipse ]
+ [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+USING: project-euler.001 tools.test ;
+IN: project-euler.001.tests
+
+[ 233168 ] [ euler001 ] unit-test
+[ 233168 ] [ euler001a ] unit-test
+[ 233168 ] [ euler001b ] unit-test
: euler001b ( -- answer )
- 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] filter sum ;
+ 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
! [ euler001b ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
--- /dev/null
+USING: project-euler.002 tools.test ;
+IN: project-euler.002.tests
+
+[ 4613732 ] [ euler002 ] unit-test
+[ 4613732 ] [ euler002a ] unit-test
! 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...
-! Find the sum of all the even-valued terms in the sequence which do not exceed one million.
+! Find the sum of all the even-valued terms in the sequence which do not exceed
+! four million.
! SOLUTION
V{ 0 } clone 1 rot (fib-upto) ;
: euler002 ( -- answer )
- 1000000 fib-upto [ even? ] filter sum ;
+ 4000000 fib-upto [ even? ] filter sum ;
! [ euler002 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.22 SD (100 trials)
! ALTERNATE SOLUTIONS
but-last-slice { 0 1 } prepend ;
: euler002a ( -- answer )
- 1000000 fib-upto* [ even? ] filter sum ;
+ 4000000 fib-upto* [ even? ] filter sum ;
! [ euler002a ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.2 SD (100 trials)
MAIN: euler002a
--- /dev/null
+USING: project-euler.003 tools.test ;
+IN: project-euler.003.tests
+
+[ 6857 ] [ euler003 ] unit-test
! The prime factors of 13195 are 5, 7, 13 and 29.
-! What is the largest prime factor of the number 317584931803?
+! What is the largest prime factor of the number 600851475143 ?
! SOLUTION
! --------
: euler003 ( -- answer )
- 317584931803 factors supremum ;
+ 600851475143 factors supremum ;
! [ euler003 ] 100 ave-time
-! 1 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.49 SD (100 trials)
MAIN: euler003
--- /dev/null
+USING: project-euler.004 tools.test ;
+IN: project-euler.004.tests
+
+[ 906609 ] [ euler004 ] unit-test
<PRIVATE
: source-004 ( -- seq )
- 100 999 [a,b] [ 10 mod zero? not ] filter ;
+ 100 999 [a,b] [ 10 mod 0 = not ] filter ;
: max-palindrome ( seq -- palindrome )
natural-sort [ palindrome? ] find-last nip ;
source-004 dup cartesian-product [ product ] map prune max-palindrome ;
! [ euler004 ] 100 ave-time
-! 1608 ms run / 102 ms GC ave time - 100 trials
+! 1164 ms ave run time - 39.35 SD (100 trials)
MAIN: euler004
--- /dev/null
+USING: project-euler.005 tools.test ;
+IN: project-euler.005.tests
+
+[ 232792560 ] [ euler005 ] unit-test
20 1 [ 1+ lcm ] reduce ;
! [ euler005 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.14 SD (100 trials)
MAIN: euler005
--- /dev/null
+USING: project-euler.006 tools.test ;
+IN: project-euler.006.tests
+
+[ 25164150 ] [ euler006 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.ranges sequences ;
+USING: kernel math math.ranges sequences ;
IN: project-euler.006
! http://projecteuler.net/index.php?section=problems&id=6
PRIVATE>
: euler006 ( -- answer )
- 1 100 [a,b] dup sum-of-squares swap square-of-sum - abs ;
+ 100 [1,b] [ sum-of-squares ] [ square-of-sum ] bi - abs ;
! [ euler006 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.24 SD (100 trials)
MAIN: euler006
--- /dev/null
+USING: project-euler.007 tools.test ;
+IN: project-euler.007.tests
+
+[ 104743 ] [ euler007 ] unit-test
10001 nth-prime ;
! [ euler007 ] 100 ave-time
-! 10 ms run / 0 ms GC ave time - 100 trials
+! 5 ms ave run time - 1.13 SD (100 trials)
MAIN: euler007
--- /dev/null
+USING: project-euler.008 tools.test ;
+IN: project-euler.008.tests
+
+[ 40824 ] [ euler008 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.parser project-euler.common sequences ;
+USING: grouping math.parser sequences ;
IN: project-euler.008
! http://projecteuler.net/index.php?section=problems&id=8
PRIVATE>
: euler008 ( -- answer )
- source-008 5 collect-consecutive [ string>digits product ] map supremum ;
+ source-008 5 clump [ string>digits product ] map supremum ;
! [ euler008 ] 100 ave-time
-! 11 ms run / 0 ms GC ave time - 100 trials
+! 2 ms ave run time - 0.79 SD (100 trials)
MAIN: euler008
--- /dev/null
+USING: project-euler.009 tools.test ;
+IN: project-euler.009.tests
+
+[ 31875000 ] [ euler009 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions namespaces make sequences sorting ;
+USING: kernel make math sequences sorting ;
IN: project-euler.009
! http://projecteuler.net/index.php?section=problems&id=9
: abc ( p q -- triplet )
[
- 2dup * , ! a = p * q
- [ sq ] bi@ 2dup - 2 / , ! b = (p² - q²) / 2
- + 2 / , ! c = (p² + q²) / 2
+ 2dup * , ! a = p * q
+ [ sq ] bi@
+ [ - 2 / , ] ! b = (p² - q²) / 2
+ [ + 2 / , ] 2bi ! c = (p² + q²) / 2
] { } make natural-sort ;
: (ptriplet) ( target p q triplet -- target p q )
- roll [ swap sum = ] keep -roll
- [ next-pq 2dup abc (ptriplet) ] unless ;
+ sum [ pick ] dip = [ next-pq 2dup abc (ptriplet) ] unless ;
: ptriplet ( target -- triplet )
3 1 { 3 4 5 } (ptriplet) abc nip ;
1000 ptriplet product ;
! [ euler009 ] 100 ave-time
-! 1 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.73 SD (100 trials)
MAIN: euler009
--- /dev/null
+USING: project-euler.010 tools.test ;
+IN: project-euler.010.tests
+
+[ 142913828922 ] [ euler010 ] unit-test
! The sum of the primes below 10 is 2 + 3 + 5 + 7 = 17.
-! Find the sum of all the primes below one million.
+! Find the sum of all the primes below two million.
! SOLUTION
! --------
: euler010 ( -- answer )
- 1000000 primes-upto sum ;
+ 2000000 primes-upto sum ;
-! [ euler010 ] 100 ave-time
-! 14 ms run / 0 ms GC ave time - 100 trials
+! [ euler010 ] time
+! 266425 ms run / 10001 ms GC time
+
+! TODO: this takes well over one minute now that they changed the problem to
+! two million instead of one. the primes vocab could use some improvements
MAIN: euler010
--- /dev/null
+USING: project-euler.011 tools.test ;
+IN: project-euler.011.tests
+
+[ 70600674 ] [ euler011 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make project-euler.common sequences
-splitting grouping ;
+USING: grouping kernel make sequences ;
IN: project-euler.011
! http://projecteuler.net/index.php?section=problems&id=11
horizontal pad-front pad-back flip ;
: max-product ( matrix width -- n )
- [ collect-consecutive ] curry map concat
+ [ clump ] curry map concat
[ product ] map supremum ; inline
PRIVATE>
] { } make supremum ;
! [ euler011 ] 100 ave-time
-! 4 ms run / 0 ms GC ave time - 100 trials
+! 3 ms ave run time - 0.77 SD (100 trials)
MAIN: euler011
--- /dev/null
+USING: project-euler.012 tools.test ;
+IN: project-euler.012.tests
+
+[ 76576500 ] [ euler012 ] unit-test
8 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ;
! [ euler012 ] 10 ave-time
-! 5413 ms run / 1 ms GC ave time - 10 trials
+! 6573 ms ave run time - 346.27 SD (10 trials)
MAIN: euler012
--- /dev/null
+USING: project-euler.013 tools.test ;
+IN: project-euler.013.tests
+
+[ 5537376230 ] [ euler013 ] unit-test
source-013 sum number>string 10 head string>number ;
! [ euler013 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.31 SD (100 trials)
MAIN: euler013
--- /dev/null
+USING: project-euler.014 tools.test ;
+IN: project-euler.014.tests
+
+[ 837799 ] [ euler014 ] unit-test
+[ 837799 ] [ euler014a ] unit-test
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.short-circuit kernel
-math math.ranges namespaces make sequences sorting ;
+USING: combinators.short-circuit kernel make math math.ranges sequences ;
IN: project-euler.014
! http://projecteuler.net/index.php?section=problems&id=14
<PRIVATE
: worth-calculating? ( n -- ? )
- { [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } 0&& nip ;
+ 1- 3 { [ mod 0 = ] [ / even? ] } 2&& ;
PRIVATE>
--- /dev/null
+USING: project-euler.015 tools.test ;
+IN: project-euler.015.tests
+
+[ 137846528820 ] [ euler015 ] unit-test
20 grid-paths ;
! [ euler015 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.2 SD (100 trials)
MAIN: euler015
--- /dev/null
+USING: project-euler.016 tools.test ;
+IN: project-euler.016.tests
+
+[ 1366 ] [ euler016 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.functions math.parser project-euler.common sequences ;
+USING: math.functions project-euler.common sequences ;
IN: project-euler.016
! http://projecteuler.net/index.php?section=problems&id=16
2 1000 ^ number>digits sum ;
! [ euler016 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.67 SD (100 trials)
MAIN: euler016
--- /dev/null
+USING: project-euler.017 tools.test ;
+IN: project-euler.017.tests
+
+[ 21124 ] [ euler017 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.ranges math.text.english sequences strings
- ascii combinators.short-circuit ;
+USING: ascii kernel math.ranges math.text.english sequences ;
IN: project-euler.017
! http://projecteuler.net/index.php?section=problems&id=17
: euler017 ( -- answer )
1000 [1,b] SBUF" " clone [ number>text over push-all ] reduce [ Letter? ] count ;
-! [ euler017a ] 100 ave-time
-! 14 ms run / 0 ms GC ave time - 100 trials
+! [ euler017 ] 100 ave-time
+! 15 ms ave run time - 1.71 SD (100 trials)
MAIN: euler017
--- /dev/null
+USING: project-euler.018 tools.test ;
+IN: project-euler.018.tests
+
+[ 1074 ] [ euler018 ] unit-test
+[ 1074 ] [ euler018a ] unit-test
source-018 propagate-all first first ;
! [ euler018 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.29 SD (100 trials)
! ALTERNATE SOLUTIONS
source-018 max-path ;
! [ euler018a ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.39 SD (100 trials)
MAIN: euler018a
--- /dev/null
+USING: project-euler.019 tools.test ;
+IN: project-euler.019.tests
+
+[ 171 ] [ euler019 ] unit-test
+[ 171 ] [ euler019a ] unit-test
: euler019 ( -- answer )
1901 2000 [a,b] [
12 [1,b] [ 1 zeller-congruence ] with map
- ] map concat [ zero? ] count ;
+ ] map concat [ 0 = ] count ;
! [ euler019 ] 100 ave-time
-! 1 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.51 SD (100 trials)
! ALTERNATE SOLUTIONS
PRIVATE>
: euler019a ( -- answer )
- end-date start-date first-days [ zero? ] count ;
+ end-date start-date first-days [ 0 = ] count ;
! [ euler019a ] 100 ave-time
-! 131 ms run / 3 ms GC ave time - 100 trials
+! 17 ms ave run time - 2.13 SD (100 trials)
MAIN: euler019
--- /dev/null
+USING: project-euler.020 tools.test ;
+IN: project-euler.020.tests
+
+[ 648 ] [ euler020 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.combinatorics math.parser project-euler.common sequences ;
+USING: math.combinatorics project-euler.common sequences ;
IN: project-euler.020
! http://projecteuler.net/index.php?section=problems&id=20
100 factorial number>digits sum ;
! [ euler020 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.55 (100 trials)
MAIN: euler020
--- /dev/null
+USING: project-euler.021 tools.test ;
+IN: project-euler.021.tests
+
+[ 31626 ] [ euler021 ] unit-test
: amicable? ( n -- ? )
dup sum-proper-divisors
- { [ 2dup = not ] [ 2dup sum-proper-divisors = ] } 0&& 2nip ;
+ { [ = not ] [ sum-proper-divisors = ] } 2&& ;
: euler021 ( -- answer )
10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ;
! [ euler021 ] 100 ave-time
-! 328 ms run / 10 ms GC ave time - 100 trials
+! 335 ms ave run time - 18.63 SD (100 trials)
MAIN: euler021
--- /dev/null
+USING: project-euler.022 tools.test ;
+IN: project-euler.022.tests
+
+[ 871198282 ] [ euler022 ] unit-test
source-022 natural-sort name-scores sum ;
! [ euler022 ] 100 ave-time
-! 123 ms run / 4 ms GC ave time - 100 trials
+! 74 ms ave run time - 5.13 SD (100 trials)
MAIN: euler022
--- /dev/null
+USING: project-euler.023 tools.test ;
+IN: project-euler.023.tests
+
+[ 4179871 ] [ euler023 ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables kernel math math.ranges project-euler.common sequences
- sorting sets ;
+USING: kernel math math.ranges project-euler.common sequences sets sorting ;
IN: project-euler.023
! http://projecteuler.net/index.php?section=problems&id=23
--- /dev/null
+USING: project-euler.024 tools.test ;
+IN: project-euler.024.tests
+
+[ 2783915460 ] [ euler024 ] unit-test
999999 10 permutation 10 digits>integer ;
! [ euler024 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.27 SD (100 trials)
MAIN: euler024
--- /dev/null
+USING: project-euler.025 tools.test ;
+IN: project-euler.025.tests
+
+[ 4782 ] [ euler025 ] unit-test
+[ 4782 ] [ euler025a ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math math.constants math.functions math.parser
- math.ranges memoize project-euler.common sequences ;
+USING: kernel math math.constants math.functions math.parser memoize
+ project-euler.common sequences ;
IN: project-euler.025
! http://projecteuler.net/index.php?section=problems&id=25
1000 digit-fib ;
! [ euler025 ] 10 ave-time
-! 5237 ms run / 72 ms GC ave time - 10 trials
+! 5345 ms ave run time - 105.91 SD (10 trials)
! ALTERNATE SOLUTIONS
1000 digit-fib* ;
! [ euler025a ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.17 SD (100 trials)
MAIN: euler025a
--- /dev/null
+USING: project-euler.026 tools.test ;
+IN: project-euler.026.tests
+
+[ 983 ] [ euler026 ] unit-test
source-026 max-period drop denominator ;
! [ euler026 ] 100 ave-time
-! 724 ms run / 7 ms GC ave time - 100 trials
+! 290 ms ave run time - 19.2 SD (100 trials)
MAIN: euler026
--- /dev/null
+USING: project-euler.027 tools.test ;
+IN: project-euler.027.tests
+
+[ -59231 ] [ euler027 ] unit-test
source-027 max-consecutive drop product ;
! [ euler027 ] 100 ave-time
-! 687 ms run / 23 ms GC ave time - 100 trials
+! 111 ms ave run time - 6.07 SD (100 trials)
! TODO: generalize max-consecutive/max-product (from #26) into a new word
--- /dev/null
+USING: project-euler.028 tools.test ;
+IN: project-euler.028.tests
+
+[ 669171001 ] [ euler028 ] unit-test
<PRIVATE
: sum-corners ( n -- sum )
- dup 1 = [ [ sq 4 * ] keep 6 * - 6 + ] unless ;
+ dup 1 = [ [ sq 4 * ] [ 6 * ] bi - 6 + ] unless ;
: sum-diags ( n -- sum )
1 swap 2 <range> [ sum-corners ] sigma ;
1001 sum-diags ;
! [ euler028 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.39 SD (100 trials)
MAIN: euler028
--- /dev/null
+USING: project-euler.029 tools.test ;
+IN: project-euler.029.tests
+
+[ 9183 ] [ euler029 ] unit-test
2 100 [a,b] dup cartesian-product [ first2 ^ ] map prune length ;
! [ euler029 ] 100 ave-time
-! 951 ms run / 12 ms GC ave time - 100 trials
+! 704 ms ave run time - 28.07 SD (100 trials)
MAIN: euler029
--- /dev/null
+USING: project-euler.030 tools.test ;
+IN: project-euler.030.tests
+
+[ 443839 ] [ euler030 ] unit-test
325537 [ dup sum-fifth-powers = ] filter sum 1- ;
! [ euler030 ] 100 ave-time
-! 2537 ms run / 125 ms GC ave time - 100 trials
+! 1700 ms ave run time - 64.84 SD (100 trials)
MAIN: euler030
--- /dev/null
+USING: project-euler.031 tools.test ;
+IN: project-euler.031.tests
+
+[ 73682 ] [ euler031 ] unit-test
drop 1 ;
: 2p ( m -- n )
- dup 0 >= [ [ 2 - 2p ] keep 1p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 2 - 2p ] [ 1p ] bi + ] [ drop 0 ] if ;
: 5p ( m -- n )
- dup 0 >= [ [ 5 - 5p ] keep 2p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 5 - 5p ] [ 2p ] bi + ] [ drop 0 ] if ;
: 10p ( m -- n )
- dup 0 >= [ [ 10 - 10p ] keep 5p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 10 - 10p ] [ 5p ] bi + ] [ drop 0 ] if ;
: 20p ( m -- n )
- dup 0 >= [ [ 20 - 20p ] keep 10p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 20 - 20p ] [ 10p ] bi + ] [ drop 0 ] if ;
: 50p ( m -- n )
- dup 0 >= [ [ 50 - 50p ] keep 20p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 50 - 50p ] [ 20p ] bi + ] [ drop 0 ] if ;
: 100p ( m -- n )
- dup 0 >= [ [ 100 - 100p ] keep 50p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 100 - 100p ] [ 50p ] bi + ] [ drop 0 ] if ;
: 200p ( m -- n )
- dup 0 >= [ [ 200 - 200p ] keep 100p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 200 - 200p ] [ 100p ] bi + ] [ drop 0 ] if ;
PRIVATE>
200 200p ;
! [ euler031 ] 100 ave-time
-! 4 ms run / 0 ms GC ave time - 100 trials
+! 3 ms ave run time - 0.91 SD (100 trials)
! TODO: generalize to eliminate duplication; use a sequence to specify denominations?
--- /dev/null
+USING: project-euler.032 tools.test ;
+IN: project-euler.032.tests
+
+[ 45228 ] [ euler032 ] unit-test
+[ 45228 ] [ euler032a ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables kernel math math.combinatorics math.functions
- math.parser math.ranges project-euler.common sequences sets ;
+USING: kernel math math.combinatorics math.functions math.parser math.ranges
+ project-euler.common sequences sets ;
IN: project-euler.032
! http://projecteuler.net/index.php?section=problems&id=32
[ string>number ] tri@ [ * ] dip = ;
: valid? ( n -- ? )
- dup 1and4 swap 2and3 or ;
+ [ 1and4 ] [ 2and3 ] bi or ;
: products ( seq -- m )
[ 10 4 ^ mod ] map ;
source-032 [ valid? ] filter products prune sum ;
! [ euler032 ] 10 ave-time
-! 23922 ms run / 1505 ms GC ave time - 10 trials
+! 16361 ms ave run time - 417.8 SD (10 trials)
! ALTERNATE SOLUTIONS
: euler032a ( -- answer )
source-032a [ mmp ] map [ pandigital? ] filter products prune sum ;
-! [ euler032a ] 100 ave-time
-! 5978 ms run / 327 ms GC ave time - 100 trials
+! [ euler032a ] 10 ave-time
+! 2624 ms ave run time - 131.91 SD (10 trials)
MAIN: euler032a
--- /dev/null
+USING: project-euler.033 tools.test ;
+IN: project-euler.033.tests
+
+[ 100 ] [ euler033 ] unit-test
source-033 curious-fractions product denominator ;
! [ euler033 ] 100 ave-time
-! 5 ms run / 0 ms GC ave time - 100 trials
+! 7 ms ave run time - 1.31 SD (100 trials)
MAIN: euler033
--- /dev/null
+USING: project-euler.034 tools.test ;
+IN: project-euler.034.tests
+
+[ 40730 ] [ euler034 ] unit-test
3 2000000 [a,b] [ factorion? ] filter sum ;
! [ euler034 ] 10 ave-time
-! 15089 ms run / 725 ms GC ave time - 10 trials
+! 5506 ms ave run time - 144.0 SD (10 trials)
MAIN: euler034
--- /dev/null
+USING: project-euler.035 tools.test ;
+IN: project-euler.035.tests
+
+[ 55 ] [ euler035 ] unit-test
source-035 [ possible? ] filter [ circular? ] count ;
! [ euler035 ] 100 ave-time
-! 904 ms run / 86 ms GC ave time - 100 trials
+! 538 ms ave run time - 17.16 SD (100 trials)
! TODO: try using bit arrays or other methods outlined here:
! http://home.comcast.net/~babdulbaki/Circular_Primes.html
--- /dev/null
+USING: project-euler.036 tools.test ;
+IN: project-euler.036.tests
+
+[ 872187 ] [ euler036 ] unit-test
<PRIVATE
: both-bases? ( n -- ? )
- { [ dup palindrome? ]
- [ dup >bin dup reverse = ] } 0&& nip ;
+ { [ palindrome? ] [ >bin dup reverse = ] } 1&& ;
PRIVATE>
1 1000000 2 <range> [ both-bases? ] filter sum ;
! [ euler036 ] 100 ave-time
-! 3891 ms run / 173 ms GC ave time - 100 trials
+! 1703 ms ave run time - 96.6 SD (100 trials)
MAIN: euler036
--- /dev/null
+USING: project-euler.037 tools.test ;
+IN: project-euler.037.tests
+
+[ 748317 ] [ euler037 ] unit-test
23 1000000 primes-between [ r-trunc? ] filter [ l-trunc? ] filter sum ;
! [ euler037 ] 100 ave-time
-! 768 ms run / 9 ms GC ave time - 100 trials
+! 130 ms ave run time - 6.27 SD (100 trials)
MAIN: euler037
--- /dev/null
+USING: project-euler.038 tools.test ;
+IN: project-euler.038.tests
+
+[ 932718654 ] [ euler038 ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser math.ranges project-euler.common sequences ;
+USING: kernel math math.parser math.ranges project-euler.common sequences
+ strings ;
IN: project-euler.038
! http://projecteuler.net/index.php?section=problems&id=38
9123 9876 [a,b] [ concat-product ] map [ pandigital? ] filter supremum ;
! [ euler038 ] 100 ave-time
-! 37 ms run / 1 ms GC ave time - 100 trials
+! 11 ms ave run time - 1.5 SD (100 trials)
MAIN: euler038
--- /dev/null
+USING: project-euler.039 tools.test ;
+IN: project-euler.039.tests
+
+[ 840 ] [ euler039 ] unit-test
] with-scope ;
! [ euler039 ] 100 ave-time
-! 2 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.37 SD (100 trials)
MAIN: euler039
--- /dev/null
+USING: project-euler.040 tools.test ;
+IN: project-euler.040.tests
+
+[ 210 ] [ euler040 ] unit-test
[ swap nth-integer ] with map product ;
! [ euler040 ] 100 ave-time
-! 1002 ms run / 43 ms GC ave time - 100 trials
+! 444 ms ave run time - 23.64 SD (100 trials)
MAIN: euler040
--- /dev/null
+USING: project-euler.041 tools.test ;
+IN: project-euler.041.tests
+
+[ 7652413 ] [ euler041 ] unit-test
[ 10 digits>integer ] map [ prime? ] find nip ;
! [ euler041 ] 100 ave-time
-! 107 ms run / 7 ms GC ave time - 100 trials
+! 64 ms ave run time - 4.22 SD (100 trials)
MAIN: euler041
--- /dev/null
+USING: project-euler.042 tools.test ;
+IN: project-euler.042.tests
+
+[ 162 ] [ euler042 ] unit-test
+[ 162 ] [ euler042a ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: ascii io.files kernel math math.functions namespaces make
- project-euler.common sequences splitting io.encodings.ascii ;
+USING: ascii io.encodings.ascii io.files kernel make math math.functions
+ namespaces project-euler.common sequences splitting ;
IN: project-euler.042
! http://projecteuler.net/index.php?section=problems&id=42
triangle-upto [ member? ] curry count ;
! [ euler042 ] 100 ave-time
-! 27 ms run / 1 ms GC ave time - 100 trials
+! 19 ms ave run time - 1.97 SD (100 trials)
! ALTERNATE SOLUTIONS
source-042 [ alpha-value ] map [ triangle? ] count ;
! [ euler042a ] 100 ave-time
-! 25 ms run / 1 ms GC ave time - 100 trials
+! 21 ms ave run time - 2.2 SD (100 trials)
MAIN: euler042a
--- /dev/null
+USING: project-euler.043 tools.test ;
+IN: project-euler.043.tests
+
+[ 16695334890 ] [ euler043 ] unit-test
+[ 16695334890 ] [ euler043a ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit hashtables kernel math
- math.combinatorics math.parser math.ranges project-euler.common sequences
- sorting sets ;
+USING: combinators.short-circuit kernel math math.combinatorics math.parser
+ math.ranges project-euler.common sequences sets sorting ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43
: interesting? ( seq -- ? )
{
- [ 17 8 pick subseq-divisible? ]
- [ 13 7 pick subseq-divisible? ]
- [ 11 6 pick subseq-divisible? ]
- [ 7 5 pick subseq-divisible? ]
- [ 5 4 pick subseq-divisible? ]
- [ 3 3 pick subseq-divisible? ]
- [ 2 2 pick subseq-divisible? ]
- } 0&& nip ;
+ [ 17 8 rot subseq-divisible? ]
+ [ 13 7 rot subseq-divisible? ]
+ [ 11 6 rot subseq-divisible? ]
+ [ 7 5 rot subseq-divisible? ]
+ [ 5 4 rot subseq-divisible? ]
+ [ 3 3 rot subseq-divisible? ]
+ [ 2 2 rot subseq-divisible? ]
+ } 1&& ;
PRIVATE>
: euler043 ( -- answer )
- 1234567890 number>digits all-permutations
- [ interesting? ] filter [ 10 digits>integer ] map sum ;
+ 1234567890 number>digits 0 [
+ dup interesting? [
+ 10 digits>integer +
+ ] [ drop ] if
+ ] reduce-permutations ;
! [ euler043 ] time
-! 125196 ms run / 19548 ms GC time
+! 60280 ms run / 59 ms GC time
! ALTERNATE SOLUTIONS
1000 over <range> [ number>digits 3 0 pad-left ] map [ all-unique? ] filter ;
: overlap? ( seq -- ? )
- dup first 2 tail* swap second 2 head = ;
+ [ first 2 tail* ] [ second 2 head ] bi = ;
: clean ( seq -- seq )
[ unclip 1 head prefix concat ] map [ all-unique? ] filter ;
: add-missing-digit ( seq -- seq )
- dup natural-sort 10 swap diff first prefix ;
+ dup natural-sort 10 swap diff prepend ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
interesting-pandigitals [ 10 digits>integer ] sigma ;
! [ euler043a ] 100 ave-time
-! 19 ms run / 1 ms GC ave time - 100 trials
+! 10 ms ave run time - 1.37 SD (100 trials)
MAIN: euler043a
--- /dev/null
+USING: project-euler.044 tools.test ;
+IN: project-euler.044.tests
+
+[ 5482660 ] [ euler044 ] unit-test
dup 3 * 1- * 2 / ;
: sum-and-diff? ( m n -- ? )
- 2dup + -rot - [ pentagonal? ] bi@ and ;
+ [ + ] [ - ] 2bi [ pentagonal? ] bi@ and ;
PRIVATE>
[ first2 sum-and-diff? ] filter [ first2 - abs ] map infimum ;
! [ euler044 ] 10 ave-time
-! 8924 ms run / 2872 ms GC ave time - 10 trials
+! 4996 ms ave run time - 87.46 SD (10 trials)
! TODO: this solution is ugly and not very efficient...find a better algorithm
--- /dev/null
+USING: project-euler.045 tools.test ;
+IN: project-euler.045.tests
+
+[ 1533776805 ] [ euler045 ] unit-test
143 next-solution ;
! [ euler045 ] 100 ave-time
-! 18 ms run / 1 ms GC ave time - 100 trials
+! 12 ms ave run time - 1.71 SD (100 trials)
MAIN: euler045
--- /dev/null
+USING: project-euler.046 tools.test ;
+IN: project-euler.046.tests
+
+[ 5777 ] [ euler046 ] unit-test
9 disprove-conjecture ;
! [ euler046 ] 100 ave-time
-! 150 ms run / 2 ms GC ave time - 100 trials
+! 37 ms ave run time - 3.39 SD (100 trials)
MAIN: euler046
--- /dev/null
+USING: project-euler.047 tools.test ;
+IN: project-euler.047.tests
+
+[ 134043 ] [ euler047 ] unit-test
+[ 134043 ] [ euler047a ] unit-test
4 646 consecutive ;
! [ euler047 ] time
-! 542708 ms run / 60548 ms GC time
+! 344688 ms run / 20727 ms GC time
! ALTERNATE SOLUTIONS
0 <repetition> >array sieve set ;
: is-prime? ( index -- ? )
- sieve get nth zero? ;
+ sieve get nth 0 = ;
: multiples ( n -- seq )
sieve get length 1- over <range> ;
4 200000 consecutive-under ;
! [ euler047a ] 100 ave-time
-! 503 ms run / 5 ms GC ave time - 100 trials
+! 331 ms ave run time - 19.14 SD (100 trials)
! TODO: I don't like that you have to specify the upper bound, maybe try making
! this lazy so it could also short-circuit when it finds the answer?
--- /dev/null
+USING: project-euler.048 tools.test ;
+IN: project-euler.048.tests
+
+[ 9110846700 ] [ euler048 ] unit-test
--- /dev/null
+USING: project-euler.052 tools.test ;
+IN: project-euler.052.tests
+
+[ 142857 ] [ euler052 ] unit-test
[ number>digits natural-sort ] map all-equal? ;
: candidate? ( n -- ? )
- { [ dup odd? ] [ dup 3 mod zero? ] } 0&& nip ;
+ { [ odd? ] [ 3 mod 0 = ] } 1&& ;
: next-all-same ( x n -- n )
dup candidate? [
6 123456 next-all-same ;
! [ euler052 ] 100 ave-time
-! 403 ms run / 7 ms GC ave time - 100 trials
+! 92 ms ave run time - 6.29 SD (100 trials)
MAIN: euler052
--- /dev/null
+USING: project-euler.053 tools.test ;
+IN: project-euler.053.tests
+
+[ 4075 ] [ euler053 ] unit-test
23 100 [a,b] [ dup [ nCk 1000000 > ] with count ] sigma ;
! [ euler053 ] 100 ave-time
-! 64 ms run / 2 ms GC ave time - 100 trials
+! 52 ms ave run time - 4.44 SD (100 trials)
MAIN: euler053
--- /dev/null
+USING: project-euler.055 tools.test ;
+IN: project-euler.055.tests
+
+[ 249 ] [ euler055 ] unit-test
10000 [ lychrel? ] count ;
! [ euler055 ] 100 ave-time
-! 1370 ms run / 31 ms GC ave time - 100 trials
+! 478 ms ave run time - 30.63 SD (100 trials)
MAIN: euler055
--- /dev/null
+USING: project-euler.056 tools.test ;
+IN: project-euler.056.tests
+
+[ 972 ] [ euler056 ] unit-test
[ first2 ^ number>digits sum ] map supremum ;
! [ euler056 ] 100 ave-time
-! 33 ms run / 1 ms GC ave time - 100 trials
+! 22 ms ave run time - 2.13 SD (100 trials)
MAIN: euler056
--- /dev/null
+USING: project-euler.059 tools.test ;
+IN: project-euler.059.tests
+
+[ 107359 ] [ euler059 ] unit-test
source-059 dup 3 crack-key decrypt sum ;
! [ euler059 ] 100 ave-time
-! 13 ms run / 0 ms GC ave time - 100 trials
+! 8 ms ave run time - 1.4 SD (100 trials)
MAIN: euler059
--- /dev/null
+USING: project-euler.067 tools.test ;
+IN: project-euler.067.tests
+
+[ 7273 ] [ euler067 ] unit-test
+[ 7273 ] [ euler067a ] unit-test
source-067 propagate-all first first ;
! [ euler067 ] 100 ave-time
-! 18 ms run / 0 ms GC time
+! 20 ms ave run time - 2.12 SD (100 trials)
! ALTERNATE SOLUTIONS
source-067 max-path ;
! [ euler067a ] 100 ave-time
-! 14 ms run / 0 ms GC ave time - 100 trials
+! 21 ms ave run time - 2.65 SD (100 trials)
MAIN: euler067a
--- /dev/null
+USING: project-euler.071 tools.test ;
+IN: project-euler.071.tests
+
+[ 428570 ] [ euler071 ] unit-test
--- /dev/null
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math project-euler.common sequences ;
+IN: project-euler.071
+
+! http://projecteuler.net/index.php?section=problems&id=71
+
+! DESCRIPTION
+! -----------
+
+! Consider the fraction, n/d, where n and d are positive integers. If n<d and
+! HCF(n,d) = 1, it is called a reduced proper fraction.
+
+! If we list the set of reduced proper fractions for d <= 8 in ascending order of
+! size, we get:
+
+! 1/8, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 3/8, 2/5, 3/7, 1/2, 4/7, 3/5, 5/8,
+! 2/3, 5/7, 3/4, 4/5, 5/6, 6/7, 7/8
+
+! It can be seen that 2/5 is the fraction immediately to the left of 3/7.
+
+! By listing the set of reduced proper fractions for d <= 1,000,000 in
+! ascending order of size, find the numerator of the fraction immediately to the
+! left of 3/7.
+
+
+! SOLUTION
+! --------
+
+! Use the properties of a Farey sequence by setting an upper bound of 3/7 and
+! then taking the mediant of that fraction and the one to its immediate left
+! repeatedly until the denominator is as close to 1000000 as possible without
+! going over.
+
+<PRIVATE
+
+: penultimate ( seq -- elt )
+ dup length 2 - swap nth ;
+
+PRIVATE>
+
+: euler071 ( -- answer )
+ 2/5 [ dup denominator 1000000 <= ] [ 3/7 mediant dup ] [ ] produce
+ nip penultimate numerator ;
+
+! [ euler071 ] 100 ave-time
+! 155 ms ave run time - 6.95 SD (100 trials)
+
+MAIN: euler071
--- /dev/null
+USING: project-euler.073 tools.test ;
+IN: project-euler.073.tests
+
+[ 5066251 ] [ euler073 ] unit-test
--- /dev/null
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel locals make math project-euler.common sequences ;
+IN: project-euler.073
+
+! http://projecteuler.net/index.php?section=problems&id=73
+
+! DESCRIPTION
+! -----------
+
+! Consider the fraction, n/d, where n and d are positive integers. If n<d and
+! HCF(n,d) = 1, it is called a reduced proper fraction.
+
+! If we list the set of reduced proper fractions for d <= 8 in ascending order of
+! size, we get:
+
+! 1/8, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 3/8, 2/5, 3/7, 1/2, 4/7, 3/5, 5/8,
+! 2/3, 5/7, 3/4, 4/5, 5/6, 6/7, 7/8
+
+! It can be seen that there are 3 fractions between 1/3 and 1/2.
+
+! How many fractions lie between 1/3 and 1/2 in the sorted set of reduced
+! proper fractions for d <= 10,000?
+
+
+! SOLUTION
+! --------
+
+! Use the properties of a Farey sequence and mediants to recursively generate
+! the next fraction until the denominator is as close to 1000000 as possible
+! without going over.
+
+<PRIVATE
+
+:: (euler073) ( limit lo hi -- )
+ [let | m [ lo hi mediant ] |
+ m denominator limit <= [
+ m ,
+ limit lo m (euler073)
+ limit m hi (euler073)
+ ] when
+ ] ;
+
+PRIVATE>
+
+: euler073 ( -- answer )
+ [ 10000 1/3 1/2 (euler073) ] { } make length ;
+
+! [ euler073 ] 10 ave-time
+! 20506 ms ave run time - 937.07 SD (10 trials)
+
+MAIN: euler073
--- /dev/null
+USING: project-euler.075 tools.test ;
+IN: project-euler.075.tests
+
+[ 214954 ] [ euler075 ] unit-test
! 120 cm: (30,40,50), (20,48,52), (24,45,51)
-! Given that L is the length of the wire, for how many values of L ≤ 1,000,000
+! Given that L is the length of the wire, for how many values of L ≤ 2,000,000
! can exactly one right angle triangle be formed?
! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html
! Identical implementation as problem #39
-! Basically, this makes an array of 1000000 zeros, recursively creates
+! Basically, this makes an array of 2000000 zeros, recursively creates
! primitive triples using the three transforms and then increments the array at
-! index [a+b+c] by one for each triple's sum AND its multiples under 1000000
+! index [a+b+c] by one for each triple's sum AND its multiples under 2000000
! (to account for non-primitive triples). The answer is just the total number
! of indexes that are equal to one.
: euler075 ( -- answer )
[
- 1000000 count-perimeters p-count get [ 1 = ] count
+ 2000000 count-perimeters p-count get [ 1 = ] count
] with-scope ;
-! [ euler075 ] 100 ave-time
-! 1873 ms run / 123 ms GC ave time - 100 trials
+! [ euler075 ] 10 ave-time
+! 3341 ms ave run timen - 157.77 SD (10 trials)
MAIN: euler075
--- /dev/null
+USING: project-euler.076 tools.test ;
+IN: project-euler.076.tests
+
+[ 190569291 ] [ euler076 ] unit-test
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators kernel locals math math.order math.ranges
- sequences ;
+USING: arrays assocs kernel locals math math.order math.ranges sequences ;
IN: project-euler.076
! http://projecteuler.net/index.php?section=problems&id=76
100 (euler076) ;
! [ euler076 ] 100 ave-time
-! 704 ms run time - 100 trials
+! 560 ms ave run time - 17.74 SD (100 trials)
MAIN: euler076
--- /dev/null
+USING: project-euler.079 tools.test ;
+IN: project-euler.079.tests
+
+[ 73162890 ] [ euler079 ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs hashtables io.files kernel math math.parser
-namespaces make io.encodings.ascii sequences sets ;
+USING: assocs io.encodings.ascii io.files kernel make math math.parser
+ sequences sets ;
IN: project-euler.079
! http://projecteuler.net/index.php?section=problems&id=79
source-079 >edges topological-sort 10 digits>integer ;
! [ euler079 ] 100 ave-time
-! 2 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.46 SD (100 trials)
! TODO: prune and diff are relatively slow; topological sort could be
! cleaned up and generalized much better, but it works for this problem
--- /dev/null
+USING: project-euler.092 tools.test ;
+IN: project-euler.092.tests
+
+[ 8581146 ] [ euler092 ] unit-test
! Copyright (c) 2008 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences ;
+USING: kernel math math.ranges project-euler.common sequences ;
IN: project-euler.092
! http://projecteuler.net/index.php?section=problems&id=92
<PRIVATE
: next-link ( n -- m )
- 0 swap [ dup zero? not ] [ 10 /mod sq -rot [ + ] dip ] [ ] while drop ;
+ number>digits [ sq ] sigma ;
: chain-ending ( n -- m )
- dup 1 = over 89 = or [ next-link chain-ending ] unless ;
+ dup [ 1 = ] [ 89 = ] bi or [ next-link chain-ending ] unless ;
: lower-endings ( -- seq )
567 [1,b] [ chain-ending ] map ;
: fast-chain-ending ( seq n -- m )
dup 567 > [ next-link ] when 1- swap nth ;
-: count ( seq quot -- n )
- 0 -rot [ rot >r call [ r> 1+ ] [ r> ] if ] curry each ; inline
-
PRIVATE>
: euler092 ( -- answer )
lower-endings 9999999 [1,b] [ fast-chain-ending 89 = ] with count ;
! [ euler092 ] 10 ave-time
-! 11169 ms run / 0 ms GC ave time - 10 trials
+! 33257 ms ave run time - 624.27 SD (10 trials)
+
+! TODO: this solution is not very efficient, much better optimizations exist
MAIN: euler092
--- /dev/null
+USING: project-euler.097 tools.test ;
+IN: project-euler.097.tests
+
+[ 8739992577 ] [ euler097 ] unit-test
2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1+ ;
! [ euler097 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run timen - 0.22 SD (100 trials)
MAIN: euler097
--- /dev/null
+USING: project-euler.100 tools.test ;
+IN: project-euler.100.tests
+
+[ 756872327473 ] [ euler100 ] unit-test
[ dup dup 1- * 2 * 10 24 ^ <= ]
[ tuck 6 * swap - 2 - ] [ ] while nip ;
-! TODO: solution is incredibly slow (>30 minutes) and needs generalization
+! TODO: solution needs generalization
-! [ euler100 ] time
-! ? ms run time
+! [ euler100 ] 100 ave-time
+! 0 ms ave run time - 0.14 SD (100 trials)
MAIN: euler100
--- /dev/null
+USING: project-euler.116 tools.test ;
+IN: project-euler.116.tests
+
+[ 20492570929 ] [ euler116 ] unit-test
50 (euler116) ;
! [ euler116 ] 100 ave-time
-! 0 ms run time - 100 trials
+! 0 ms ave run time - 0.34 SD (100 trials)
MAIN: euler116
--- /dev/null
+USING: project-euler.117 tools.test ;
+IN: project-euler.117.tests
+
+[ 100808458960497 ] [ euler117 ] unit-test
50 (euler117) ;
! [ euler117 ] 100 ave-time
-! 0 ms run time - 100 trials
+! 0 ms ave run time - 0.29 SD (100 trials)
MAIN: euler117
--- /dev/null
+USING: project-euler.134 tools.test ;
+IN: project-euler.134.tests
+
+[ 18613426663617118 ] [ euler134 ] unit-test
[ [ s + ] keep ] leach drop ;
! [ euler134 ] 10 ave-time
-! 2430 ms run / 36 ms GC ave time - 10 trials
+! 933 ms ave run timen - 19.58 SD (10 trials)
MAIN: euler134
--- /dev/null
+USING: project-euler.148 tools.test ;
+IN: project-euler.148.tests
+
+[ 2129970655314432 ] [ euler148 ] unit-test
10 9 ^ (euler148) ;
! [ euler148 ] 100 ave-time
-! 0 ms run time - 100 trials
+! 0 ms ave run time - 0.17 SD (100 trials)
MAIN: euler148
--- /dev/null
+USING: project-euler.150 tools.test ;
+IN: project-euler.150.tests
+
+[ -271248680 ] [ euler150 ] unit-test
1000 (euler150) ;
! [ euler150 ] 10 ave-time
-! 32858 ms run time - 10 trials
+! 30208 ms ave run time - 593.45 SD (10 trials)
MAIN: euler150
--- /dev/null
+USING: project-euler.164 tools.test ;
+IN: project-euler.164.tests
+
+[ 378158756814587 ] [ euler164 ] unit-test
init-table 19 [ next-table ] times values sum ;
! [ euler164 ] 100 ave-time
-! 8 ms run time - 100 trials
+! 7 ms ave run time - 1.23 SD (100 trials)
MAIN: euler164
--- /dev/null
+USING: project-euler.169 tools.test ;
+IN: project-euler.169.tests
+
+[ 178653872807 ] [ euler169 ] unit-test
! 2 + 4 + 4
! 2 + 8
-! What is f(1025)?
+! What is f(10^25)?
! SOLUTION
10 25 ^ fn ;
! [ euler169 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.2 SD (100 trials)
MAIN: euler169
--- /dev/null
+USING: project-euler.173 tools.test ;
+IN: project-euler.173.tests
+
+[ 1572729 ] [ euler173 ] unit-test
1000000 laminae ;
! [ euler173 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.35 SD (100 trials)
MAIN: euler173
--- /dev/null
+USING: project-euler.175 tools.test ;
+IN: project-euler.175.tests
+
+[ "1,13717420,8" ] [ euler175 ] unit-test
V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ;
! [ euler175 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.31 SD (100 trials)
MAIN: euler175
--- /dev/null
+USING: project-euler.186 tools.test ;
+IN: project-euler.186.tests
+
+[ 2325629 ] [ euler186 ] unit-test
-USING: circular disjoint-sets kernel math math.ranges
-sequences ;
+! Copyright (c) 2008 Eric Mertens.
+! See http://factorcode.org/license.txt for BSD license.
+USING: circular disjoint-sets kernel math math.ranges sequences ;
IN: project-euler.186
+! http://projecteuler.net/index.php?section=problems&id=186
+
+! DESCRIPTION
+! -----------
+
+! Here are the records from a busy telephone system with one million users:
+
+! RecNr Caller Called
+! 1 200007 100053
+! 2 600183 500439
+! 3 600863 701497
+! ... ... ...
+
+! The telephone number of the caller and the called number in record n are
+! Caller(n) = S2n-1 and Called(n) = S2n where S1,2,3,... come from the "Lagged
+! Fibonacci Generator":
+
+! For 1 <= k <= 55, Sk = [100003 - 200003k + 300007k^3] (modulo 1000000)
+! For 56 <= k, Sk = [Sk-24 + Sk-55] (modulo 1000000)
+
+! If Caller(n) = Called(n) then the user is assumed to have misdialled and the
+! call fails; otherwise the call is successful.
+
+! From the start of the records, we say that any pair of users X and Y are
+! friends if X calls Y or vice-versa. Similarly, X is a friend of a friend of Z
+! if X is a friend of Y and Y is a friend of Z; and so on for longer chains.
+
+! The Prime Minister's phone number is 524287. After how many successful calls,
+! not counting misdials, will 99% of the users (including the PM) be a friend,
+! or a friend of a friend etc., of the Prime Minister?
+
+
+! SOLUTION
+! --------
+
: (generator) ( k -- n )
dup sq 300007 * 200003 - * 100003 + 1000000 rem ;
[ first ] [ advance ] bi ;
: 2unless? ( x y ?quot quot -- )
- >r 2keep rot [ 2drop ] r> if ; inline
+ [ 2keep rot [ 2drop ] ] dip if ; inline
: (p186) ( generator counter unionfind -- counter )
- 524287 over equiv-set-size 990000 <
- [
+ 524287 over equiv-set-size 990000 < [
pick [ next ] [ next ] bi
[ = ] [
pick equate
: euler186 ( -- n )
<generator> 0 1000000 <relation> (p186) ;
+! [ euler186 ] 10 ave-time
+! 18572 ms ave run time - 796.87 SD (10 trials)
+
MAIN: euler186
--- /dev/null
+USING: project-euler.190 tools.test ;
+IN: project-euler.190.tests
+
+[ 371048281 ] [ euler190 ] unit-test
2 15 [a,b] [ P_m truncate ] sigma ;
! [ euler150 ] 100 ave-time
-! 7 ms run time - 100 trials
+! 5 ms ave run time - 1.01 SD (100 trials)
MAIN: euler190
--- /dev/null
+USING: project-euler.203 tools.test ;
+IN: project-euler.203.tests
+
+[ 105 ] [ 8 solve ] unit-test
+[ 34029210557338 ] [ 51 solve ] unit-test
--- /dev/null
+USING: fry kernel math math.primes.factors sequences sets ;
+IN: project-euler.203
+
+: iterate ( n initial quot -- results ) swapd '[ @ dup ] replicate nip ; inline
+: (generate) ( seq -- seq ) [ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ;
+: generate ( n -- seq ) 1- { 1 } [ (generate) ] iterate concat prune ;
+: squarefree ( n -- ? ) factors duplicates empty? ;
+: solve ( n -- n ) generate [ squarefree ] filter sum ;
+: euler203 ( -- n ) 51 solve ;
--- /dev/null
+USING: project-euler.215 project-euler.215.private tools.test ;
+IN: project-euler.215.tests
+
+[ 8 ] [ 9 3 solve ] unit-test
+[ 806844323190414 ] [ euler215 ] unit-test
--- /dev/null
+! Copyright (c) 2008 Eric Mertens.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals math ;
+IN: project-euler.215
+
+! http://projecteuler.net/index.php?section=problems&id=215
+
+! DESCRIPTION
+! -----------
+
+! Consider the problem of building a wall out of 2x1 and 3x1 bricks
+! (horizontalvertical dimensions) such that, for extra strength, the gaps
+! between horizontally-adjacent bricks never line up in consecutive layers,
+! i.e. never form a "running crack".
+
+! For example, the following 93 wall is not acceptable due to the running crack
+! shown in red:
+
+! See problem site for image...
+
+! There are eight ways of forming a crack-free 9x3 wall, written W(9,3) = 8.
+
+! Calculate W(32,10).
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+TUPLE: block two three ;
+TUPLE: end { ways integer } ;
+
+C: <block> block
+C: <end> end
+: <failure> 0 <end> ; inline
+: <success> 1 <end> ; inline
+
+: failure? ( t -- ? ) ways>> 0 = ; inline
+
+: choice ( t p q -- t t )
+ [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline
+
+GENERIC: merge ( t t -- t )
+GENERIC# block-merge 1 ( t t -- t )
+GENERIC# end-merge 1 ( t t -- t )
+M: block merge block-merge ;
+M: end merge end-merge ;
+M: block block-merge [ [ two>> ] bi@ merge ]
+ [ [ three>> ] bi@ merge ] 2bi <block> ;
+M: end block-merge nip ;
+M: block end-merge drop ;
+M: end end-merge [ ways>> ] bi@ + <end> ;
+
+GENERIC: h-1 ( t -- t )
+GENERIC: h0 ( t -- t )
+GENERIC: h1 ( t -- t )
+GENERIC: h2 ( t -- t )
+
+M: block h-1 [ h1 ] [ h2 ] choice merge ;
+M: block h0 drop <failure> ;
+M: block h1 [ [ h1 ] [ h2 ] choice merge ]
+ [ [ h0 ] [ h1 ] choice merge ] bi <block> ;
+M: block h2 [ h1 ] [ h2 ] choice merge <failure> swap <block> ;
+
+M: end h-1 drop <failure> ;
+M: end h0 ;
+M: end h1 drop <failure> ;
+M: end h2 dup failure? [ <failure> <block> ] unless ;
+
+: next-row ( t -- t ) [ h-1 ] [ h1 ] choice swap <block> ;
+
+: first-row ( n -- t )
+ [ <failure> <success> <failure> ] dip
+ 1- [| a b c | b c <block> a b ] times 2drop ;
+
+GENERIC: total ( t -- n )
+M: block total [ total ] dup choice + ;
+M: end total ways>> ;
+
+: solve ( width height -- ways )
+ [ first-row ] dip 1- [ next-row ] times total ;
+
+PRIVATE>
+
+: euler215 ( -- answer )
+ 32 10 solve ;
+
+! [ euler215 ] 100 ave-time
+! 208 ms ave run time - 9.06 SD (100 trials)
+
+MAIN: euler215
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations io kernel math math.functions math.parser math.statistics
- namespaces make tools.time ;
+USING: continuations fry io kernel make math math.functions math.parser
+ math.statistics memory tools.time ;
IN: project-euler.ave-time
: collect-benchmarks ( quot n -- seq )
- [
- >r >r datastack r> [ benchmark , ] curry tuck
- [ with-datastack drop ] 2curry r> swap times call
- ] { } make ;
+ [
+ [ datastack ]
+ [ '[ _ gc benchmark , ] tuck '[ _ _ with-datastack drop ] ]
+ [ 1- ] tri* swap times call
+ ] { } make ; inline
: nth-place ( x n -- y )
10 swap ^ [ * round ] keep / ;
: ave-time ( quot n -- )
- [ collect-benchmarks ] keep
- swap [ std 2 nth-place ] [ mean round ] bi [
+ [ collect-benchmarks ] keep swap
+ [ std 2 nth-place ] [ mean round ] bi [
# " ms ave run time - " % # " SD (" % # " trials)" %
] "" make print flush ; inline
-USING: arrays kernel math math.functions math.miller-rabin
-math.matrices math.order math.parser math.primes.factors
-math.ranges namespaces make sequences sequences.lib sorting
-unicode.case ;
+! Copyright (c) 2007-2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel make math math.functions math.matrices math.miller-rabin
+ math.order math.parser math.primes.factors math.ranges math.ratios
+ sequences sequences.lib sorting strings unicode.case ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
! -------------------------------
! alpha-value - #22, #42
! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
-! collect-consecutive - #8, #11
! log10 - #25, #134
! max-path - #18, #67
+! mediant - #71, #73
! nth-triangle - #12, #42
-! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56
+! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
! palindrome? - #4, #36, #55
! pandigital? - #32, #38
! pentagonal? - #44, #45
! [uad]-transform - #39, #75
-: nth-pair ( n seq -- nth next )
- over 1+ over nth >r nth r> ;
+: nth-pair ( seq n -- nth next )
+ tail-slice first2 ;
: perfect-square? ( n -- ? )
dup sqrt mod zero? ;
<PRIVATE
-: count-shifts ( seq width -- n )
- >r length 1+ r> - ;
-
: max-children ( seq -- seq )
- [ dup length 1- [ over nth-pair max , ] each ] { } make nip ;
+ [ dup length 1- [ nth-pair max , ] with each ] { } make ;
! Propagate one row into the upper one
: propagate ( bottom top -- newtop )
[ over rest rot first2 max rot + ] map nip ;
-: shift-3rd ( seq obj obj -- seq obj obj )
- rot rest -rot ;
-
: (sum-divisors) ( n -- sum )
dup sqrt >fixnum [1,b] [
- [ 2dup mod zero? [ 2dup / + , ] [ drop ] if ] each
+ [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each
dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
] { } make sum ;
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
swap [ swap [ 2array ] map-with ] map-with concat ;
-: collect-consecutive ( seq width -- seq )
- [
- 2dup count-shifts [ 2dup head shift-3rd , ] times
- ] { } make 2nip ;
-
: log10 ( m -- n )
log 10 log / ;
+: mediant ( a/c b/d -- (a+b)/(c+d) )
+ 2>fraction [ + ] 2bi@ / ;
+
: max-path ( triangle -- n )
dup length 1 > [
2 cut* first2 max-children [ + ] 2map suffix max-path
] if ;
: number>digits ( n -- seq )
- [ dup zero? not ] [ 10 /mod ] [ ] produce reverse nip ;
+ [ dup 0 = not ] [ 10 /mod ] [ ] produce reverse nip ;
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
number>string dup reverse = ;
: pandigital? ( n -- ? )
- number>string natural-sort "123456789" = ;
+ number>string natural-sort >string "123456789" = ;
: pentagonal? ( n -- ? )
dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
-: propagate-all ( triangle -- newtriangle )
- reverse [ first dup ] keep rest [ propagate dup ] map nip reverse swap suffix ;
+: propagate-all ( triangle -- new-triangle )
+ reverse [ first dup ] [ rest ] bi
+ [ propagate dup ] map nip reverse swap suffix ;
: sum-divisors ( n -- sum )
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
! Optimized brute-force, is often faster than prime factorization
: tau* ( m -- n )
- factor-2s [ 1+ ] dip [ perfect-square? -1 0 ? ] keep
- dup sqrt >fixnum [1,b] [
- dupd mod zero? [ [ 2 + ] dip ] when
+ factor-2s dup [ 1+ ]
+ [ perfect-square? -1 0 ? ]
+ [ dup sqrt >fixnum [1,b] ] tri* [
+ dupd mod 0 = [ [ 2 + ] dip ] when
] each drop * ;
! These transforms are for generating primitive Pythagorean triples
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: definitions io io.files kernel math math.parser project-euler.ave-time
- sequences vocabs vocabs.loader
+USING: definitions io io.files kernel math math.parser
+ prettyprint project-euler.ave-time sequences vocabs vocabs.loader
project-euler.001 project-euler.002 project-euler.003 project-euler.004
project-euler.005 project-euler.006 project-euler.007 project-euler.008
project-euler.009 project-euler.010 project-euler.011 project-euler.012
project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.047 project-euler.048
- project-euler.052 project-euler.053 project-euler.056 project-euler.059
- project-euler.067 project-euler.075 project-euler.079 project-euler.092
+ project-euler.052 project-euler.053 project-euler.055 project-euler.056
+ project-euler.059 project-euler.067 project-euler.071 project-euler.073
+ project-euler.075 project-euler.076 project-euler.079 project-euler.092
project-euler.097 project-euler.100 project-euler.116 project-euler.117
project-euler.134 project-euler.148 project-euler.150 project-euler.151
project-euler.164 project-euler.169 project-euler.173 project-euler.175
- project-euler.186 project-euler.190 ;
+ project-euler.186 project-euler.190 project-euler.215 ;
IN: project-euler
<PRIVATE
: solution-path ( n -- str/f )
number>euler "project-euler." prepend
- vocab where dup [ first ] when ;
+ vocab where dup [ first <pathname> ] when ;
PRIVATE>
: run-project-euler ( -- )
problem-prompt dup problem-solved? [
dup number>euler "project-euler." prepend run
- "Answer: " swap dup number? [ number>string ] when append print
- "Source: " swap solution-path append print
+ "Answer: " write dup number? [ number>string ] when print
+ "Source: " write solution-path .
] [
drop "That problem has not been solved yet..." print
] if ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel math ;
IN: roman
{ $values { "n" "an integer" } { "str" "a string" } }
{ $description "Converts a number to its lower-case Roman Numeral equivalent." }
{ $notes "The range for this word is 1-3999, inclusive." }
-{ $see-also >ROMAN roman> } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "56 >roman print"
+ "lvi"
+ }
+} ;
HELP: >ROMAN
{ $values { "n" "an integer" } { "str" "a string" } }
{ $description "Converts a number to its upper-case Roman numeral equivalent." }
{ $notes "The range for this word is 1-3999, inclusive." }
-{ $see-also >roman roman> } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "56 >ROMAN print"
+ "LVI"
+ }
+} ;
HELP: roman>
{ $values { "str" "a string" } { "n" "an integer" } }
{ $description "Converts a Roman numeral to an integer." }
{ $notes "The range for this word is i-mmmcmxcix, inclusive." }
-{ $see-also >roman } ;
+{ $examples
+ { $example "USING: prettyprint roman ;"
+ "\"lvi\" roman> ."
+ "56"
+ }
+} ;
+
+{ >roman >ROMAN roman> } related-words
HELP: roman+
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Adds two Roman numerals." }
-{ $see-also roman- } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"v\" \"v\" roman+ print"
+ "x"
+ }
+} ;
HELP: roman-
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Subtracts two Roman numerals." }
-{ $see-also roman+ } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"x\" \"v\" roman- print"
+ "v"
+ }
+} ;
+
+{ roman+ roman- } related-words
HELP: roman*
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Multiplies two Roman numerals." }
-{ $see-also roman/i roman/mod } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"ii\" \"iii\" roman* print"
+ "vi"
+ }
+} ;
HELP: roman/i
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Computes the integer division of two Roman numerals." }
-{ $see-also roman* roman/mod /i } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"v\" \"iv\" roman/i print"
+ "i"
+ }
+} ;
HELP: roman/mod
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
{ $description "Computes the quotient and remainder of two Roman numerals." }
-{ $see-also roman* roman/i /mod } ;
+{ $examples
+ { $example "USING: kernel io roman ;"
+ "\"v\" \"iv\" roman/mod [ print ] bi@"
+ "i\ni"
+ }
+} ;
+
+{ roman* roman/i roman/mod } related-words
HELP: ROMAN:
-{ $description "A parsing word that reads the next token and converts it to an integer." } ;
+{ $description "A parsing word that reads the next token and converts it to an integer." }
+{ $examples
+ { $example "USING: prettyprint roman ;"
+ "ROMAN: v ."
+ "5"
+ }
+} ;
+
+ARTICLE: "roman" "Roman numerals"
+"The " { $vocab-link "roman" } " vocabulary can convert numbers to and from the Roman numeral system and can perform arithmetic given Roman numerals as input." $nl
+"A parsing word for literal Roman numerals:"
+{ $subsection POSTPONE: ROMAN: }
+"Converting to Roman numerals:"
+{ $subsection >roman }
+{ $subsection >ROMAN }
+"Converting Roman numerals to integers:"
+{ $subsection roman> }
+"Roman numeral arithmetic:"
+{ $subsection roman+ }
+{ $subsection roman- }
+{ $subsection roman* }
+{ $subsection roman/i }
+{ $subsection roman/mod } ;
+
+ABOUT: "roman"
: enumerate ( seq -- seq' ) <enum> >alist ;
+: splice ( left-seq right-seq seq -- newseq ) swap 3append ;
+
+: surround ( seq left-seq right-seq -- newseq ) swapd 3append ;
+++ /dev/null
-
-USING: kernel namespaces sequences
- io io.files io.launcher io.encodings.ascii
- bake builder.util
- accessors vars
- math.parser ;
-
-IN: size-of
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: headers
-
-: include-headers ( -- seq )
- headers> [ `{ "#include <" , ">" } to-string ] map ;
-
-: size-of-c-program ( type -- lines )
- `{
- "#include <stdio.h>"
- include-headers
- { "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" }
- }
- to-strings ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: c-file ( -- path ) "size-of.c" temp-file ;
-
-: exe ( -- path ) "size-of" temp-file ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: size-of ( type -- n )
- size-of-c-program c-file ascii set-file-lines
-
- { "gcc" c-file "-o" exe } to-strings
- [ "Error compiling generated C program" print ] run-or-bail
-
- exe ascii <process-reader> contents string>number ;
\ No newline at end of file
--- /dev/null
+USING: arrays assocs kernel vectors sequences namespaces
+ random math.parser math fry ;
+
+IN: assocs.lib
+
+: set-assoc-stack ( value key seq -- )
+ dupd [ key? ] with find-last nip set-at ;
+
+: at-default ( key assoc -- value/key )
+ dupd at [ nip ] when* ;
+
+: replace-at ( assoc value key -- assoc )
+ >r >r dup r> 1vector r> rot set-at ;
+
+: peek-at* ( assoc key -- obj ? )
+ swap at* dup [ >r peek r> ] when ;
+
+: peek-at ( assoc key -- obj )
+ peek-at* drop ;
+
+: >multi-assoc ( assoc -- new-assoc )
+ [ 1vector ] assoc-map ;
+
+: multi-assoc-each ( assoc quot -- )
+ [ with each ] curry assoc-each ; inline
+
+: insert ( value variable -- ) namespace push-at ;
+
+: generate-key ( assoc -- str )
+ >r 32 random-bits >hex r>
+ 2dup key? [ nip generate-key ] [ drop ] if ;
+
+: set-at-unique ( value assoc -- key )
+ dup generate-key [ swap set-at ] keep ;
+
+: histogram ( assoc quot -- assoc' )
+ H{ } clone [
+ swap [ change-at ] 2curry assoc-each
+ ] keep ; inline
+
+: inc-at ( key assoc -- )
+ [ 0 or 1 + ] change-at ;
+
+: ?at ( obj assoc -- value/obj ? )
+ dupd at* [ [ nip ] [ drop ] if ] keep ;
+
+: if-at ( obj assoc quot1 quot2 -- )
+ [ ?at ] 2dip if ; inline
+
+: when-at ( obj assoc quot -- ) [ ] if-at ; inline
+
+: unless-at ( obj assoc quot -- ) [ ] swap if-at ; inline
}
{ default-block-style
H{
- { wrap-margin 1000 }
+ { wrap-margin 1100 }
}
}
{ code-style
}
}
{ table-content-style
- H{ { wrap-margin 800 } }
+ H{ { wrap-margin 1000 } }
}
{ list-style
H{ { table-gap { 10 20 } } }
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences sequences.lib grouping assocs kernel ascii
-unicode.case tr ;
+USING: sequences grouping assocs kernel ascii unicode.case tr ;
IN: soundex
TR: soundex-tr
USING: tools.deploy.config ;
H{
{ deploy-reflection 1 }
- { deploy-random? t }
{ deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-name "Spheres" }
-USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
-opengl multiline ui.gadgets accessors sequences ui.render ui math locals
-arrays generalizations combinators opengl.capabilities ui.gadgets.worlds ;
+USING: kernel opengl opengl.demo-support opengl.gl
+opengl.shaders opengl.framebuffers opengl.capabilities multiline
+ui.gadgets accessors sequences ui.render ui math locals arrays
+generalizations combinators ui.gadgets.worlds ;
IN: spheres
STRING: plane-vertex-shader
! : display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
-: display ( -- ) set-projection black set-color draw-nodes draw-springs ;
+: display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: tools.deploy.config ;
H{
{ deploy-word-defs? f }
- { deploy-random? f }
{ deploy-name "Sudoku" }
{ deploy-threads? f }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
- { deploy-random? t }
{ deploy-io 2 }
{ deploy-math? t }
{ deploy-word-defs? f }
#! OpenGL rendering for tetris
: draw-block ( block -- )
- dup { 1 1 } v+ gl-fill-rect ;
+ [ { 1 1 } gl-fill-rect ] with-translation ;
: draw-piece-blocks ( piece -- )
piece-blocks [ draw-block ] each ;
: draw-piece ( piece -- )
- dup tetromino>> colour>> set-color draw-piece-blocks ;
+ dup tetromino>> colour>> gl-color draw-piece-blocks ;
: draw-next-piece ( piece -- )
dup tetromino>> colour>>
- clone 0.2 >>alpha set-color draw-piece-blocks ;
+ clone 0.2 >>alpha gl-color draw-piece-blocks ;
! TODO: move implementation specific stuff into tetris-board
: (draw-row) ( x y row -- )
>r over r> nth dup
- [ set-color 2array draw-block ] [ 3drop ] if ;
+ [ gl-color 2array draw-block ] [ 3drop ] if ;
: draw-row ( y row -- )
dup length -rot [ (draw-row) ] 2curry each ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test time-server ;
+IN: time-server.tests
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.servers.connection accessors threads
+calendar calendar.format ;
+IN: time-server
+
+: handle-time-client ( -- )
+ now timestamp>rfc822 print ;
+
+: <time-server> ( -- threaded-server )
+ <threaded-server>
+ "time-server" >>name
+ 1234 >>insecure
+ [ handle-time-client ] >>handler ;
+
+: start-time-server ( -- threaded-server )
+ <time-server> [ start-server ] in-thread ;
+
+MAIN: start-time-server
-USING: namespaces debugger io.files bootstrap.image builder.util ;
+USING: namespaces debugger io.files bootstrap.image update.util ;
IN: update.backup
USING: kernel namespaces system io.files bootstrap.image http.client
- builder.util update update.backup ;
+ update update.backup update.util ;
IN: update.latest
USING: kernel system sequences io.files io.launcher bootstrap.image
http.client
- builder.util builder.release.branch ;
+ update.util ;
+
+ ! builder.util builder.release.branch ;
IN: update
--- /dev/null
+
+USING: kernel classes strings quotations words math math.parser arrays
+ combinators.cleave
+ accessors
+ system prettyprint splitting
+ sequences combinators sequences.deep
+ io
+ io.launcher
+ io.encodings.utf8
+ calendar
+ calendar.format ;
+
+IN: update.util
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: to-strings
+
+: to-string ( obj -- str )
+ dup class
+ {
+ { \ string [ ] }
+ { \ quotation [ call ] }
+ { \ word [ execute ] }
+ { \ fixnum [ number>string ] }
+ { \ array [ to-strings concat ] }
+ }
+ case ;
+
+: to-strings ( seq -- str )
+ dup [ string? ] all?
+ [ ]
+ [ [ to-string ] map flatten ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
+
+: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: branch-name ( -- string ) "clean-" platform append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gnu-make ( -- string )
+ os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-id ( -- id )
+ { "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
+ " " split second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: datestamp ( -- string )
+ now
+ { year>> month>> day>> hour>> minute>> } <arr>
+ [ pad-00 ] map "-" join ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slides help.markup math arrays hashtables namespaces
+sequences kernel sequences parser memoize io.encodings.binary
+locals kernel.private tools.vocabs.browser assocs quotations
+urls peg.ebnf tools.vocabs tools.annotations tools.crossref
+help.topics math.functions compiler.tree.optimizer
+compiler.cfg.optimizer fry ;
+IN: vpri-talk
+
+: vpri-slides
+{
+ { $slide "Factor!"
+ { $url "http://factorcode.org" }
+ "Development started in 2003"
+ "Open source (BSD license)"
+ "Influenced by Forth, Lisp, and Smalltalk"
+ "Blurs the line between language and library"
+ "Interactive development"
+ }
+ { $slide "Programming is hard"
+ "Let's play tetris instead"
+ { $vocab-link "tetris" }
+ "Tetris is hard too... let's cheat"
+ "Factor workflow: change code, F2, test, repeat"
+ }
+ { $slide "Basics"
+ "Stack based, dynamically typed"
+ { $code "{ 1 1 3 4 4 8 9 9 } dup duplicates diff ." }
+ "Words: named code snippets"
+ { $code ": remove-duplicates ( seq -- seq' )" " dup duplicates diff ;" }
+ { $code "{ 1 1 3 4 4 8 9 9 } remove-duplicates ." }
+ "Vocabularies: named sets of words"
+ { $link "vocab-index" }
+ }
+ { $slide "Quotations"
+ "Quotation: unnamed block of code"
+ "Combinators: words taking quotations"
+ { $code "{ 1 1 3 4 4 8 9 9 }" "[ { 1 3 8 } member? ] filter ." }
+ { $code "{ -1 1 -2 0 3 } [ 0 max ] map" }
+ "Partial application:"
+ { $code ": clamp ( seq n -- seq' ) '[ _ max ] map" "{ -1 1 -2 0 3 } 0 clamp ;" }
+ }
+ { $slide "Object system"
+ "CLOS with single dispatch"
+ "A tuple is a user-defined class which holds named values."
+ { $code
+ "TUPLE: rectangle width height ;"
+ "TUPLE: circle radius ;"
+ }
+ }
+ { $slide "Object system"
+ "Constructing instances:"
+ { $code "rectangle new" }
+ { $code "rectangle boa" }
+ "Let's encapsulate:"
+ { $code
+ ": <rectangle> ( w h -- r ) rectangle boa ;"
+ ": <circle> ( r -- c ) circle boa ;"
+ }
+ }
+ { $slide "Object system"
+ "Generic words and methods"
+ { $code "GENERIC: area ( shape -- n )" }
+ "Two methods:"
+ { $code
+ "USE: math.constants"
+ ""
+ "M: rectangle area"
+ " [ width>> ] [ height>> ] bi * ;"
+ ""
+ "M: circle area radius>> sq pi * ;"
+ }
+ }
+ { $slide "Object system"
+ "We can compute areas now."
+ { $code "100 20 <rectangle> area ." }
+ { $code "3 <circle> area ." }
+ }
+ { $slide "Object system"
+ "New operation, existing types:"
+ { $code
+ "GENERIC: perimiter ( shape -- n )"
+ ""
+ "M: rectangle perimiter"
+ " [ width>> ] [ height>> ] bi + 2 * ;"
+ ""
+ "M: circle perimiter"
+ " radius>> 2 * pi * ;"
+ }
+ }
+ { $slide "Object system"
+ "We can compute perimiters now."
+ { $code "100 20 <rectangle> perimiter ." }
+ { $code "3 <circle> perimiter ." }
+ }
+ { $slide "Object system"
+ "New type, extending existing operations:"
+ { $code
+ "TUPLE: triangle base height ;"
+ ""
+ ": <triangle> ( b h -- t ) triangle boa ;"
+ ""
+ "M: triangle area"
+ " [ base>> ] [ height>> ] bi * 2 / ;"
+ }
+ }
+ { $slide "Object system"
+ "New type, extending existing operations:"
+ { $code
+ ": hypotenuse ( x y -- z ) [ sq ] bi@ + sqrt ;"
+ ""
+ "M: triangle perimiter"
+ " [ base>> ] [ height>> ] bi"
+ " [ + ] [ hypotenuse ] 2bi + ;"
+ }
+ }
+ { $slide "Object system"
+ "Object system handles dynamic redefinition very well"
+ { $code "TUPLE: person name age occupation ;" }
+ "Make an instance..."
+ }
+ { $slide "Object system"
+ "Let's add a new slot:"
+ { $code "TUPLE: person name age address occupation ;" }
+ "Fill it in with inspector..."
+ "Change the order:"
+ { $code "TUPLE: person name occupation address ;" }
+ }
+ { $slide "Object system"
+ "How does it work?"
+ "Objects are not hashtables; slot access is very fast"
+ "Redefinition walks the heap; expensive but rare"
+ }
+ { $slide "Object system"
+ "Supports \"duck typing\""
+ "Two tuples can have a slot with the same name"
+ "Code that uses accessors will work on both"
+ "Accessors are auto-generated generic words"
+ }
+ { $slide "Object system"
+ "More: inheritance, type declarations, read-only slots, predicate, intersection, singleton classes, reflection"
+ "Object system is entirely implemented in Factor"
+ { { $vocab-link "generic" } ", " { $vocab-link "classes" } ", " { $vocab-link "slots" } }
+ }
+ { $slide "The parser"
+ "All data types have a literal syntax"
+ "Literal hashtables and arrays are very useful in data-driven code"
+ "\"Code is data\" because quotations are objects (enables Lisp-style macros)"
+ { $code "H{ { \"cookies\" 12 } { \"milk\" 10 } }" }
+ "Libraries can define new parsing words"
+ }
+ { $slide "Example: float arrays"
+ { $vocab-link "float-arrays" }
+ "Avoids boxing and unboxing overhead"
+ "Implemented with library code"
+ { $code "F{ 3.14 7.6 10.3 }" }
+ }
+ { $slide "Example: memoization"
+ { "Memoization with " { $link POSTPONE: MEMO: } }
+ { $code
+ ": fib ( m -- n )"
+ " dup 1 > ["
+ " [ 1 - fib ] [ 2 - fib ] bi +"
+ " ] when ;"
+ }
+ "Very slow! Let's profile it..."
+ }
+ { $slide "Example: memoization"
+ { "Let's use " { $link POSTPONE: : } " instead of " { $link POSTPONE: MEMO: } }
+ { $code
+ "MEMO: fib ( m -- n )"
+ " dup 1 > ["
+ " [ 1 - fib ] [ 2 - fib ] bi +"
+ " ] when ;"
+ }
+ "Much faster"
+ }
+ { $slide "Meta-circularity"
+ { { $link POSTPONE: MEMO: } " is just a library word" }
+ { "But so is " { $link POSTPONE: : } }
+ "Factor's parser is written in Factor"
+ { "All syntax is just parsing words: " { $link POSTPONE: [ } ", " { $link POSTPONE: " } }
+ }
+ { $slide "Extensible syntax, DSLs"
+ "Most parsing words fall in one of two categories"
+ "First category: literal syntax for new data types"
+ "Second category: defining new types of words"
+ "Some parsing words are more complicated"
+ }
+ { $slide "Example: printf"
+ { { $link POSTPONE: EBNF: } ": a complex parsing word" }
+ "Implements a custom syntax for expressing parsers: like OMeta!"
+ { "Example: " { $vocab-link "printf-example" } }
+ { $code "\"vegan\" \"cheese\" \"%s is not %s\\n\" printf" }
+ { $code "5 \"Factor\" \"%s is %d years old\\n\" printf" }
+ }
+ { $slide "Example: simple web browser"
+ { $vocab-link "webkit-demo" }
+ "Demonstrates Cocoa binding"
+ "Let's deploy a stand-alone binary with the deploy tool"
+ "Deploy tool generates binaries with no external dependencies"
+ }
+ { $slide "Locals and lexical scope"
+ "Sometimes, there's no good stack solution to a problem"
+ "Or, you're porting existing code in a quick-and-dirty way"
+ "Our solution: implement named locals as a DSL in Factor"
+ "Influenced by Scheme and Lisp"
+ }
+ { $slide "Locals and lexical scope"
+ { "Define lambda words with " { $link POSTPONE: :: } }
+ { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+ "Mutable bindings with correct semantics"
+ { "Named inputs for quotations with " { $link POSTPONE: [| } }
+ "Full closures"
+ }
+ { $slide "Locals and lexical scope"
+ "Combinator with 5 parameters!"
+ { $code
+ ":: branch ( a b neg zero pos -- )"
+ " a b = zero [ a b < neg pos if ] if ; inline"
+ }
+ "Unwieldy with the stack"
+ }
+ { $slide "Locals and lexical scope"
+ { $code
+ "ERROR: underage-exception ;"
+ ""
+ ": check-drinking-age ( age -- )"
+ " 21"
+ " [ underage-exception ]"
+ " [ \"Grats, you're now legal\" print ]"
+ " [ \"Go get hammered\" print ]"
+ " branch ;"
+ }
+ }
+ { $slide "Locals and lexical scope"
+ "Locals are entirely implemented in Factor"
+ "Example of compile-time meta-programming"
+ "No performance penalty -vs- using the stack"
+ "In the base image, only 59 words out of 13,000 use locals"
+ }
+ { $slide "More about partial application"
+ { { $link POSTPONE: '[ } " is \"fry syntax\"" }
+ { $code "'[ _ + ] == [ + ] curry" }
+ { $code "'[ @ t ] == [ t ] compose" }
+ { $code "'[ _ nth @ ] == [ [ nth ] curry ] dip compose" }
+ { $code "'[ [ _ ] dip nth ] == [ [ ] curry dip nth ] curry" }
+ { "Fry and locals desugar to " { $link curry } ", " { $link compose } }
+ }
+ { $slide "More about partial application"
+ { { $link call } " is fundamental" }
+ { { $link quotation } ", " { $link curry } " and " { $link compose } " are classes" }
+ { $code
+ "GENERIC: call ( quot -- )"
+ "M: curry call uncurry call ;"
+ "M: compose call uncompose slip call ;"
+ "M: quotation call (call) ;"
+ }
+ { "So " { $link curry } ", " { $link compose } " are library features" }
+ }
+ { $slide "Why stack-based?"
+ "Because nobody else is doing it"
+ "Interesting properties: concatenation is composition, chaining functions together, \"fluent\" interfaces, new combinators"
+ { $vocab-link "smtp-example" }
+ { $code
+ "{ \"chicken\" \"beef\" \"pork\" \"turkey\" }"
+ "[ 5 short head ] map ."
+ }
+ "To rattle people's cages"
+ }
+ { $slide "Help system"
+ "Help markup is just literal data"
+ { "Look at the help for " { $link T{ link f + } } }
+ "These slides are built with the help system and a custom style sheet"
+ { $vocab-link "vpri-talk" }
+ }
+ { $slide "Some line counts"
+ "VM: 12,000 lines of C"
+ "core: 9,000 lines of Factor"
+ "basis: 80,000 lines of Factor"
+ }
+ { $slide "More line counts"
+ "Object system (core): 2184 lines"
+ "Dynamic variables (core): 40 lines"
+ "Deterministic scoped destructors (core): 56 lines"
+ "Optimizing compiler (basis): 12938 lines"
+ "Lexical variables and closures (basis): 477 lines"
+ "Fry (basis): 51 lines"
+ "Help system (basis): 1831 lines"
+ }
+ { $slide "Implementation"
+ "VM: garbage collection, bignums, ..."
+ "Bootstrap image: parser, hashtables, object system, ..."
+ "Non-optimizing compiler"
+ "Stage 2 bootstrap: optimizing compiler, UI, ..."
+ "Full image contains machine code"
+ }
+ { $slide "Compiler"
+ { "Let's look at " { $vocab-link "benchmark.mandel" } }
+ "A naive implementation would be very slow"
+ "Combinators, currying, partial application"
+ "Boxed complex numbers"
+ "Boxed floats"
+ { "Redundancy in " { $link absq } " and " { $link sq } }
+ }
+ { $slide "Compiler: front-end"
+ "Builds high-level tree SSA IR"
+ "Stack code with uniquely-named values"
+ "Inlines combinators and calls to quotations"
+ { $code "USING: compiler.tree.builder compiler.tree.debugger ;" "[ c pixel ] build-tree nodes>quot ." }
+ }
+ { $slide "Compiler: high-level optimizer"
+ "12 optimization passes"
+ { $link optimize-tree }
+ "Some passes collect information, others use the results of past analysis to rewrite the code"
+ }
+ { $slide "Compiler: propagation pass"
+ "Propagation pass computes types with type function"
+ { "Example: output type of " { $link + } " depends on the types of inputs" }
+ "Type: can be a class, a numeric interval, array with a certain length, tuple with certain type slots, literal value, ..."
+ "Mandelbrot: we infer that we're working on complex floats"
+ }
+ { $slide "Compiler: propagation pass"
+ "Propagation also supports \"constraints\""
+ { $code "[ dup array? [ first ] when ] optimized." }
+ { $code "[ >fixnum dup 0 < [ 1 + ] when ] optimized." }
+ { $code
+ "["
+ " >fixnum"
+ " dup [ -10 > ] [ 10 < ] bi and"
+ " [ 1 + ] when"
+ "] optimized."
+ }
+ }
+ { $slide "Compiler: propagation pass"
+ "Eliminates method dispatch, inlines method bodies"
+ "Mandelbrot: we infer that integer indices are fixnums"
+ "Mandelbrot: we eliminate generic arithmetic"
+ }
+ { $slide "Compiler: escape analysis"
+ "We identify allocations for tuples which are never returned or passed to other words (except slot access)"
+ { "Partial application with " { $link curry } " and " { $link compose } }
+ "Complex numbers"
+ }
+ { $slide "Compiler: escape analysis"
+ { "Virtual sequences: " { $link <slice> } ", " { $link <reversed> } }
+ { $code "[ <reversed> [ . ] each ] optimized." }
+ { "Mandelbrot: we unbox " { $link curry } ", complex number allocations" }
+ }
+ { $slide "Compiler: dead code elimination"
+ "Cleans up the mess from previous optimizations"
+ "After inlining and dispatch elimination, dead code comes up because of unused generality"
+ { "No-ops like " { $snippet "0 +" } ", " { $snippet "1 *" } }
+ "Literals which are never used"
+ "Side-effect-free words whose outputs are dropped"
+ { $code "[ c pixel ] optimized." }
+ }
+ { $slide "Compiler: low level IR"
+ "Register-based SSA"
+ "Stack operations expand into low-level instructions"
+ { $code "[ 5 ] test-mr mr." }
+ { $code "[ swap ] test-mr mr." }
+ { $code "[ append reverse ] test-mr mr." }
+ }
+ { $slide "Compiler: low-level optimizer"
+ "5 optimization passes"
+ { $link optimize-cfg }
+ "Gets rid of redundancy which is hidden in high-level stack code"
+ }
+ { $slide "Compiler: optimize memory"
+ "First pass optimizes stack and memory operations"
+ { "Example: " { $link 2array } }
+ { { $link <array> } " fills array with initial value" }
+ "What if we immediately store new values into the array?"
+ { $code "\\ 2array test-mr mr." }
+ "Mandelbrot: we optimize stack operations"
+ }
+ { $slide "Compiler: value numbering"
+ "Identifies expressions which are computed more than once in a basic block"
+ "Simplifies expressions with various identities"
+ "Mandelbrot: redundant float boxing and unboxing, redundant arithmetic"
+ }
+ { $slide "Compiler: dead code elimination"
+ "Dead code elimination for low-level IR"
+ "Again, cleans up results of prior optimizations"
+ }
+ { $slide "Compiler: register allocation"
+ "IR assumes an infinite number of registers which are only assigned once"
+ "Real CPUs have a finite set of registers which can be assigned any number of times"
+ "\"Linear scan register allocation with second-chance binpacking\""
+ }
+ { $slide "Compiler: register allocation"
+ "3 steps:"
+ "Compute live intervals"
+ "Allocate registers"
+ "Assign registers and insert spills"
+ }
+ { $slide "Compiler: register allocation"
+ "Step 1: compute live intervals"
+ "We number all instructions consecutively"
+ "A live interval associates a virtual register with a list of usages"
+ }
+ { $slide "Compiler: register allocation"
+ "Step 2: allocate registers"
+ "We scan through sorted live intervals"
+ "If a physical register is available, assign"
+ "Otherwise, find live interval with furthest away use, split it, look at both parts again"
+ }
+ { $slide "Compiler: register allocation"
+ "Step 3: assign registers and insert spills"
+ "Simple IR rewrite step"
+ "After register allocation, one vreg may have several live intervals, and different physical registers at different points in time"
+ "Hence, \"second chance\""
+ { "Mandelbrot: " { $code "[ c pixel ] test-mr mr." } }
+ }
+ { $slide "Compiler: code generation"
+ "Iterate over list of instructions"
+ "Extract tuple slots and call hooks"
+ { $vocab-link "cpu.architecture" }
+ "Finally, we hand the code to the VM"
+ { $code "\\ 2array disassemble" }
+ }
+ { $slide "Garbage collection"
+ "All roots are identified precisely"
+ "Generational copying for data"
+ "Mark sweep for native code"
+ }
+ { $slide "History"
+ "Started in 2003, implemented in Java"
+ "Scripting language for a 2D shooter game"
+ "Interactive development is addictive"
+ "I wanted to write entire applications in Factor"
+ "Added JVM bytecode compiler pretty early on"
+ }
+ { $slide "History"
+ "Wrote native C implementation, mid-2004"
+ "Added native compiler at some point"
+ "Added an FFI, SDL bindings, then UI"
+ "Switched UI to OpenGL and native APIs"
+ "Generational GC"
+ "Got rid of interpreter"
+ }
+ { $slide "Project infrastructure"
+ { $url "http://factorcode.org" }
+ { $url "http://concatenative.org" }
+ { $url "http://docs.factorcode.org" }
+ { $url "http://planet.factorcode.org" }
+ "Uses our HTTP server, SSL, DB, Atom libraries..."
+ }
+ { $slide "Project infrastructure"
+ "Build farm, written in Factor"
+ "12 platforms"
+ "Builds Factor and all libraries, runs tests, makes binaries"
+ "Saves us from the burden of making releases by hand"
+ "Maintains stability"
+ }
+ { $slide "Community"
+ "#concatenative irc.freenode.net: 50-60 members"
+ "factor-talk@lists.sf.net: 180 subscribers"
+ "About 30 people have code in the Factor repository"
+ "Easy to get started: binaries, lots of docs, friendly community..."
+ }
+ { $slide "Future direction: Factor 1.0"
+ "Continue doing what we're doing:"
+ "Polish off some language features"
+ "Stability"
+ "Performance"
+ "Documentation"
+ "Developer tools"
+ }
+ { $slide "Future direction: Factor 2.0"
+ "Native threads"
+ "Syntax-aware Factor editor"
+ "Embedding Factor in C apps"
+ "Cross-compilation for smaller devices"
+ }
+ { $slide "Research areas"
+ "Identify areas where stack languages are lacking, and try to find idioms, abstractions or DSLs to solve these problems"
+ "Factor is a good platform for DSLs (fry, locals, EBNF, help, ...); what about implementing a complete language on top?"
+ "Static typing, soft typing, for stack-based languages"
+ }
+ { $slide "That's all, folks"
+ "It is hard to cover everything in a single talk"
+ "Factor has many cool things that I didn't talk about"
+ "Questions?"
+ }
+} ;
+
+: vpri-talk ( -- ) vpri-slides slides-window ;
+
+MAIN: vpri-talk
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors furnace.actions http.server.dispatchers
-html.forms io.servers.connection namespaces prettyprint ;
+USING: accessors furnace.actions http.server
+http.server.dispatchers html.forms io.servers.connection
+namespaces prettyprint ;
IN: webapps.ip
TUPLE: ip-app < dispatcher ;
: <ip-app> ( -- dispatcher )
ip-app new-dispatcher
<display-ip-action> "" add-responder ;
+
+: run-ip-app ( -- )
+ <ip-app> main-responder set-global
+ 8080 httpd ;
+
+MAIN: run-ip-app
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-ui? f }
+ { deploy-compiler? t }
+ { deploy-c-types? f }
+ { deploy-reflection 1 }
+ { deploy-name "WebKit demo" }
+ { deploy-io 1 }
+ { deploy-math? f }
+ { deploy-word-props? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-defs? f }
+ { deploy-threads? f }
+}
--- /dev/null
+A simple example showing usage of the Cocoa WebKit framework from Factor
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel
+cocoa
+cocoa.application
+cocoa.types
+cocoa.classes
+cocoa.windows ;
+IN: webkit-demo
+
+FRAMEWORK: /System/Library/Frameworks/WebKit.framework
+IMPORT: WebView
+
+: rect ( -- rect ) 0 0 700 500 <NSRect> ;
+
+: <WebView> ( -- id )
+ WebView -> alloc
+ rect f f -> initWithFrame:frameName:groupName: ;
+
+: <WebWindow> ( -- id )
+ <WebView> rect <ViewWindow> ;
+
+: load-url ( window url -- )
+ [ -> contentView ] [ <NSString> ] bi* -> setMainFrameURL: ;
+
+: webkit-demo ( -- )
+ <WebWindow>
+ [ -> center ]
+ [ f -> makeKeyAndOrderFront: ]
+ [ "http://factorcode.org" load-url ] tri ;
+
+: run-webkit-demo ( -- )
+ [ webkit-demo ] cocoa-app ;
+
+MAIN: run-webkit-demo
+++ /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 cpu.architecture ;
-IN: compiler.alien
-
-: large-struct? ( ctype -- ? )
- dup c-struct? [ 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 ;
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs arrays generic kernel kernel.private
-math memory namespaces make sequences layouts system hashtables
-classes alien byte-arrays combinators words ;
-IN: compiler.backend
-
-! Labels
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-: define-label ( name -- ) <label> swap set ;
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
-! Mapping from register class to machine registers
-HOOK: machine-registers cpu ( -- assoc )
-
-! A pseudo-register class for parameters spilled on the stack
-SINGLETON: stack-params
-
-! Return values of this class go here
-GENERIC: return-reg ( register-class -- reg )
-
-! Sequence of registers used for parameter passing in class
-GENERIC: param-regs ( register-class -- regs )
-
-GENERIC: param-reg ( n register-class -- reg )
-
-M: object param-reg param-regs nth ;
-
-! Load a literal (immediate or indirect)
-GENERIC# load-literal 1 ( obj reg -- )
-
-HOOK: load-indirect cpu ( obj reg -- )
-
-HOOK: stack-frame-size cpu ( frame-size -- n )
-
-! Set up caller stack frame
-HOOK: %prologue cpu ( n -- )
-
-! Tear down stack frame
-HOOK: %epilogue cpu ( n -- )
-
-! Call another word
-HOOK: %call cpu ( word -- )
-
-! Local jump for branches
-HOOK: %jump-label cpu ( label -- )
-
-! Test if vreg is 'f' or not
-HOOK: %jump-f cpu ( label reg -- )
-
-! Test if vreg is 't' or not
-HOOK: %jump-t cpu ( label reg -- )
-
-HOOK: %dispatch cpu ( -- )
-
-HOOK: %dispatch-label cpu ( word -- )
-
-! Return to caller
-HOOK: %return cpu ( -- )
-
-! Change datastack height
-HOOK: %inc-d cpu ( n -- )
-
-! Change callstack height
-HOOK: %inc-r cpu ( n -- )
-
-! Load stack into vreg
-HOOK: %peek cpu ( reg loc -- )
-
-! Store vreg to stack
-HOOK: %replace cpu ( reg loc -- )
-
-! Copy values between vregs
-HOOK: %copy cpu ( dst src -- )
-HOOK: %copy-float cpu ( dst src -- )
-
-! Box and unbox floats
-HOOK: %unbox-float cpu ( dst src -- )
-HOOK: %box-float cpu ( dst src -- )
-
-! FFI stuff
-
-! Is this integer small enough to appear in value template
-! slots?
-HOOK: small-enough? cpu ( n -- ? )
-
-! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? cpu ( heap-size -- ? )
-
-! Do we pass explode value structs?
-HOOK: value-structs? cpu ( -- ? )
-
-! If t, fp parameters are shadowed by dummy int parameters
-HOOK: fp-shadows-int? cpu ( -- ? )
-
-HOOK: %prepare-unbox cpu ( -- )
-
-HOOK: %unbox cpu ( n reg-class func -- )
-
-HOOK: %unbox-long-long cpu ( n func -- )
-
-HOOK: %unbox-small-struct cpu ( c-type -- )
-
-HOOK: %unbox-large-struct cpu ( n c-type -- )
-
-HOOK: %box cpu ( n reg-class func -- )
-
-HOOK: %box-long-long cpu ( n func -- )
-
-HOOK: %prepare-box-struct cpu ( size -- )
-
-HOOK: %box-small-struct cpu ( c-type -- )
-
-HOOK: %box-large-struct cpu ( n c-type -- )
-
-GENERIC: %save-param-reg ( stack reg reg-class -- )
-
-GENERIC: %load-param-reg ( stack reg reg-class -- )
-
-HOOK: %prepare-alien-invoke cpu ( -- )
-
-HOOK: %prepare-var-args cpu ( -- )
-
-M: object %prepare-var-args ;
-
-HOOK: %alien-invoke cpu ( function library -- )
-
-HOOK: %cleanup cpu ( alien-node -- )
-
-HOOK: %alien-callback cpu ( quot -- )
-
-HOOK: %callback-value cpu ( ctype -- )
-
-! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind cpu ( n -- )
-
-HOOK: %prepare-alien-indirect cpu ( -- )
-
-HOOK: %alien-indirect cpu ( -- )
-
-M: stack-params param-reg drop ;
-
-M: stack-params param-regs drop f ;
-
-M: object load-literal load-indirect ;
-
-PREDICATE: small-slot < integer cells small-enough? ;
-
-PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
-
-: if-small-struct ( n size true false -- ? )
- [ over not over struct-small-enough? and ] 2dip
- [ [ nip ] prepose ] dip if ;
- inline
-
-: %unbox-struct ( n c-type -- )
- [
- %unbox-small-struct
- ] [
- %unbox-large-struct
- ] if-small-struct ;
-
-: %box-struct ( n c-type -- )
- [
- %box-small-struct
- ] [
- %box-large-struct
- ] if-small-struct ;
-
-! Alien accessors
-HOOK: %unbox-byte-array cpu ( dst src -- )
-
-HOOK: %unbox-alien cpu ( dst src -- )
-
-HOOK: %unbox-f cpu ( dst src -- )
-
-HOOK: %unbox-any-c-ptr cpu ( dst src -- )
-
-HOOK: %box-alien cpu ( dst src -- )
-
-! Allocation
-HOOK: %allot cpu ( dst size type tag temp -- )
-
-HOOK: %write-barrier cpu ( src temp -- )
-
-! GC check
-HOOK: %gc cpu ( -- )
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays kernel kernel.private math
-namespaces sequences stack-checker.known-words system layouts
-combinators command-line io vocabs.loader accessors init
-compiler compiler.units compiler.constants compiler.codegen
-compiler.cfg.builder compiler.alien compiler.codegen.fixup
-cpu.x86 compiler.backend compiler.backend.x86 ;
-IN: compiler.backend.x86.32
-
-! We implement the FFI for Linux, OS X and Windows all at once.
-! OS X requires that the stack be 16-byte aligned, and we do
-! this on all platforms, sacrificing some stack space for
-! code simplicity.
-
-M: x86.32 machine-registers
- {
- { int-regs { EAX ECX EDX EBP EBX } }
- { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
- } ;
-
-M: x86.32 ds-reg ESI ;
-M: x86.32 rs-reg EDI ;
-M: x86.32 stack-reg ESP ;
-M: x86.32 stack-save-reg EDX ;
-M: x86.32 temp-reg-1 EAX ;
-M: x86.32 temp-reg-2 ECX ;
-
-M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
-
-M: x86.32 %alien-invoke (CALL) rel-dlsym ;
-
-M: x86.32 struct-small-enough? ( size -- ? )
- heap-size { 1 2 4 8 } member?
- os { linux netbsd solaris } member? not and ;
-
-! On x86, parameters are never passed in registers.
-M: int-regs return-reg drop EAX ;
-M: int-regs param-regs drop { } ;
-M: int-regs push-return-reg return-reg PUSH ;
-: load/store-int-return ( n reg-class -- src dst )
- return-reg stack-reg rot [+] ;
-M: int-regs load-return-reg load/store-int-return MOV ;
-M: int-regs store-return-reg load/store-int-return swap MOV ;
-
-M: float-regs param-regs drop { } ;
-
-: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
-
-M: float-regs push-return-reg
- stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
-
-: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
-
-: load/store-float-return ( n reg-class -- op size )
- [ stack@ ] [ reg-size ] bi* ;
-M: float-regs load-return-reg load/store-float-return FLD ;
-M: float-regs store-return-reg load/store-float-return FSTP ;
-
-: align-sub ( n -- )
- dup 16 align swap - ESP swap SUB ;
-
-: align-add ( n -- )
- 16 align ESP swap ADD ;
-
-: with-aligned-stack ( n quot -- )
- swap dup align-sub slip align-add ; inline
-
-M: x86.32 fixnum>slot@ 1 SHR ;
-
-M: x86.32 prepare-division CDQ ;
-
-M: x86.32 load-indirect
- 0 [] MOV rc-absolute-cell rel-literal ;
-
-M: object %load-param-reg 3drop ;
-
-M: object %save-param-reg 3drop ;
-
-: box@ ( n reg-class -- stack@ )
- #! Used for callbacks; we want to box the values given to
- #! us by the C function caller. Computes stack location of
- #! nth parameter; note that we must go back one more stack
- #! frame, since %box sets one up to call the one-arg boxer
- #! function. The size of this stack frame so far depends on
- #! the reg-class of the boxer's arg.
- reg-size neg + stack-frame* + 20 + ;
-
-: (%box) ( n reg-class -- )
- #! If n is f, push the return register onto the stack; we
- #! are boxing a return value of a C function. If n is an
- #! integer, push [ESP+n] on the stack; we are boxing a
- #! parameter being passed to a callback from C.
- over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
- push-return-reg ;
-
-M: x86.32 %box ( n reg-class func -- )
- over reg-size [
- >r (%box) r> f %alien-invoke
- ] with-aligned-stack ;
-
-: (%box-long-long) ( n -- )
- #! If n is f, push the return registers onto the stack; we
- #! are boxing a return value of a C function. If n is an
- #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
- #! boxing a parameter being passed to a callback from C.
- [
- int-regs box@
- EDX over stack@ MOV
- EAX swap cell - stack@ MOV
- ] when*
- EDX PUSH
- EAX PUSH ;
-
-M: x86.32 %box-long-long ( n func -- )
- 8 [
- [ (%box-long-long) ] [ f %alien-invoke ] bi*
- ] with-aligned-stack ;
-
-: struct-return@ ( size n -- n )
- [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
-
-M: x86.32 %box-large-struct ( n c-type -- )
- ! Compute destination address
- heap-size
- [ swap struct-return@ ] keep
- ECX ESP roll [+] LEA
- 8 [
- ! Push struct size
- PUSH
- ! Push destination address
- ECX PUSH
- ! Copy the struct from the C stack
- "box_value_struct" f %alien-invoke
- ] with-aligned-stack ;
-
-M: x86.32 %prepare-box-struct ( size -- )
- ! Compute target address for value struct return
- EAX ESP rot f struct-return@ [+] LEA
- ! Store it as the first parameter
- ESP [] EAX MOV ;
-
-M: x86.32 %box-small-struct ( c-type -- )
- #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
- 12 [
- heap-size PUSH
- EDX PUSH
- EAX PUSH
- "box_small_struct" f %alien-invoke
- ] with-aligned-stack ;
-
-M: x86.32 %prepare-unbox ( -- )
- #! Move top of data stack to EAX.
- EAX ESI [] MOV
- ESI 4 SUB ;
-
-: (%unbox) ( func -- )
- 4 [
- ! Push parameter
- EAX PUSH
- ! Call the unboxer
- f %alien-invoke
- ] with-aligned-stack ;
-
-M: x86.32 %unbox ( n reg-class func -- )
- #! The value being unboxed must already be in EAX.
- #! If n is f, we're unboxing a return value about to be
- #! returned by the callback. Otherwise, we're unboxing
- #! a parameter to a C function about to be called.
- (%unbox)
- ! Store the return value on the C stack
- over [ store-return-reg ] [ 2drop ] if ;
-
-M: x86.32 %unbox-long-long ( n func -- )
- (%unbox)
- ! Store the return value on the C stack
- [
- dup stack@ EAX MOV
- cell + stack@ EDX MOV
- ] when* ;
-
-: %unbox-struct-1 ( -- )
- #! Alien must be in EAX.
- 4 [
- EAX PUSH
- "alien_offset" f %alien-invoke
- ! Load first cell
- EAX EAX [] MOV
- ] with-aligned-stack ;
-
-: %unbox-struct-2 ( -- )
- #! Alien must be in EAX.
- 4 [
- EAX PUSH
- "alien_offset" f %alien-invoke
- ! Load second cell
- EDX EAX 4 [+] MOV
- ! Load first cell
- EAX EAX [] MOV
- ] with-aligned-stack ;
-
-M: x86 %unbox-small-struct ( size -- )
- #! Alien must be in EAX.
- heap-size cell align cell /i {
- { 1 [ %unbox-struct-1 ] }
- { 2 [ %unbox-struct-2 ] }
- } case ;
-
-M: x86.32 %unbox-large-struct ( n c-type -- )
- #! Alien must be in EAX.
- heap-size
- ! Compute destination address
- ECX ESP roll [+] LEA
- 12 [
- ! Push struct size
- PUSH
- ! Push destination address
- ECX PUSH
- ! Push source address
- EAX PUSH
- ! Copy the struct to the stack
- "to_value_struct" f %alien-invoke
- ] with-aligned-stack ;
-
-M: x86.32 %prepare-alien-indirect ( -- )
- "unbox_alien" f %alien-invoke
- cell temp@ EAX MOV ;
-
-M: x86.32 %alien-indirect ( -- )
- cell temp@ CALL ;
-
-M: x86.32 %alien-callback ( quot -- )
- 4 [
- EAX load-indirect
- EAX PUSH
- "c_to_factor" f %alien-invoke
- ] with-aligned-stack ;
-
-M: x86.32 %callback-value ( ctype -- )
- ! Align C stack
- ESP 12 SUB
- ! Save top of data stack
- %prepare-unbox
- EAX PUSH
- ! Restore data/call/retain stacks
- "unnest_stacks" f %alien-invoke
- ! Place top of data stack in EAX
- EAX POP
- ! Restore C stack
- ESP 12 ADD
- ! Unbox EAX
- unbox-return ;
-
-M: x86.32 %cleanup ( alien-node -- )
- #! a) If we just called an stdcall function in Windows, it
- #! cleaned up the stack frame for us. But we don't want that
- #! so we 'undo' the cleanup since we do that in %epilogue.
- #! b) If we just called a function returning a struct, we
- #! have to fix ESP.
- {
- {
- [ dup abi>> "stdcall" = ]
- [ alien-stack-frame ESP swap SUB ]
- } {
- [ dup return>> large-struct? ]
- [ drop EAX PUSH ]
- }
- [ drop ]
- } cond ;
-
-M: x86.32 %unwind ( n -- ) RET ;
-
-os windows? [
- cell "longlong" c-type (>>align)
- cell "ulonglong" c-type (>>align)
- 4 "double" c-type (>>align)
-] unless
-
-: (sse2?) ( -- ? ) "Intrinsic" throw ;
-
-<<
-
-\ (sse2?) [
- { EAX EBX ECX EDX } [ PUSH ] each
- EAX 1 MOV
- CPUID
- EDX 26 SHR
- EDX 1 AND
- { EAX EBX ECX EDX } [ POP ] each
- JE
-] { } define-if-intrinsic
-
-\ (sse2?) { } { object } define-primitive
-
->>
-
-: sse2? ( -- ? ) (sse2?) ;
-
-"-no-sse2" cli-args member? [
- "Checking if your CPU supports SSE2..." print flush
- [ optimized-recompile-hook ] recompile-hook [
- [ sse2? ] compile-call
- ] with-variable
- [
- " - yes" print
- "compiler.backend.x86.sse2" require
- [
- sse2? [
- "This image was built to use SSE2, which your CPU does not support." print
- "You will need to bootstrap Factor again." print
- flush
- 1 exit
- ] unless
- ] "compiler.backend.x86" add-init-hook
- ] [
- " - no" print
- ] if
-] unless
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays kernel kernel.private math
-namespaces make sequences system layouts alien alien.accessors
-alien.structs slots splitting assocs combinators
-cpu.x86 compiler.codegen compiler.constants
-compiler.codegen.fixup compiler.cfg.registers compiler.backend
-compiler.backend.x86 compiler.backend.x86.sse2 ;
-IN: compiler.backend.x86.64
-
-M: x86.64 machine-registers
- {
- { int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
- { double-float-regs {
- XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
- XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
- } }
- } ;
-
-M: x86.64 ds-reg R14 ;
-M: x86.64 rs-reg R15 ;
-M: x86.64 stack-reg RSP ;
-M: x86.64 stack-save-reg RSI ;
-M: x86.64 temp-reg-1 RAX ;
-M: x86.64 temp-reg-2 RCX ;
-
-M: int-regs return-reg drop RAX ;
-M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
-
-M: float-regs return-reg drop XMM0 ;
-
-M: float-regs param-regs
- drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-
-M: x86.64 fixnum>slot@ drop ;
-
-M: x86.64 prepare-division CQO ;
-
-M: x86.64 load-indirect ( literal reg -- )
- 0 [] MOV rc-relative rel-literal ;
-
-M: stack-params %load-param-reg
- drop
- >r R11 swap stack@ MOV
- r> stack@ R11 MOV ;
-
-M: stack-params %save-param-reg
- >r stack-frame* + cell + swap r> %load-param-reg ;
-
-: with-return-regs ( quot -- )
- [
- V{ RDX RAX } clone int-regs set
- V{ XMM1 XMM0 } clone float-regs set
- call
- ] with-scope ; inline
-
-! The ABI for passing structs by value is pretty messed up
-<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>reg-class) >>
-
-: struct-types&offset ( struct-type -- pairs )
- fields>> [
- [ type>> ] [ offset>> ] bi 2array
- ] map ;
-
-: split-struct ( pairs -- seq )
- [
- [ 8 mod zero? [ t , ] when , ] assoc-each
- ] { } make { t } split harvest ;
-
-: flatten-small-struct ( c-type -- seq )
- struct-types&offset split-struct [
- [ c-type c-type-reg-class ] map
- int-regs swap member? "void*" "double" ? c-type
- ] map ;
-
-: flatten-large-struct ( c-type -- seq )
- heap-size cell align
- cell /i "__stack_value" c-type <repetition> ;
-
-M: struct-type flatten-value-type ( type -- seq )
- dup heap-size 16 > [
- flatten-large-struct
- ] [
- flatten-small-struct
- ] if ;
-
-M: x86.64 %prepare-unbox ( -- )
- ! First parameter is top of stack
- RDI R14 [] MOV
- R14 cell SUB ;
-
-M: x86.64 %unbox ( n reg-class func -- )
- ! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-
-M: x86.64 %unbox-long-long ( n func -- )
- int-regs swap %unbox ;
-
-: %unbox-struct-field ( c-type i -- )
- ! Alien must be in RDI.
- RDI swap cells [+] swap reg-class>> {
- { int-regs [ int-regs get pop swap MOV ] }
- { double-float-regs [ float-regs get pop swap MOVSD ] }
- } case ;
-
-M: x86.64 %unbox-small-struct ( c-type -- )
- ! Alien must be in RDI.
- "alien_offset" f %alien-invoke
- ! Move alien_offset() return value to RDI so that we don't
- ! clobber it.
- RDI RAX MOV
- [
- flatten-small-struct [ %unbox-struct-field ] each-index
- ] with-return-regs ;
-
-M: x86.64 %unbox-large-struct ( n c-type -- )
- ! Source is in RDI
- heap-size
- ! Load destination address
- RSI RSP roll [+] LEA
- ! Load structure size
- RDX swap MOV
- ! Copy the struct to the C stack
- "to_value_struct" f %alien-invoke ;
-
-: load-return-value ( reg-class -- )
- 0 over param-reg swap return-reg
- 2dup eq? [ 2drop ] [ MOV ] if ;
-
-M: x86.64 %box ( n reg-class func -- )
- rot [
- rot [ 0 swap param-reg ] keep %load-param-reg
- ] [
- swap load-return-value
- ] if*
- f %alien-invoke ;
-
-M: x86.64 %box-long-long ( n func -- )
- int-regs swap %box ;
-
-M: x86.64 struct-small-enough? ( size -- ? )
- heap-size 2 cells <= ;
-
-: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
-
-: %box-struct-field ( c-type i -- )
- box-struct-field@ swap reg-class>> {
- { int-regs [ int-regs get pop MOV ] }
- { double-float-regs [ float-regs get pop MOVSD ] }
- } case ;
-
-M: x86.64 %box-small-struct ( c-type -- )
- #! Box a <= 16-byte struct.
- [
- [ flatten-small-struct [ %box-struct-field ] each-index ]
- [ RDX swap heap-size MOV ] bi
- RDI 0 box-struct-field@ MOV
- RSI 1 box-struct-field@ MOV
- "box_small_struct" f %alien-invoke
- ] with-return-regs ;
-
-: struct-return@ ( size n -- n )
- [ ] [ \ stack-frame get swap - ] ?if ;
-
-M: x86.64 %box-large-struct ( n c-type -- )
- ! Struct size is parameter 2
- heap-size
- RSI over MOV
- ! Compute destination address
- swap struct-return@ RDI RSP rot [+] LEA
- ! Copy the struct from the C stack
- "box_value_struct" f %alien-invoke ;
-
-M: x86.64 %prepare-box-struct ( size -- )
- ! Compute target address for value struct return
- RAX RSP rot f struct-return@ [+] LEA
- RSP 0 [+] RAX MOV ;
-
-M: x86.64 %prepare-var-args RAX RAX XOR ;
-
-M: x86.64 %alien-global
- [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
-
-M: x86.64 %alien-invoke
- R11 0 MOV
- rc-absolute-cell rel-dlsym
- R11 CALL ;
-
-M: x86.64 %prepare-alien-indirect ( -- )
- "unbox_alien" f %alien-invoke
- cell temp@ RAX MOV ;
-
-M: x86.64 %alien-indirect ( -- )
- cell temp@ CALL ;
-
-M: x86.64 %alien-callback ( quot -- )
- RDI load-indirect "c_to_factor" f %alien-invoke ;
-
-M: x86.64 %callback-value ( ctype -- )
- ! Save top of data stack
- %prepare-unbox
- ! Put former top of data stack in RDI
- cell temp@ RDI MOV
- ! Restore data/call/retain stacks
- "unnest_stacks" f %alien-invoke
- ! Put former top of data stack in RDI
- RDI cell temp@ MOV
- ! Unbox former top of data stack to return registers
- unbox-return ;
-
-M: x86.64 %cleanup ( alien-node -- ) drop ;
-
-M: x86.64 %unwind ( n -- ) drop 0 RET ;
-
-USE: cpu.x86.intrinsics
-
-! On 64-bit systems, the result of reading 4 bytes from memory
-! is a fixnum.
-\ alien-unsigned-4 small-reg-32 define-unsigned-getter
-\ set-alien-unsigned-4 small-reg-32 define-setter
-
-\ alien-signed-4 small-reg-32 define-signed-getter
-\ set-alien-signed-4 small-reg-32 define-setter
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays generic kernel system
-kernel.private math math.private memory namespaces sequences
-words math.floats.private layouts quotations locals cpu.x86
-compiler.codegen compiler.cfg.templates compiler.cfg.builder
-compiler.cfg.registers compiler.constants compiler.backend
-compiler.backend.x86 ;
-IN: compiler.backend.x86.sse2
-
-M:: x86 %box-float ( dst src temp -- )
- #! Only called by pentium4 backend, uses SSE2 instruction
- dst 16 float float temp %allot
- dst 8 float tag-number - [+] src MOVSD ;
-
-M: x86 %unbox-float ( dst src -- )
- float-offset [+] MOVSD ;
-
-: define-float-op ( word op -- )
- [ "x" operand "y" operand ] swap suffix T{ template
- { input { { float "x" } { float "y" } } }
- { output { "x" } }
- } define-intrinsic ;
-
-{
- { float+ ADDSD }
- { float- SUBSD }
- { float* MULSD }
- { float/f DIVSD }
-} [
- first2 define-float-op
-] each
-
-: define-float-jump ( word op -- )
- [ "x" operand "y" operand UCOMISD ] swap suffix
- { { float "x" } { float "y" } } define-if-intrinsic ;
-
-{
- { float< JAE }
- { float<= JA }
- { float> JBE }
- { float>= JB }
- { float= JNE }
-} [
- first2 define-float-jump
-] each
-
-\ float>fixnum [
- "out" operand "in" operand CVTTSD2SI
- "out" operand tag-bits get SHL
-] T{ template
- { input { { float "in" } } }
- { scratch { { f "out" } } }
- { output { "out" } }
-} define-intrinsic
-
-\ fixnum>float [
- "in" operand %untag-fixnum
- "out" operand "in" operand CVTSI2SD
-] T{ template
- { input { { f "in" } } }
- { scratch { { float "out" } } }
- { output { "out" } }
- { clobber { "in" } }
-} define-intrinsic
-
-: alien-float-get-template
- T{ template
- { input {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { scratch { { float "value" } } }
- { output { "value" } }
- { clobber { "offset" } }
- } ;
-
-: alien-float-set-template
- T{ template
- { input {
- { float "value" float }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { clobber { "offset" } }
- } ;
-
-: define-alien-float-intrinsics ( word get-quot word set-quot -- )
- [ "value" operand swap %alien-accessor ] curry
- alien-float-set-template
- define-intrinsic
- [ "value" operand swap %alien-accessor ] curry
- alien-float-get-template
- define-intrinsic ;
-
-\ alien-double
-[ MOVSD ]
-\ set-alien-double
-[ swap MOVSD ]
-define-alien-float-intrinsics
-
-\ alien-float
-[ dupd MOVSS dup CVTSS2SD ]
-\ set-alien-float
-[ swap dup dup CVTSD2SS MOVSS ]
-define-alien-float-intrinsics
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays alien.accessors
-compiler.backend kernel kernel.private math memory namespaces
-make sequences words system layouts combinators math.order
-math.private alien alien.c-types slots.private cpu.x86
-cpu.x86.private locals compiler.backend compiler.codegen.fixup
-compiler.constants compiler.intrinsics compiler.cfg.builder
-compiler.cfg.registers compiler.cfg.stacks
-compiler.cfg.templates compiler.codegen ;
-IN: compiler.backend.x86
-
-HOOK: ds-reg cpu ( -- reg )
-HOOK: rs-reg cpu ( -- reg )
-HOOK: stack-reg cpu ( -- reg )
-HOOK: stack-save-reg cpu ( -- reg )
-
-: stack@ ( n -- op ) stack-reg swap [+] ;
-
-: reg-stack ( n reg -- op ) swap cells neg [+] ;
-
-GENERIC: loc>operand ( loc -- operand )
-
-M: ds-loc loc>operand n>> ds-reg reg-stack ;
-M: rs-loc loc>operand n>> rs-reg reg-stack ;
-
-M: int-regs %save-param-reg drop >r stack@ r> MOV ;
-M: int-regs %load-param-reg drop swap stack@ MOV ;
-
-GENERIC: MOVSS/D ( dst src reg-class -- )
-
-M: single-float-regs MOVSS/D drop MOVSS ;
-M: double-float-regs MOVSS/D drop MOVSD ;
-
-M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
-M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
-
-GENERIC: push-return-reg ( reg-class -- )
-GENERIC: load-return-reg ( stack@ reg-class -- )
-GENERIC: store-return-reg ( stack@ reg-class -- )
-
-! Only used by inline allocation
-HOOK: temp-reg-1 cpu ( -- reg )
-HOOK: temp-reg-2 cpu ( -- reg )
-
-HOOK: fixnum>slot@ cpu ( op -- )
-
-HOOK: prepare-division cpu ( -- )
-
-M: f load-literal
- \ f tag-number MOV drop ;
-
-M: fixnum load-literal
- swap tag-fixnum MOV ;
-
-M: x86 stack-frame ( n -- i )
- 3 cells + 16 align cell - ;
-
-: factor-area-size ( -- n ) 4 cells ;
-
-M: x86 %prologue ( n -- )
- temp-reg-1 0 MOV rc-absolute-cell rel-this
- dup cell + PUSH
- temp-reg-1 PUSH
- stack-reg swap 2 cells - SUB ;
-
-M: x86 %epilogue ( n -- )
- stack-reg swap ADD ;
-
-HOOK: %alien-global cpu ( symbol dll register -- )
-
-M: x86 %prepare-alien-invoke
- #! Save Factor stack pointers in case the C code calls a
- #! callback which does a GC, which must reliably trace
- #! all roots.
- "stack_chain" f temp-reg-1 %alien-global
- temp-reg-1 [] stack-reg MOV
- temp-reg-1 [] cell SUB
- temp-reg-1 2 cells [+] ds-reg MOV
- temp-reg-1 3 cells [+] rs-reg MOV ;
-
-M: x86 %call ( label -- ) CALL ;
-
-M: x86 %jump-label ( label -- ) JMP ;
-
-M: x86 %jump-f ( label vreg -- ) \ f tag-number CMP JE ;
-
-M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
-
-: code-alignment ( -- n )
- building get length dup cell align swap - ;
-
-: align-code ( n -- )
- 0 <repetition> % ;
-
-M:: x86 %dispatch ( src temp -- )
- ! Load jump table base. We use a temporary register
- ! since on AMD64 we have to load a 64-bit immediate. On
- ! x86, this is redundant.
- ! Untag and multiply to get a jump table offset
- src fixnum>slot@
- ! Add jump table base
- temp HEX: ffffffff MOV rc-absolute-cell rel-here
- src temp ADD
- src HEX: 7f [+] JMP
- ! Fix up the displacement above
- code-alignment dup bootstrap-cell 8 = 15 9 ? +
- building get dup pop* push
- align-code ;
-
-M: x86 %dispatch-label ( word -- )
- 0 cell, rc-absolute-cell rel-word ;
-
-M: x86 %peek loc>operand MOV ;
-
-M: x86 %replace loc>operand swap MOV ;
-
-: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
-
-M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
-
-M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
-
-M: x86 fp-shadows-int? ( -- ? ) f ;
-
-M: x86 value-structs? t ;
-
-M: x86 small-enough? ( n -- ? )
- HEX: -80000000 HEX: 7fffffff between? ;
-
-: %untag ( reg -- ) tag-mask get bitnot AND ;
-
-: %untag-fixnum ( reg -- ) tag-bits get SAR ;
-
-: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-
-: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
-
-M: x86 %return ( -- ) 0 %unwind ;
-
-! Alien intrinsics
-M: x86 %unbox-byte-array ( dst src -- )
- byte-array-offset [+] LEA ;
-
-M: x86 %unbox-alien ( dst src -- )
- alien-offset [+] MOV ;
-
-M: x86 %unbox-f ( dst src -- )
- drop 0 MOV ;
-
-M: x86 %unbox-any-c-ptr ( dst src -- )
- { "is-byte-array" "end" "start" } [ define-label ] each
- ! Address is computed in ds-reg
- ds-reg PUSH
- ds-reg 0 MOV
- ! Object is stored in ds-reg
- rs-reg PUSH
- rs-reg swap MOV
- ! We come back here with displaced aliens
- "start" resolve-label
- ! Is the object f?
- rs-reg \ f tag-number CMP
- "end" get JE
- ! Is the object an alien?
- rs-reg header-offset [+] alien type-number tag-fixnum CMP
- "is-byte-array" get JNE
- ! If so, load the offset and add it to the address
- ds-reg rs-reg alien-offset [+] ADD
- ! Now recurse on the underlying alien
- rs-reg rs-reg underlying-alien-offset [+] MOV
- "start" get JMP
- "is-byte-array" resolve-label
- ! Add byte array address to address being computed
- ds-reg rs-reg ADD
- ! Add an offset to start of byte array's data
- ds-reg byte-array-offset ADD
- "end" resolve-label
- ! Done, store address in destination register
- ds-reg MOV
- ! Restore rs-reg
- rs-reg POP
- ! Restore ds-reg
- ds-reg POP ;
-
-M:: x86 %write-barrier ( src temp -- )
- #! Mark the card pointed to by vreg.
- ! Mark the card
- src card-bits SHR
- "cards_offset" f temp %alien-global
- temp temp [+] card-mark <byte> MOV
-
- ! Mark the card deck
- temp deck-bits card-bits - SHR
- "decks_offset" f temp %alien-global
- temp temp [+] card-mark <byte> MOV ;
-
-: load-zone-ptr ( reg -- )
- #! Load pointer to start of zone array
- 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
-
-: load-allot-ptr ( temp -- )
- [ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
-
-: inc-allot-ptr ( n temp -- )
- [ POP ] [ cell [+] swap 8 align ADD ] bi ;
-
-: store-header ( temp type -- )
- [ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
-
-: store-tagged ( dst temp tag -- )
- dupd tag-number OR MOV ;
-
-M:: x86 %allot ( dst size type tag temp -- )
- temp load-allot-ptr
- temp type store-header
- temp size inc-allot-ptr
- dst temp store-tagged ;
-
-M: x86 %gc ( -- )
- "end" define-label
- temp-reg-1 load-zone-ptr
- temp-reg-2 temp-reg-1 cell [+] MOV
- temp-reg-2 1024 ADD
- temp-reg-1 temp-reg-1 3 cells [+] MOV
- temp-reg-2 temp-reg-1 CMP
- "end" get JLE
- %prepare-alien-invoke
- "minor_gc" f %alien-invoke
- "end" resolve-label ;
-
-: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
-
-:: %allot-bignum-signed-1 ( dst src temp -- )
- #! on entry, inreg is a signed 32-bit quantity
- #! exits with tagged ptr to bignum in outreg
- #! 1 cell header, 1 cell length, 1 cell sign, + digits
- #! length is the # of digits + sign
- [
- { "end" "nonzero" "positive" "store" } [ define-label ] each
- src 0 CMP ! is it zero?
- "nonzero" get JNE
- ! Use cached zero value
- 0 >bignum dst load-indirect
- "end" get JMP
- "nonzero" resolve-label
- ! Allocate a bignum
- dst 4 cells bignum bignum temp %allot
- ! Write length
- dst 1 bignum@ 2 MOV
- ! Test sign
- src 0 CMP
- "positive" get JGE
- dst 2 bignum@ 1 MOV ! negative sign
- src NEG
- "store" get JMP
- "positive" resolve-label
- dst 2 bignum@ 0 MOV ! positive sign
- "store" resolve-label
- dst 3 bignum@ src MOV
- "end" resolve-label
- ] with-scope ;
-
-: alien@ ( reg n -- op ) cells object tag-number - [+] ;
-
-M:: x86 %box-alien ( dst src temp -- )
- [
- { "end" "f" } [ define-label ] each
- src 0 CMP
- "f" get JE
- dst 4 cells alien object temp %allot
- dst 1 alien@ \ f tag-number MOV
- dst 2 alien@ \ f tag-number MOV
- ! Store src in alien-offset slot
- dst 3 alien@ src MOV
- "end" get JMP
- "f" resolve-label
- \ f tag-number MOV
- "end" resolve-label
- ] with-scope ;
-
-! Type checks
-\ tag [
- "in" operand tag-mask get AND
- "in" operand %tag-fixnum
-] T{ template
- { input { { f "in" } } }
- { output { "in" } }
-} define-intrinsic
-
-! Slots
-: %slot-literal-known-tag ( -- op )
- "obj" operand
- "n" get cells
- "obj" operand-tag - [+] ;
-
-: %slot-literal-any-tag ( -- op )
- "obj" operand %untag
- "obj" operand "n" get cells [+] ;
-
-: %slot-any ( -- op )
- "obj" operand %untag
- "n" operand fixnum>slot@
- "obj" operand "n" operand [+] ;
-
-\ slot {
- ! Slot number is literal and the tag is known
- {
- [ "val" operand %slot-literal-known-tag MOV ] T{ template
- { input { { f "obj" known-tag } { small-slot "n" } } }
- { scratch { { f "val" } } }
- { output { "val" } }
- }
- }
- ! Slot number is literal
- {
- [ "obj" operand %slot-literal-any-tag MOV ] T{ template
- { input { { f "obj" } { small-slot "n" } } }
- { output { "obj" } }
- }
- }
- ! Slot number in a register
- {
- [ "obj" operand %slot-any MOV ] T{ template
- { input { { f "obj" } { f "n" } } }
- { output { "obj" } }
- { clobber { "n" } }
- }
- }
-} define-intrinsics
-
-\ (set-slot) {
- ! Slot number is literal and the tag is known
- {
- [ %slot-literal-known-tag "val" operand MOV ] T{ template
- { input { { f "val" } { f "obj" known-tag } { small-slot "n" } } }
- { scratch { { f "scratch" } } }
- { clobber { "obj" } }
- }
- }
- ! Slot number is literal
- {
- [ %slot-literal-any-tag "val" operand MOV ] T{ template
- { input { { f "val" } { f "obj" } { small-slot "n" } } }
- { scratch { { f "scratch" } } }
- { clobber { "obj" } }
- }
- }
- ! Slot number in a register
- {
- [ %slot-any "val" operand MOV ] T{ template
- { input { { f "val" } { f "obj" } { f "n" } } }
- { scratch { { f "scratch" } } }
- { clobber { "obj" "n" } }
- }
- }
-} define-intrinsics
-
-! Sometimes, we need to do stuff with operands which are
-! less than the word size. Instead of teaching the register
-! allocator about the different sized registers, with all
-! the complexity this entails, we just push/pop a register
-! which is guaranteed to be unused (the tempreg)
-: small-reg cell 8 = RBX EBX ? ; inline
-: small-reg-8 BL ; inline
-: small-reg-16 BX ; inline
-: small-reg-32 EBX ; inline
-
-! Fixnums
-: fixnum-op ( op hash -- pair )
- >r [ "x" operand "y" operand ] swap suffix r> 2array ;
-
-: fixnum-value-op ( op -- pair )
- T{ template
- { input { { f "x" } { small-tagged "y" } } }
- { output { "x" } }
- } fixnum-op ;
-
-: fixnum-register-op ( op -- pair )
- T{ template
- { input { { f "x" } { f "y" } } }
- { output { "x" } }
- } fixnum-op ;
-
-: define-fixnum-op ( word op -- )
- [ fixnum-value-op ] keep fixnum-register-op
- 2array define-intrinsics ;
-
-{
- { fixnum+fast ADD }
- { fixnum-fast SUB }
- { fixnum-bitand AND }
- { fixnum-bitor OR }
- { fixnum-bitxor XOR }
-} [
- first2 define-fixnum-op
-] each
-
-\ fixnum-bitnot [
- "x" operand NOT
- "x" operand tag-mask get XOR
-] T{ template
- { input { { f "x" } } }
- { output { "x" } }
-} define-intrinsic
-
-\ fixnum*fast {
- {
- [
- "x" operand "y" get IMUL2
- ] T{ template
- { input { { f "x" } { [ small-tagged? ] "y" } } }
- { output { "x" } }
- }
- } {
- [
- "out" operand "x" operand MOV
- "out" operand %untag-fixnum
- "y" operand "out" operand IMUL2
- ] T{ template
- { input { { f "x" } { f "y" } } }
- { scratch { { f "out" } } }
- { output { "out" } }
- }
- }
-} define-intrinsics
-
-: %untag-fixnums ( seq -- )
- [ %untag-fixnum ] unique-operands ;
-
-\ fixnum-shift-fast [
- "x" operand "y" get
- dup 0 < [ neg SAR ] [ SHL ] if
- ! Mask off low bits
- "x" operand %untag
-] T{ template
- { input { { f "x" } { [ ] "y" } } }
- { output { "x" } }
-} define-intrinsic
-
-: overflow-check ( word -- )
- "end" define-label
- "z" operand "x" operand MOV
- "z" operand "y" operand pick execute
- ! If the previous arithmetic operation overflowed, then we
- ! turn the result into a bignum and leave it in EAX.
- "end" get JNO
- ! There was an overflow. Recompute the original operand.
- { "y" "x" } %untag-fixnums
- "x" operand "y" operand rot execute
- "z" operand "x" operand "y" operand %allot-bignum-signed-1
- "end" resolve-label ; inline
-
-: overflow-template ( word insn -- )
- [ overflow-check ] curry T{ template
- { input { { f "x" } { f "y" } } }
- { scratch { { f "z" } } }
- { output { "z" } }
- { clobber { "x" "y" } }
- { gc t }
- } define-intrinsic ;
-
-\ fixnum+ \ ADD overflow-template
-\ fixnum- \ SUB overflow-template
-
-: fixnum-jump ( op inputs -- pair )
- >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
-
-: fixnum-value-jump ( op -- pair )
- { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
-
-: fixnum-register-jump ( op -- pair )
- { { f "x" } { f "y" } } fixnum-jump ;
-
-: define-fixnum-jump ( word op -- )
- [ fixnum-value-jump ] keep fixnum-register-jump
- 2array define-if-intrinsics ;
-
-{
- { fixnum< JL }
- { fixnum<= JLE }
- { fixnum> JG }
- { fixnum>= JGE }
- { eq? JE }
-} [
- first2 define-fixnum-jump
-] each
-
-\ fixnum>bignum [
- "x" operand %untag-fixnum
- "x" operand dup "scratch" operand %allot-bignum-signed-1
-] T{ template
- { input { { f "x" } } }
- { scratch { { f "scratch" } } }
- { output { "x" } }
- { gc t }
-} define-intrinsic
-
-\ bignum>fixnum [
- "nonzero" define-label
- "positive" define-label
- "end" define-label
- "x" operand %untag
- "y" operand "x" operand cell [+] MOV
- ! if the length is 1, its just the sign and nothing else,
- ! so output 0
- "y" operand 1 tag-fixnum CMP
- "nonzero" get JNE
- "y" operand 0 MOV
- "end" get JMP
- "nonzero" resolve-label
- ! load the value
- "y" operand "x" operand 3 cells [+] MOV
- ! load the sign
- "x" operand "x" operand 2 cells [+] MOV
- ! is the sign negative?
- "x" operand 0 CMP
- "positive" get JE
- "y" operand -1 IMUL2
- "positive" resolve-label
- "y" operand 3 SHL
- "end" resolve-label
-] T{ template
- { input { { f "x" } } }
- { scratch { { f "y" } } }
- { clobber { "x" } }
- { output { "y" } }
-} define-intrinsic
-
-! User environment
-: %userenv ( -- )
- "x" operand 0 MOV
- "userenv" f rc-absolute-cell rel-dlsym
- "n" operand fixnum>slot@
- "n" operand "x" operand ADD ;
-
-\ getenv [
- %userenv "n" operand dup [] MOV
-] T{ template
- { input { { f "n" } } }
- { scratch { { f "x" } } }
- { output { "n" } }
-} define-intrinsic
-
-\ setenv [
- %userenv "n" operand [] "val" operand MOV
-] T{ template
- { input { { f "val" } { f "n" } } }
- { scratch { { f "x" } } }
- { clobber { "n" } }
-} define-intrinsic
-
-! Alien intrinsics
-: %alien-accessor ( quot -- )
- "offset" operand %untag-fixnum
- "offset" operand "alien" operand ADD
- "offset" operand [] swap call ; inline
-
-: %alien-integer-get ( quot reg -- )
- small-reg PUSH
- swap %alien-accessor
- "value" operand small-reg MOV
- "value" operand %tag-fixnum
- small-reg POP ; inline
-
-: alien-integer-get-template
- T{ template
- { input {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { scratch { { f "value" } } }
- { output { "value" } }
- { clobber { "offset" } }
- } ;
-
-: define-getter ( word quot reg -- )
- [ %alien-integer-get ] 2curry
- alien-integer-get-template
- define-intrinsic ;
-
-: define-unsigned-getter ( word reg -- )
- [ small-reg dup XOR MOV ] swap define-getter ;
-
-: define-signed-getter ( word reg -- )
- [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
-
-: %alien-integer-set ( quot reg -- )
- small-reg PUSH
- small-reg "value" operand MOV
- small-reg %untag-fixnum
- swap %alien-accessor
- small-reg POP ; inline
-
-: alien-integer-set-template
- T{ template
- { input {
- { f "value" fixnum }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { clobber { "value" "offset" } }
- } ;
-
-: define-setter ( word reg -- )
- [ swap MOV ] swap
- [ %alien-integer-set ] 2curry
- alien-integer-set-template
- define-intrinsic ;
-
-\ alien-unsigned-1 small-reg-8 define-unsigned-getter
-\ set-alien-unsigned-1 small-reg-8 define-setter
-
-\ alien-signed-1 small-reg-8 define-signed-getter
-\ set-alien-signed-1 small-reg-8 define-setter
-
-\ alien-unsigned-2 small-reg-16 define-unsigned-getter
-\ set-alien-unsigned-2 small-reg-16 define-setter
-
-\ alien-signed-2 small-reg-16 define-signed-getter
-\ set-alien-signed-2 small-reg-16 define-setter
-
-\ alien-cell [
- "value" operand [ MOV ] %alien-accessor
-] T{ template
- { input {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { scratch { { unboxed-alien "value" } } }
- { output { "value" } }
- { clobber { "offset" } }
-} define-intrinsic
-
-\ set-alien-cell [
- "value" operand [ swap MOV ] %alien-accessor
-] T{ template
- { input {
- { unboxed-c-ptr "value" pinned-c-ptr }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { clobber { "offset" } }
-} define-intrinsic
+++ /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
-Slava Pestov
+++ /dev/null
-IN: compiler.cfg.builder.tests
-USING: tools.test kernel sequences
-words sequences.private fry prettyprint alien
-math.private compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.debugger ;
-
-! Just ensure that various CFGs build correctly.
-{
- [ ]
- [ 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-1 ( -- ) test-1 ;
-: test-2 ( -- ) 3 . test-2 ;
-: test-3 ( a -- b ) dup [ test-3 ] when ;
-
-{
- test-1
- test-2
- test-3
-} [
- '[ _ test-cfg drop ] [ ] swap unit-test
-] each
+++ /dev/null
- ! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators hashtables kernel
-math fry namespaces make sequences words byte-arrays
-locals layouts alien.c-types alien.structs
-stack-checker.inlining
-compiler.intrinsics
-compiler.tree
-compiler.tree.builder
-compiler.tree.combinators
-compiler.tree.propagation.info
-compiler.cfg
-compiler.cfg.stacks
-compiler.cfg.templates
-compiler.cfg.iterator
-compiler.cfg.instructions
-compiler.cfg.registers
-compiler.alien ;
-IN: compiler.cfg.builder
-
-! 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 [
- dupd successors>> push
- ] when*
- set-basic-block ;
-
-: end-basic-block ( -- )
- building off
- basic-block off ;
-
-: stop-iterating ( -- next ) end-basic-block f ;
-
-SYMBOL: procedures
-SYMBOL: current-word
-SYMBOL: current-label
-SYMBOL: loops
-
-! Basic block after prologue, makes recursion faster
-SYMBOL: current-label-start
-
-: add-procedure ( -- )
- basic-block get current-word get current-label get
- <cfg> procedures get push ;
-
-: begin-procedure ( word label -- )
- end-basic-block
- begin-basic-block
- H{ } clone loops set
- current-label set
- current-word set
- add-procedure ;
-
-: with-cfg-builder ( nodes word label quot -- )
- '[ begin-procedure @ ] with-scope ; inline
-
-GENERIC: emit-node ( node -- next )
-
-: check-basic-block ( node -- node' )
- basic-block get [ drop f ] unless ; inline
-
-: emit-nodes ( nodes -- )
- [ current-node emit-node check-basic-block ] iterate-nodes
- finalize-phantoms ;
-
-: remember-loop ( label -- )
- basic-block get swap loops get set-at ;
-
-: begin-word ( -- )
- #! We store the basic block after the prologue as a loop
- #! labelled by the current word, so that self-recursive
- #! calls can skip an epilogue/prologue.
- init-phantoms
- ##prologue
- ##branch
- begin-basic-block
- current-label get remember-loop ;
-
-: (build-cfg) ( nodes word label -- )
- [
- begin-word
- [ emit-nodes ] with-node-iterator
- ] with-cfg-builder ;
-
-: build-cfg ( nodes word -- procedures )
- V{ } clone [
- procedures [
- dup (build-cfg)
- ] with-variable
- ] keep ;
-
-SYMBOL: +intrinsics+
-SYMBOL: +if-intrinsics+
-
-: if-intrinsics ( #call -- quot )
- word>> +if-intrinsics+ word-prop ;
-
-: local-recursive-call ( basic-block -- next )
- ##branch
- basic-block get successors>> push
- stop-iterating ;
-
-: emit-call ( word -- next )
- finalize-phantoms
- {
- { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
- { [ dup loops get key? ] [ loops get at local-recursive-call ] }
- [ ##epilogue ##jump stop-iterating ]
- } 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 ;
-
-M: #recursive emit-node
- dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
-
-! #if
-: emit-branch ( obj quot -- final-bb )
- '[
- begin-basic-block copy-phantoms
- @
- basic-block get dup [ ##branch ] when
- ] with-scope ;
-
-: emit-branches ( seq quot -- )
- '[ _ emit-branch ] map
- end-basic-block
- begin-basic-block
- basic-block get '[ [ _ swap successors>> push ] when* ] each
- init-phantoms ;
-
-: emit-if ( node -- next )
- children>> [ emit-nodes ] emit-branches ;
-
-M: #if emit-node
- phantom-pop ##branch-t emit-if iterate-next ;
-
-! #dispatch
-: dispatch-branch ( nodes word -- label )
- #! The order here is important, dispatch-branches must
- #! run after ##dispatch, so that each branch gets the
- #! correct register state
- gensym [
- [
- copy-phantoms
- ##prologue
- [ emit-nodes ] with-node-iterator
- ##epilogue
- ##return
- ] with-cfg-builder
- ] keep ;
-
-: dispatch-branches ( node -- )
- children>> [
- current-word get dispatch-branch
- ##dispatch-label
- ] each ;
-
-: emit-dispatch ( node -- )
- phantom-pop int-regs next-vreg
- [ finalize-contents finalize-heights ##epilogue ] 2dip ##dispatch
- dispatch-branches init-phantoms ;
-
-M: #dispatch emit-node
- tail-call? [
- emit-dispatch iterate-next
- ] [
- current-word get gensym [
- [
- begin-word
- emit-dispatch
- ] with-cfg-builder
- ] keep emit-call
- ] if ;
-
-! #call
-: define-intrinsics ( word intrinsics -- )
- +intrinsics+ set-word-prop ;
-
-: define-intrinsic ( word quot assoc -- )
- 2array 1array define-intrinsics ;
-
-: define-if-intrinsics ( word intrinsics -- )
- [ template new swap >>input ] assoc-map
- +if-intrinsics+ set-word-prop ;
-
-: define-if-intrinsic ( word quot inputs -- )
- 2array 1array define-if-intrinsics ;
-
-: find-intrinsic ( #call -- pair/f )
- word>> +intrinsics+ word-prop find-template ;
-
-: find-boolean-intrinsic ( #call -- pair/f )
- word>> +if-intrinsics+ word-prop find-template ;
-
-: find-if-intrinsic ( #call -- pair/f )
- node@ {
- { [ dup length 2 < ] [ 2drop f ] }
- { [ dup second #if? ] [ drop find-boolean-intrinsic ] }
- [ 2drop f ]
- } cond ;
-
-: do-if-intrinsic ( pair -- next )
- [ ##if-intrinsic ] apply-template skip-next emit-if
- iterate-next ;
-
-: do-boolean-intrinsic ( pair -- next )
- [ ##if-intrinsic ] apply-template
- { t f } [
- <constant> phantom-push finalize-phantoms
- ] emit-branches
- iterate-next ;
-
-: do-intrinsic ( pair -- next )
- [ ##intrinsic ] apply-template iterate-next ;
-
-: setup-value-classes ( #call -- )
- node-input-infos [ class>> ] map set-value-classes ;
-
-{
- (tuple) (array) (byte-array)
- (complex) (ratio) (wrapper)
- (write-barrier)
-} [ t "intrinsic" set-word-prop ] each
-
-: allot-size ( -- n )
- 1 phantom-datastack get phantom-input first value>> ;
-
-:: emit-allot ( size type tag -- )
- int-regs next-vreg
- dup fresh-object
- dup size type tag int-regs next-vreg ##allot
- type tagged boa phantom-push ;
-
-: emit-write-barrier ( -- )
- phantom-pop dup >vreg fresh-object? [ drop ] [
- int-regs next-vreg ##write-barrier
- ] if ;
-
-: emit-intrinsic ( word -- next )
- {
- { \ (tuple) [ allot-size 2 cells + tuple tuple emit-allot ] }
- { \ (array) [ allot-size 2 cells + array object emit-allot ] }
- { \ (byte-array) [ allot-size cells 2 + byte-array object emit-allot ] }
- { \ (complex) [ 3 cells complex complex emit-allot ] }
- { \ (ratio) [ 3 cells ratio ratio emit-allot ] }
- { \ (wrapper) [ 2 cells wrapper object emit-allot ] }
- { \ (write-barrier) [ emit-write-barrier ] }
- } case
- iterate-next ;
-
-M: #call emit-node
- dup setup-value-classes
- dup find-if-intrinsic [ do-if-intrinsic ] [
- dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
- dup find-intrinsic [ do-intrinsic ] [
- word>> dup "intrinsic" word-prop
- [ emit-intrinsic ] [ emit-call ] if
- ] ?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 stop-iterating ;
-
-! FFI
-: return-size ( ctype -- n )
- #! Amount of space we reserve for a return value.
- {
- { [ dup c-struct? not ] [ drop 0 ] }
- { [ dup large-struct? not ] [ drop 2 cells ] }
- [ heap-size ]
- } cond ;
-
-: <alien-stack-frame> ( params -- stack-frame )
- stack-frame new
- swap
- [ return>> return-size >>return ]
- [ alien-parameters parameter-sizes drop >>params ] bi
- dup [ params>> ] [ return>> ] bi + >>size ;
-
-: alien-stack-frame ( node -- )
- params>> <alien-stack-frame> ##stack-frame ;
-
-: emit-alien-node ( node quot -- next )
- [ drop alien-stack-frame ]
- [ [ params>> ] dip call ] 2bi
- iterate-next ; inline
-
-M: #alien-invoke emit-node
- [ ##alien-invoke ] emit-alien-node ;
-
-M: #alien-indirect emit-node
- [ ##alien-indirect ] emit-alien-node ;
-
-M: #alien-callback emit-node
- params>> dup xt>> dup
- [
- init-phantoms
- [ ##alien-callback ] emit-alien-node drop
- ] with-cfg-builder
- iterate-next ;
-
-! No-op nodes
-M: #introduce emit-node drop iterate-next ;
-
-M: #copy emit-node drop iterate-next ;
-
-M: #enter-recursive emit-node drop iterate-next ;
-
-M: #phi emit-node drop iterate-next ;
+++ /dev/null
-Final stage of compilation generates machine code from dataflow IR
+++ /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
-
-TUPLE: cfg entry word label ;
-
-C: <cfg> cfg
-
-! - "number" and "visited" is used by linearization.
-TUPLE: basic-block < identity-tuple
-visited
-number
-instructions
-successors ;
-
-: <basic-block> ( -- basic-block )
- basic-block new
- V{ } clone >>instructions
- V{ } clone >>successors ;
-
-TUPLE: mr instructions word label ;
-
-: <mr> ( instructions word label -- mr )
- mr new
- swap >>label
- swap >>word
- swap >>instructions ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences quotations namespaces io
-accessors prettyprint prettyprint.config
-compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.linearization ;
-IN: compiler.cfg.debugger
-
-GENERIC: test-cfg ( quot -- cfgs )
-
-M: callable test-cfg
- build-tree optimize-tree gensym build-cfg ;
-
-M: word test-cfg
- [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
-
-: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;
-
-: mr. ( mrs -- )
- [
- boa-tuples? on
- "=== word: " write
- dup word>> pprint
- ", label: " write
- dup label>> pprint nl nl
- instructions>> .
- nl
- ] each ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors arrays kernel sequences namespaces
-math compiler.cfg.registers compiler.cfg.instructions.syntax ;
-IN: compiler.cfg.instructions
-
-! Virtual CPU instructions, used by CFG and machine IRs
-
-TUPLE: ##cond-branch < insn src ;
-TUPLE: ##unary < insn dst src ;
-TUPLE: ##nullary < insn dst ;
-
-! Stack operations
-INSN: ##load-literal < ##nullary obj ;
-INSN: ##peek < ##nullary loc ;
-INSN: ##replace src loc ;
-INSN: ##inc-d n ;
-INSN: ##inc-r n ;
-
-! Subroutine calls
-TUPLE: stack-frame
-{ size integer }
-{ params integer }
-{ return integer }
-{ total-size integer } ;
-
-INSN: ##stack-frame stack-frame ;
- : ##simple-stack-frame ( -- ) T{ stack-frame } ##stack-frame ;
-INSN: ##call word ;
-INSN: ##jump word ;
-INSN: ##return ;
-
-INSN: ##intrinsic quot defs-vregs uses-vregs ;
-
-! Jump tables
-INSN: ##dispatch-label label ;
-INSN: ##dispatch src temp ;
-
-! 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 temp ;
-INSN: ##box-alien < ##unary temp ;
-
-! Memory allocation
-INSN: ##allot < ##nullary size type tag temp ;
-INSN: ##write-barrier src temp ;
-INSN: ##gc ;
-
-! FFI
-INSN: ##alien-invoke params ;
-INSN: ##alien-indirect params ;
-INSN: ##alien-callback params ;
-
-GENERIC: defs-vregs ( insn -- seq )
-GENERIC: uses-vregs ( insn -- seq )
-
-M: ##nullary defs-vregs dst>> >vreg 1array ;
-M: ##unary defs-vregs dst>> >vreg 1array ;
-M: ##write-barrier defs-vregs temp>> >vreg 1array ;
-
-: allot-defs-vregs ( insn -- seq )
- [ dst>> >vreg ] [ temp>> >vreg ] bi 2array ;
-
-M: ##box-float defs-vregs allot-defs-vregs ;
-M: ##box-alien defs-vregs allot-defs-vregs ;
-M: ##allot defs-vregs allot-defs-vregs ;
-M: ##dispatch defs-vregs temp>> >vreg 1array ;
-M: insn defs-vregs drop f ;
-
-M: ##replace uses-vregs src>> >vreg 1array ;
-M: ##unary uses-vregs src>> >vreg 1array ;
-M: ##write-barrier uses-vregs src>> >vreg 1array ;
-M: ##dispatch uses-vregs src>> >vreg 1array ;
-M: insn uses-vregs drop f ;
-
-: intrinsic-vregs ( assoc -- seq' )
- [ nip >vreg ] { } assoc>map sift ;
-
-: intrinsic-defs-vregs ( insn -- seq )
- defs-vregs>> intrinsic-vregs ;
-
-: intrinsic-uses-vregs ( insn -- seq )
- uses-vregs>> intrinsic-vregs ;
-
-M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
-M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
-
-! Instructions used by CFG IR only.
-INSN: ##prologue ;
-INSN: ##epilogue ;
-
-INSN: ##branch ;
-INSN: ##branch-f < ##cond-branch ;
-INSN: ##branch-t < ##cond-branch ;
-INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
-
-M: ##cond-branch uses-vregs src>> >vreg 1array ;
-
-M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
-M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
-
-! Instructions used by machine IR only.
-INSN: _prologue stack-frame ;
-INSN: _epilogue stack-frame ;
-
-INSN: _label id ;
-
-TUPLE: _cond-branch < insn src label ;
-
-INSN: _branch label ;
-INSN: _branch-f < _cond-branch ;
-INSN: _branch-t < _cond-branch ;
-INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
-
-M: _cond-branch uses-vregs src>> >vreg 1array ;
-
-M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
-M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
-
-INSN: _spill-integer src n ;
-INSN: _reload-integer dst n ;
-
-INSN: _spill-float src n ;
-INSN: _reload-float dst n ;
+++ /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 fry sequences parser ;
-IN: compiler.cfg.instructions.syntax
-
-TUPLE: insn ;
-
-: INSN:
- parse-tuple-definition "regs" suffix
- [ dup tuple eq? [ drop insn ] when ] dip
- [ define-tuple-class ]
- [ 2drop save-location ]
- [ 2drop dup '[ f _ boa , ] define-inline ]
- 3tri ; parsing
+++ /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: namespaces sequences math math.order kernel assocs
-accessors vectors fry heaps
-compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals
-compiler.backend ;
-IN: compiler.cfg.linear-scan.allocation
-
-! Mapping from register classes to sequences of machine registers
-SYMBOL: free-registers
-
-: free-registers-for ( vreg -- seq )
- reg-class>> free-registers get at ;
-
-: deallocate-register ( live-interval -- )
- [ reg>> ] [ vreg>> ] bi free-registers-for push ;
-
-! Vector of active live intervals
-SYMBOL: active-intervals
-
-: add-active ( live-interval -- )
- active-intervals get push ;
-
-: delete-active ( live-interval -- )
- active-intervals get delete ;
-
-: expire-old-intervals ( n -- )
- active-intervals get
- swap '[ end>> _ < ] partition
- active-intervals set
- [ deallocate-register ] each ;
-
-: expire-old-uses ( n -- )
- active-intervals get
- swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ;
-
-: update-state ( live-interval -- )
- start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
-
-! Minheap of live intervals which still need a register allocation
-SYMBOL: unhandled-intervals
-
-! Start index of current live interval. We ensure that all
-! live intervals added to the unhandled set have a start index
-! strictly greater than ths one. This ensures that we can catch
-! infinite loop situations.
-SYMBOL: progress
-
-: check-progress ( live-interval -- )
- start>> progress get <= [ "No progress" throw ] when ; inline
-
-: add-unhandled ( live-interval -- )
- [ check-progress ]
- [ dup start>> unhandled-intervals get heap-push ]
- bi ;
-
-: init-unhandled ( live-intervals -- )
- [ [ start>> ] keep ] { } map>assoc
- unhandled-intervals get heap-push-all ;
-
-: assign-free-register ( live-interval registers -- )
- #! If the live interval does not have any uses, it means it
- #! will be spilled immediately, so it still needs a register
- #! to compute the new value, but we don't add the interval
- #! to the active set and we don't remove the register from
- #! the free list.
- over uses>> empty?
- [ peek >>reg drop ] [ pop >>reg add-active ] if ;
-
-! Spilling
-SYMBOL: spill-counts
-
-: next-spill-location ( reg-class -- n )
- spill-counts get [ dup 1+ ] change-at ;
-
-: interval-to-spill ( -- live-interval )
- #! We spill the interval with the most distant use location.
- active-intervals get unclip-slice [
- [ [ uses>> peek ] bi@ > ] most
- ] reduce ;
-
-: check-split ( live-interval -- )
- [ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ;
-
-: split-interval ( live-interval -- before after )
- #! Split the live interval at the location of its first use.
- #! 'Before' now starts and ends on the same instruction.
- [ check-split ]
- [ clone [ uses>> delete-all ] [ dup start>> >>end ] bi ]
- [ clone f >>reg dup uses>> peek >>start ]
- tri ;
-
-: record-split ( live-interval before after -- )
- [ >>split-before ] [ >>split-after ] bi* drop ;
-
-: assign-spill ( before after -- before after )
- #! If it has been spilled already, reuse spill location.
- over reload-from>> [ next-spill-location ] unless*
- tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
-
-: split-and-spill ( live-interval -- before after )
- dup split-interval [ record-split ] [ assign-spill ] 2bi ;
-
-: reuse-register ( new existing -- )
- reg>> >>reg
- dup uses>> empty? [ deallocate-register ] [ add-active ] if ;
-
-: spill-existing ( new existing -- )
- #! Our new interval will be used before the active interval
- #! with the most distant use location. Spill the existing
- #! interval, then process the new interval and the tail end
- #! of the existing interval again.
- [ reuse-register ]
- [ delete-active ]
- [ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ;
-
-: spill-new ( new existing -- )
- #! Our new interval will be used after the active interval
- #! with the most distant use location. Split the new
- #! interval, then process both parts of the new interval
- #! again.
- [ split-and-spill add-unhandled ] dip spill-existing ;
-
-: spill-existing? ( new existing -- ? )
- over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ;
-
-: assign-blocked-register ( live-interval -- )
- interval-to-spill
- 2dup spill-existing?
- [ spill-existing ] [ spill-new ] if ;
-
-: assign-register ( live-interval -- )
- dup vreg>> free-registers-for [
- assign-blocked-register
- ] [
- assign-free-register
- ] if-empty ;
-
-! Main loop
-: init-allocator ( registers -- )
- V{ } clone active-intervals set
- <min-heap> unhandled-intervals set
- [ reverse >vector ] assoc-map free-registers set
- H{ { int-regs 0 } { double-float-regs 0 } } clone spill-counts set
- -1 progress set ;
-
-: handle-interval ( live-interval -- )
- [ start>> progress set ] [ update-state ] [ assign-register ] tri ;
-
-: (allocate-registers) ( -- )
- unhandled-intervals get [ handle-interval ] slurp-heap ;
-
-: allocate-registers ( live-intervals machine-registers -- live-intervals )
- #! This modifies the input live-intervals.
- init-allocator
- dup init-unhandled
- (allocate-registers) ;
+++ /dev/null
-USING: compiler.cfg.linear-scan.assignment tools.test ;
-IN: compiler.cfg.linear-scan.assignment.tests
-
-\ assign-registers must-infer
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators
-compiler.cfg.registers
-compiler.cfg.instructions
-compiler.cfg.linear-scan.live-intervals ;
-IN: compiler.cfg.linear-scan.assignment
-
-! A vector of live intervals. There is linear searching involved
-! but since we never have too many machine registers (around 30
-! at most) and we probably won't have that many live at any one
-! time anyway, it is not a problem to check each element.
-SYMBOL: active-intervals
-
-: add-active ( live-interval -- )
- active-intervals get push ;
-
-: lookup-register ( vreg -- reg )
- active-intervals get [ vreg>> = ] with find nip reg>> ;
-
-! Minheap of live intervals which still need a register allocation
-SYMBOL: unhandled-intervals
-
-: add-unhandled ( live-interval -- )
- dup split-before>> [
- [ split-before>> ] [ split-after>> ] bi
- [ add-unhandled ] bi@
- ] [
- dup start>> unhandled-intervals get heap-push
- ] if ;
-
-: init-unhandled ( live-intervals -- )
- [ add-unhandled ] each ;
-
-: insert-spill ( live-interval -- )
- [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri
- over [
- {
- { int-regs [ _spill-integer ] }
- { double-float-regs [ _spill-float ] }
- } case
- ] [ 3drop ] if ;
-
-: expire-old-intervals ( n -- )
- active-intervals get
- swap '[ end>> _ = ] partition
- active-intervals set
- [ insert-spill ] each ;
-
-: insert-reload ( live-interval -- )
- [ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri
- over [
- {
- { int-regs [ _reload-integer ] }
- { double-float-regs [ _reload-float ] }
- } case
- ] [ 3drop ] if ;
-
-: activate-new-intervals ( n -- )
- #! Any live intervals which start on the current instruction
- #! are added to the active set.
- unhandled-intervals get dup heap-empty? [ 2drop ] [
- 2dup heap-peek drop start>> = [
- heap-pop drop [ add-active ] [ insert-reload ] bi
- activate-new-intervals
- ] [ 2drop ] if
- ] if ;
-
-: (assign-registers) ( insn -- )
- dup
- [ defs-vregs ] [ uses-vregs ] bi append
- active-intervals get swap '[ vreg>> _ member? ] filter
- [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
- >>regs drop ;
-
-: init-assignment ( live-intervals -- )
- V{ } clone active-intervals set
- <min-heap> unhandled-intervals set
- init-unhandled ;
-
-: assign-registers ( insns live-intervals -- insns' )
- [
- init-assignment
- [
- [ activate-new-intervals ]
- [ drop [ (assign-registers) ] [ , ] bi ]
- [ expire-old-intervals ]
- tri
- ] each-index
- ] { } make ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences sets arrays
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation ;
-IN: compiler.cfg.linear-scan.debugger
-
-: check-assigned ( live-intervals -- )
- [
- reg>>
- [ "Not all intervals have registers" throw ] unless
- ] each ;
-
-: split-children ( live-interval -- seq )
- dup split-before>> [
- [ split-before>> ] [ split-after>> ] bi
- [ split-children ] bi@
- append
- ] [ 1array ] if ;
-
-: check-linear-scan ( live-intervals machine-registers -- )
- [ [ clone ] map ] dip allocate-registers
- [ split-children ] map concat check-assigned ;
+++ /dev/null
-IN: compiler.cfg.linear-scan.tests
-USING: tools.test random sorting sequences sets hashtables assocs
-kernel fry arrays splitting namespaces math accessors vectors
-math.order
-compiler.cfg.registers
-compiler.cfg.linear-scan
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.debugger ;
-
-[ ] [
- {
- T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
- }
- H{ { f { "A" } } }
- check-linear-scan
-] unit-test
-
-[ ] [
- {
- T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 10 } { uses V{ 10 } } }
- T{ live-interval { vreg T{ vreg { n 2 } } } { start 11 } { end 20 } { uses V{ 20 } } }
- }
- H{ { f { "A" } } }
- check-linear-scan
-] unit-test
-
-[ ] [
- {
- T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
- T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 60 } { uses V{ 60 } } }
- }
- H{ { f { "A" } } }
- check-linear-scan
-] unit-test
-
-[ ] [
- {
- T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
- T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 200 } { uses V{ 200 } } }
- }
- H{ { f { "A" } } }
- check-linear-scan
-] unit-test
-
-[
- {
- T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
- T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 100 } { uses V{ 100 } } }
- }
- H{ { f { "A" } } }
- check-linear-scan
-] must-fail
-
-SYMBOL: available
-
-SYMBOL: taken
-
-SYMBOL: max-registers
-
-SYMBOL: max-insns
-
-SYMBOL: max-uses
-
-: not-taken ( -- n )
- available get keys dup empty? [ "Oops" throw ] when
- random
- dup taken get nth 1 + max-registers get = [
- dup available get delete-at
- ] [
- dup taken get [ 1 + ] change-nth
- ] if ;
-
-: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq )
- [
- max-insns set
- max-registers set
- max-uses set
- max-insns get [ 0 ] replicate taken set
- max-insns get [ dup ] H{ } map>assoc available set
- [
- live-interval new
- swap f swap vreg boa >>vreg
- max-uses get random 2 max [ not-taken ] replicate natural-sort
- unclip [ >vector >>uses ] [ >>start ] bi*
- dup uses>> first >>end
- ] map
- ] with-scope ;
-
-: random-test ( num-intervals max-uses max-registers max-insns -- )
- over >r random-live-intervals r> f associate check-linear-scan ;
-
-[ ] [ 30 2 1 60 random-test ] unit-test
-[ ] [ 60 2 2 60 random-test ] unit-test
-[ ] [ 80 2 3 200 random-test ] unit-test
-[ ] [ 70 2 5 30 random-test ] unit-test
-[ ] [ 60 2 6 30 random-test ] unit-test
-[ ] [ 1 2 10 10 random-test ] unit-test
-
-[ ] [ 10 4 2 60 random-test ] unit-test
-[ ] [ 10 20 2 400 random-test ] unit-test
-[ ] [ 10 20 4 300 random-test ] unit-test
-
-USING: math.private compiler.cfg.debugger ;
-
-[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces
-compiler.backend
-compiler.cfg
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation
-compiler.cfg.linear-scan.assignment ;
-IN: compiler.cfg.linear-scan
-
-! References:
-
-! Linear Scan Register Allocation
-! by Massimiliano Poletto and Vivek Sarkar
-! http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
-
-! Linear Scan Register Allocation for the Java HotSpot Client Compiler
-! by Christian Wimmer
-! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
-
-! Quality and Speed in Linear-scan Register Allocation
-! by Omri Traub, Glenn Holloway, Michael D. Smith
-! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
-
-: linear-scan ( mr -- mr' )
- [
- [
- dup compute-live-intervals
- machine-registers allocate-registers
- assign-registers
- ] change-instructions
- spill-counts get >>spill-counts
- ] with-scope ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs accessors sequences math fry
-compiler.cfg.instructions compiler.cfg.registers ;
-IN: compiler.cfg.linear-scan.live-intervals
-
-TUPLE: live-interval < identity-tuple
-vreg
-reg spill-to reload-from split-before split-after
-start end uses ;
-
-: <live-interval> ( start vreg -- live-interval )
- live-interval new
- swap >>vreg
- swap >>start
- V{ } clone >>uses ;
-
-M: live-interval hashcode*
- nip [ start>> ] [ end>> 1000 * ] bi + ;
-
-M: live-interval clone
- call-next-method [ clone ] change-uses ;
-
-! Mapping from vreg to live-interval
-SYMBOL: live-intervals
-
-: add-use ( n vreg live-intervals -- )
- at [ (>>end) ] [ uses>> push ] 2bi ;
-
-: new-live-interval ( n vreg live-intervals -- )
- 2dup key? [ "Multiple defs" throw ] when
- [ [ <live-interval> ] keep ] dip set-at ;
-
-: compute-live-intervals* ( insn n -- )
- live-intervals get
- [ [ uses-vregs ] 2dip '[ _ swap _ add-use ] each ]
- [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
- 3bi ;
-
-: finalize-live-intervals ( assoc -- seq' )
- #! Reverse uses lists so that we can pop values off.
- values dup [ uses>> reverse-here ] each ;
-
-: compute-live-intervals ( instructions -- live-intervals )
- H{ } clone [
- live-intervals set
- [ compute-live-intervals* ] each-index
- ] keep finalize-live-intervals ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces make
-combinators
-compiler.cfg
-compiler.cfg.rpo
-compiler.cfg.instructions
-compiler.cfg.instructions.syntax ;
-IN: compiler.cfg.linearization
-
-! Convert CFG IR to machine IR.
-GENERIC: linearize-insn ( basic-block insn -- )
-
-: linearize-insns ( basic-block -- )
- dup instructions>> [ linearize-insn ] with each ; inline
-
-M: insn linearize-insn , drop ;
-
-: useless-branch? ( basic-block successor -- ? )
- #! If our successor immediately follows us in RPO, then we
- #! don't need to branch.
- [ number>> 1+ ] [ number>> ] bi* = ; inline
-
-: branch-to-return? ( successor -- ? )
- #! A branch to a block containing just a return is cloned.
- instructions>> dup length 2 = [
- [ first ##epilogue? ] [ second ##return? ] bi and
- ] [ drop f ] if ;
-
-: emit-branch ( basic-block successor -- )
- {
- { [ 2dup useless-branch? ] [ 2drop ] }
- { [ dup branch-to-return? ] [ nip linearize-insns ] }
- [ nip number>> _branch ]
- } cond ;
-
-M: ##branch linearize-insn
- drop dup successors>> first emit-branch ;
-
-: conditional ( basic-block -- basic-block successor1 label2 )
- dup successors>> first2 swap number>> ; inline
-
-: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
- [ conditional ] [ src>> ] bi* swap ; inline
-
-M: ##branch-f linearize-insn
- boolean-conditional _branch-f emit-branch ;
-
-M: ##branch-t linearize-insn
- boolean-conditional _branch-t emit-branch ;
-
-: >intrinsic< ( insn -- quot defs uses )
- [ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
-
-M: ##if-intrinsic linearize-insn
- [ conditional ] [ >intrinsic< ] bi*
- _if-intrinsic emit-branch ;
-
-: linearize-basic-block ( bb -- )
- [ number>> _label ] [ linearize-insns ] bi ;
-
-: linearize-basic-blocks ( rpo -- insns )
- [ [ linearize-basic-block ] each ] { } make ;
-
-: build-mr ( cfg -- mr )
- [ entry>> reverse-post-order linearize-basic-blocks ]
- [ word>> ] [ label>> ]
- tri <mr> ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces math kernel alien classes ;
-IN: compiler.cfg.registers
-
-! Virtual CPU registers, used by CFG and machine IRs
-
-MIXIN: value
-
-GENERIC: >vreg ( obj -- vreg )
-GENERIC: set-value-class ( class obj -- )
-GENERIC: value-class* ( operand -- class )
-
-: value-class ( operand -- class ) value-class* object or ;
-
-M: value >vreg drop f ;
-M: value set-value-class 2drop ;
-M: value value-class* 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 set-value-class vreg>> set-value-class ;
-M: cached value-class* vreg>> value-class* ;
-M: cached >vreg vreg>> >vreg ;
-
-INSTANCE: cached value
-
-! A tagged pointer
-TUPLE: tagged vreg class ;
-: <tagged> ( vreg -- tagged ) f tagged boa ;
-
-M: tagged set-value-class (>>class) ;
-M: tagged value-class* class>> ;
-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
-
-M: unboxed-alien value-class* drop simple-alien ;
-
-! Untagged byte array pointer
-TUPLE: unboxed-byte-array < unboxed ;
-C: <unboxed-byte-array> unboxed-byte-array
-
-M: unboxed-byte-array value-class* drop c-ptr ;
-
-! A register set to f
-TUPLE: unboxed-f < unboxed ;
-C: <unboxed-f> unboxed-f
-
-M: unboxed-f value-class* drop \ f ;
-
-! An alien, byte array or f
-TUPLE: unboxed-c-ptr < unboxed ;
-C: <unboxed-c-ptr> unboxed-c-ptr
-
-M: unboxed-c-ptr value-class* drop c-ptr ;
-
-! A constant value
-TUPLE: constant value ;
-C: <constant> constant
-
-M: constant value-class* value>> class ;
-
-INSTANCE: constant value
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces make math sequences
-compiler.cfg.instructions ;
-IN: compiler.cfg.rpo
-
-: post-order-traversal ( basic-block -- )
- dup visited>> [ drop ] [
- t >>visited
- [ successors>> [ post-order-traversal ] each ] [ , ] bi
- ] if ;
-
-: post-order ( procedure -- blocks )
- [ post-order-traversal ] { } make ;
-
-: number-blocks ( blocks -- )
- [ >>number drop ] each-index ;
-
-: reverse-post-order ( procedure -- blocks )
- post-order <reversed> dup number-blocks ; inline
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces accessors math.order assocs kernel sequences
-make compiler.cfg.instructions compiler.cfg.instructions.syntax
-compiler.cfg.registers ;
-IN: compiler.cfg.stack-frame
-
-SYMBOL: frame-required?
-
-SYMBOL: spill-counts
-
-: init-stack-frame-builder ( -- )
- frame-required? off
- T{ stack-frame } clone stack-frame set ;
-
-GENERIC: compute-stack-frame* ( insn -- )
-
-: max-stack-frame ( frame1 frame2 -- frame3 )
- {
- [ [ size>> ] bi@ max ]
- [ [ params>> ] bi@ max ]
- [ [ return>> ] bi@ max ]
- [ [ total-size>> ] bi@ max ]
- } cleave
- stack-frame boa ;
-
-M: ##stack-frame compute-stack-frame*
- frame-required? on
- stack-frame>> stack-frame [ max-stack-frame ] change ;
-
-M: _spill-integer compute-stack-frame*
- drop frame-required? on ;
-
-M: _spill-float compute-stack-frame*
- drop frame-required? on ;
-
-M: insn compute-stack-frame* drop ;
-
-: compute-stack-frame ( insns -- )
- [ compute-stack-frame* ] each ;
-
-GENERIC: insert-pro/epilogues* ( insn -- )
-
-M: ##stack-frame insert-pro/epilogues* drop ;
-
-M: ##prologue insert-pro/epilogues*
- drop frame-required? get [ stack-frame get _prologue ] when ;
-
-M: ##epilogue insert-pro/epilogues*
- drop frame-required? get [ stack-frame get _epilogue ] when ;
-
-M: insn insert-pro/epilogues* , ;
-
-: insert-pro/epilogues ( insns -- insns )
- [ [ insert-pro/epilogues* ] each ] { } make ;
-
-: build-stack-frame ( mr -- mr )
- [
- init-stack-frame-builder
- [
- [ compute-stack-frame ]
- [ insert-pro/epilogues ]
- bi
- ] change-instructions
- ] with-scope ;
+++ /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.backend
-compiler.cfg.instructions compiler.cfg.registers ;
-IN: compiler.cfg.stacks
-
-! Converting stack operations into register operations, while
-! doing a bit of optimization along the way.
-SYMBOL: known-tag
-
-! Value protocol
-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>
-
-! Default implementation
-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: vreg value-class* reg-class>> value-class* ;
-
-M: int-regs move-spec drop f ;
-M: int-regs value-class* drop object ;
-
-M: float-regs move-spec drop float ;
-M: float-regs value-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 value-class* class>> ;
-M: loc set-value-class (>>class) ;
-M: loc move-spec drop loc ;
-
-M: f move-spec drop loc ;
-M: f value-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 move-spec drop f ;
-
-M: unboxed-alien move-spec class ;
-
-M: unboxed-byte-array move-spec class ;
-
-M: unboxed-f move-spec class ;
-
-M: unboxed-c-ptr move-spec 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 value-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 value-class ] keep
- tagged new
- swap >>vreg
- swap >>class
- %move ;
-
-! Operands holding pointers to freshly-allocated objects which
-! are guaranteed to be in the nursery
-SYMBOL: fresh-objects
-
-: fresh-object ( vreg/t -- ) fresh-objects get push ;
-
-: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
-
-: %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>> ##load-literal ] }
-
- { { f float } [ int-regs next-vreg ##box-float t fresh-object ] }
- { { f unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] }
- { { 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 ;
-
-: 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 value-class
- over tagged? [ >>class ] [ drop ] if ;
-
-M: value (lazy-load)
- {
- { [ dup { small-slot small-tagged } memq? ] [ 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 ;
-
-: clear-phantoms ( -- )
- [ stack>> delete-all ] each-phantom ;
-
-: finalize-contents ( -- )
- finalize-locs finalize-vregs clear-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 ;
-
-: set-value-classes ( classes -- )
- phantom-datastack get
- over length over add-locs
- stack>> [
- [ value-class class-and ] keep set-value-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
- finalize-heights
- fresh-objects get [
- empty? [ ##simple-stack-frame ##gc ] unless
- ] [ delete-all ] bi ;
-
-: 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 ;
-
-: 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 ;
-
-: phantom-pop ( -- vreg )
- 1 phantom-datastack get phantom-input dup first f (lazy-load)
- [ 1array substitute-vregs ] keep ;
+++ /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.backend
-compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks ;
-IN: compiler.cfg.templates
-
-TUPLE: template input output scratch clobber gc ;
-
-: 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 )
- [ output>> ] [ 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
- [
- 2dup second clobbered?
- [ first (eager-load) ] [ first (lazy-load) ] if
- ] 2map ;
-
-: load-inputs ( template -- assoc )
- [
- live-vregs \ live-vregs set
- dup clobbered \ clobbered set
- input>> [ values ] [ lazy-load ] bi zip
- ] with-scope ;
-
-: alloc-scratch ( template -- assoc )
- scratch>> [ swap alloc-vreg ] assoc-map ;
-
-: do-template-inputs ( template -- defs uses )
- #! Load input values into registers and allocates scratch
- #! registers.
- [ alloc-scratch ] [ load-inputs ] bi ;
-
-: do-template-outputs ( template defs uses -- )
- [ output>> ] 2dip assoc-union '[ _ at ] map
- phantom-datastack get phantom-append ;
-
-: apply-template ( pair quot -- vregs )
- [
- first2
- dup gc>> [ t fresh-object ] when
- dup do-template-inputs
- [ do-template-outputs ] 2keep
- ] 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 small-slot eq? ] [ drop dup constant? [ value>> small-slot? ] [ drop f ] if ] }
- { [ dup small-tagged eq? ] [ drop dup constant? [ value>> small-tagged? ] [ drop f ] if ] }
- [ 2drop t ]
- } cond ;
-
-: 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 value-class 2 r> ?nth class-matches? r> and ;
-
-: template-matches? ( 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: namespaces make math math.parser sequences accessors
-kernel kernel.private layouts assocs words summary arrays
-combinators classes.algebra alien alien.c-types alien.structs
-alien.strings sets threads libc continuations.private
-compiler.errors
-compiler.alien
-compiler.backend
-compiler.codegen.fixup
-compiler.cfg
-compiler.cfg.instructions
-compiler.cfg.registers
-compiler.cfg.builder ;
-IN: compiler.codegen
-
-GENERIC: generate-insn ( insn -- )
-
-GENERIC: v>operand ( obj -- operand )
-
-SYMBOL: registers
-
-M: constant v>operand
- value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
-
-M: value v>operand
- >vreg [ registers get at ] [ "Bad value" throw ] if* ;
-
-: generate-insns ( insns -- code )
- [
- [
- dup regs>> registers set
- generate-insn
- ] each
- ] { } make fixup ;
-
-TUPLE: asm label code calls ;
-
-SYMBOL: calls
-
-: add-call ( word -- )
- #! Compile this word later.
- calls get push ;
-
-SYMBOL: compiling-word
-
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
-
-! Mapping _label IDs to label instances
-SYMBOL: labels
-
-: init-generator ( word -- )
- H{ } clone labels set
- V{ } clone literal-table set
- V{ } clone calls set
- compiling-word set
- compiled-stack-traces? compiling-word get f ? add-literal drop ;
-
-: generate ( mr -- asm )
- [
- [ label>> ]
- [ word>> init-generator ]
- [ instructions>> generate-insns ] tri
- calls get
- asm boa
- ] with-scope ;
-
-: lookup-label ( id -- label )
- labels get [ drop <label> ] cache ;
-
-M: _label generate-insn
- id>> lookup-label , ;
-
-M: _prologue generate-insn
- stack-frame>>
- [ stack-frame set ]
- [ dup size>> stack-frame-size >>total-size drop ]
- [ total-size>> %prologue ]
- tri ;
-
-M: _epilogue generate-insn
- stack-frame>> total-size>> %epilogue ;
-
-M: ##load-literal generate-insn
- [ obj>> ] [ dst>> v>operand ] bi load-literal ;
-
-M: ##peek generate-insn
- [ dst>> v>operand ] [ loc>> ] bi %peek ;
-
-M: ##replace generate-insn
- [ src>> ] [ loc>> ] bi %replace ;
-
-M: ##inc-d generate-insn n>> %inc-d ;
-
-M: ##inc-r generate-insn n>> %inc-r ;
-
-M: ##return generate-insn drop %return ;
-
-M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
-
-M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
-
-SYMBOL: operands
-
-: init-intrinsic ( insn -- )
- [ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
-
-M: ##intrinsic generate-insn
- [ init-intrinsic ] [ quot>> call ] bi ;
-
-: (operand) ( name -- operand )
- operands get at* [ "Bad operand name" throw ] unless ;
-
-: operand ( name -- operand )
- (operand) v>operand ;
-
-: operand-class ( var -- class )
- (operand) value-class ;
-
-: operand-tag ( operand -- tag/f )
- operand-class dup [ class-tag ] when ;
-
-: operand-immediate? ( operand -- ? )
- operand-class immediate class<= ;
-
-: unique-operands ( operands quot -- )
- >r [ operand ] map prune r> each ; inline
-
-M: _if-intrinsic generate-insn
- [ init-intrinsic ]
- [ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
-
-M: _branch generate-insn
- label>> lookup-label %jump-label ;
-
-M: _branch-f generate-insn
- [ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
-
-M: _branch-t generate-insn
- [ src>> v>operand ] [ label>> lookup-label ] bi %jump-t ;
-
-M: ##dispatch-label generate-insn label>> %dispatch-label ;
-
-M: ##dispatch generate-insn drop %dispatch ;
-
-: dst/src ( insn -- dst src )
- [ dst>> v>operand ] [ src>> v>operand ] bi ;
-
-M: ##copy generate-insn dst/src %copy ;
-
-M: ##copy-float generate-insn dst/src %copy-float ;
-
-M: ##unbox-float generate-insn dst/src %unbox-float ;
-
-M: ##unbox-f generate-insn dst/src %unbox-f ;
-
-M: ##unbox-alien generate-insn dst/src %unbox-alien ;
-
-M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
-
-M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
-
-M: ##box-float generate-insn dst/src %box-float ;
-
-M: ##box-alien generate-insn dst/src %box-alien ;
-
-M: ##allot generate-insn
- {
- [ dst>> v>operand ]
- [ size>> ]
- [ type>> ]
- [ tag>> ]
- [ temp>> v>operand ]
- } cleave
- %allot ;
-
-M: ##write-barrier generate-insn
- [ src>> v>operand ] [ temp>> v>operand ] bi %write-barrier ;
-
-M: ##gc generate-insn drop %gc ;
-
-! #alien-invoke
-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 -- seq )
- cell /i "void*" c-type <repetition> ;
-
-GENERIC: flatten-value-type ( type -- types )
-
-M: object flatten-value-type 1array ;
-
-M: struct-type flatten-value-type ( type -- types )
- stack-size cell align (flatten-int-type) ;
-
-M: long-long-type flatten-value-type ( type -- types )
- 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>> large-struct?
- [ %prepare-box-struct cell ] [ 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-insn
- params>>
- ! Save registers for GC
- %prepare-alien-invoke
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Call function
- dup alien-invoke-dlsym %alien-invoke
- ! Box return value
- dup %cleanup
- box-return* ;
-
-! ##alien-indirect
-M: ##alien-indirect generate-insn
- params>>
- ! Save registers for GC
- %prepare-alien-invoke
- ! Save alien at top of stack to temporary storage
- %prepare-alien-indirect
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Call alien in temporary storage
- %alien-indirect
- ! Box return value
- dup %cleanup
- box-return* ;
-
-! ##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> size>> ] }
- { [ 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 ;
-
-M: ##alien-callback generate-insn
- params>>
- [ registers>objects ]
- [ wrap-callback-quot %alien-callback ]
- [ %callback-return ]
- tri ;
+++ /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 math.order accessors
-growable compiler.constants compiler.backend ;
-IN: compiler.codegen.fixup
-
-GENERIC: fixup* ( obj -- )
-
-: code-format 22 getenv ;
-
-: compiled-offset ( -- n ) building get length code-format * ;
-
-SYMBOL: relocation-table
-SYMBOL: label-table
-
-M: label fixup* compiled-offset >>offset drop ;
-
-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
- [ label>> ] [ class>> ] bi 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: 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 ( fixup-directives -- code )
- [
- init-fixup
- [ fixup* ] each
- literal-table get >array
- relocation-table get >byte-array
- label-table get resolve-labels
- ] { } make 4array ;
+++ /dev/null
-Support for generation of relocatable code
+++ /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 ;
+++ /dev/null
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces arrays sequences io debugger
-words fry continuations vocabs assocs dlists definitions math
-threads graphs generic combinators deques search-deques
-stack-checker stack-checker.state stack-checker.inlining
-compiler.errors compiler.units compiler.tree.builder
-compiler.tree.optimizer compiler.cfg.builder
-compiler.cfg.linearization compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.codegen ;
-IN: compiler.new
-
-SYMBOL: compile-queue
-SYMBOL: compiled
-
-: queue-compile ( word -- )
- {
- { [ dup "forgotten" word-prop ] [ ] }
- { [ dup compiled get key? ] [ ] }
- { [ dup inlined-block? ] [ ] }
- { [ dup primitive? ] [ ] }
- [ dup compile-queue get push-front ]
- } cond drop ;
-
-: maybe-compile ( word -- )
- dup compiled>> [ drop ] [ queue-compile ] if ;
-
-SYMBOL: +failed+
-
-: ripple-up ( words -- )
- dup "compiled-effect" word-prop +failed+ eq?
- [ usage [ word? ] filter ] [ compiled-usage keys ] if
- [ queue-compile ] each ;
-
-: ripple-up? ( word effect -- ? )
- #! If the word has previously been compiled and had a
- #! different stack effect, we have to recompile any callers.
- swap "compiled-effect" word-prop [ = not ] keep and ;
-
-: save-effect ( word effect -- )
- [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
- [ "compiled-effect" set-word-prop ]
- 2bi ;
-
-: start ( word -- )
- H{ } clone dependencies set
- H{ } clone generic-dependencies set
- f swap compiler-error ;
-
-: fail ( word error -- )
- [ swap compiler-error ]
- [
- drop
- [ compiled-unxref ]
- [ f swap compiled get set-at ]
- [ +failed+ save-effect ]
- tri
- ] 2bi
- return ;
-
-: frontend ( word -- effect nodes )
- [ build-tree-from-word ] [ fail ] recover optimize-tree ;
-
-: finish ( effect word -- )
- [ swap save-effect ]
- [ compiled-unxref ]
- [
- dup crossref?
- [
- dependencies get >alist
- generic-dependencies get >alist
- compiled-xref
- ] [ drop ] if
- ] tri ;
-
-: save-asm ( asm -- )
- [ [ code>> ] [ label>> ] bi compiled get set-at ]
- [ calls>> [ queue-compile ] each ]
- bi ;
-
-: backend ( nodes word -- )
- build-cfg [
- build-mr
- linear-scan
- build-stack-frame
- generate
- save-asm
- ] each ;
-
-: (compile) ( word -- )
- '[
- _ {
- [ start ]
- [ frontend ]
- [ backend ]
- [ finish ]
- } cleave
- ] with-return ;
-
-: compile-loop ( deque -- )
- [ (compile) yield ] slurp-deque ;
-
-: decompile ( word -- )
- f 2array 1array t modify-code-heap ;
-
-: optimized-recompile-hook ( words -- alist )
- [
- <hashed-dlist> compile-queue set
- H{ } clone compiled set
- [ queue-compile ] each
- compile-queue get compile-loop
- compiled get >alist
- ] with-scope ;
-
-: enable-compiler ( -- )
- [ optimized-recompile-hook ] recompile-hook set-global ;
-
-: disable-compiler ( -- )
- [ default-recompile-hook ] recompile-hook set-global ;
-
-: recompile-all ( -- )
- forget-errors all-words compile ;
+++ /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: kernel words sequences lexer parser fry ;
-IN: cpu.x86.syntax
-
-: define-register ( name num size -- )
- [ "cpu.x86" create dup define-symbol ]
- [ dupd "register" set-word-prop ]
- [ "register-size" set-word-prop ]
- tri* ;
-
-: define-registers ( names size -- )
- [ dup length ] dip '[ _ define-register ] 2each ;
-
-: REGISTERS: ( -- )
- scan-word ";" parse-tokens swap define-registers ; parsing
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays compiler.constants compiler.backend
-compiler.codegen.fixup io.binary kernel combinators
-kernel.private math namespaces make sequences words system
-layouts math.order accessors cpu.x86.syntax ;
-IN: cpu.x86
-
-! A postfix assembler for x86 and AMD64.
-
-! In 32-bit mode, { 1234 } is absolute indirect addressing.
-! In 64-bit mode, { 1234 } is RIP-relative.
-! Beware!
-
-! Register operands -- eg, ECX
-REGISTERS: 8 AL CL DL BL ;
-
-REGISTERS: 16 AX CX DX BX SP BP SI DI ;
-
-REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
-
-REGISTERS: 64
-RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
-
-REGISTERS: 128
-XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
-XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
-
-TUPLE: byte value ;
-
-C: <byte> byte
-
-<PRIVATE
-
-#! Extended AMD64 registers (R8-R15) return true.
-GENERIC: extended? ( op -- ? )
-
-M: object extended? drop f ;
-
-PREDICATE: register < word
- "register" word-prop ;
-
-PREDICATE: register-8 < register
- "register-size" word-prop 8 = ;
-
-PREDICATE: register-16 < register
- "register-size" word-prop 16 = ;
-
-PREDICATE: register-32 < register
- "register-size" word-prop 32 = ;
-
-PREDICATE: register-64 < register
- "register-size" word-prop 64 = ;
-
-PREDICATE: register-128 < register
- "register-size" word-prop 128 = ;
-
-M: register extended? "register" word-prop 7 > ;
-
-! Addressing modes
-TUPLE: indirect base index scale displacement ;
-
-M: indirect extended? base>> extended? ;
-
-: canonicalize-EBP ( indirect -- indirect )
- #! { EBP } ==> { EBP 0 }
- dup base>> { EBP RBP R13 } member? [
- dup displacement>> [ 0 >>displacement ] unless
- ] when ;
-
-: canonicalize-ESP ( indirect -- indirect )
- #! { ESP } ==> { ESP ESP }
- dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
-
-: canonicalize ( indirect -- indirect )
- #! Modify the indirect to work around certain addressing mode
- #! quirks.
- canonicalize-EBP canonicalize-ESP ;
-
-: <indirect> ( base index scale displacement -- indirect )
- indirect boa canonicalize ;
-
-: reg-code ( reg -- n ) "register" word-prop 7 bitand ;
-
-: indirect-base* ( op -- n ) base>> EBP or reg-code ;
-
-: indirect-index* ( op -- n ) index>> ESP or reg-code ;
-
-: indirect-scale* ( op -- n ) scale>> 0 or ;
-
-GENERIC: sib-present? ( op -- ? )
-
-M: indirect sib-present?
- [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
-
-M: register sib-present? drop f ;
-
-GENERIC: r/m ( operand -- n )
-
-M: indirect r/m
- dup sib-present?
- [ drop ESP reg-code ] [ indirect-base* ] if ;
-
-M: register r/m reg-code ;
-
-! Immediate operands
-UNION: immediate byte integer ;
-
-GENERIC: fits-in-byte? ( value -- ? )
-
-M: byte fits-in-byte? drop t ;
-
-M: integer fits-in-byte? -128 127 between? ;
-
-GENERIC: modifier ( op -- n )
-
-M: indirect modifier
- dup base>> [
- displacement>> {
- { [ dup not ] [ BIN: 00 ] }
- { [ dup fits-in-byte? ] [ BIN: 01 ] }
- { [ dup immediate? ] [ BIN: 10 ] }
- } cond nip
- ] [
- drop BIN: 00
- ] if ;
-
-M: register modifier drop BIN: 11 ;
-
-GENERIC# n, 1 ( value n -- )
-
-M: integer n, >le % ;
-M: byte n, >r value>> r> n, ;
-: 1, ( n -- ) 1 n, ; inline
-: 4, ( n -- ) 4 n, ; inline
-: 2, ( n -- ) 2 n, ; inline
-: cell, ( n -- ) bootstrap-cell n, ; inline
-
-: mod-r/m, ( reg# indirect -- )
- [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
-
-: sib, ( indirect -- )
- dup sib-present? [
- [ indirect-base* ]
- [ indirect-index* 3 shift ]
- [ indirect-scale* 6 shift ] tri bitor bitor ,
- ] [
- drop
- ] if ;
-
-GENERIC: displacement, ( op -- )
-
-M: indirect displacement,
- dup displacement>> dup [
- swap base>>
- [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
- ] [
- 2drop
- ] if ;
-
-M: register displacement, drop ;
-
-: addressing ( reg# indirect -- )
- [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
-
-! Utilities
-UNION: operand register indirect ;
-
-GENERIC: operand-64? ( operand -- ? )
-
-M: indirect operand-64?
- [ base>> ] [ index>> ] bi [ operand-64? ] either? ;
-
-M: register-64 operand-64? drop t ;
-
-M: object operand-64? drop f ;
-
-: rex.w? ( rex.w reg r/m -- ? )
- {
- { [ dup register-128? ] [ drop operand-64? ] }
- { [ dup not ] [ drop operand-64? ] }
- [ nip operand-64? ]
- } cond and ;
-
-: rex.r ( m op -- n )
- extended? [ BIN: 00000100 bitor ] when ;
-
-: rex.b ( m op -- n )
- [ extended? [ BIN: 00000001 bitor ] when ] keep
- dup indirect? [
- index>> extended? [ BIN: 00000010 bitor ] when
- ] [
- drop
- ] if ;
-
-: rex-prefix ( reg r/m rex.w -- )
- #! Compile an AMD64 REX prefix.
- 2over rex.w? BIN: 01001000 BIN: 01000000 ?
- swap rex.r swap rex.b
- dup BIN: 01000000 = [ drop ] [ , ] if ;
-
-: 16-prefix ( reg r/m -- )
- [ register-16? ] either? [ HEX: 66 , ] when ;
-
-: prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ;
-
-: prefix-1 ( reg rex.w -- ) f swap prefix ;
-
-: short-operand ( reg rex.w n -- )
- #! Some instructions encode their single operand as part of
- #! the opcode.
- >r dupd prefix-1 reg-code r> + , ;
-
-: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
-
-: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
-
-: extended-opcode, ( opcode -- ) extended-opcode opcode, ;
-
-: opcode-or ( opcode mask -- opcode' )
- swap dup array?
- [ unclip-last rot bitor suffix ] [ bitor ] if ;
-
-: 1-operand ( op reg,rex.w,opcode -- )
- #! The 'reg' is not really a register, but a value for the
- #! 'reg' field of the mod-r/m byte.
- first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
-
-: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
- pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
-
-: immediate-1 ( imm dst reg,rex.w,opcode -- )
- immediate-operand-size-bit 1-operand 1, ;
-
-: immediate-4 ( imm dst reg,rex.w,opcode -- )
- immediate-operand-size-bit 1-operand 4, ;
-
-: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
- pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
-
-: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
- #! If imm is a byte, compile the opcode and the byte.
- #! Otherwise, set the 8-bit operand flag in the opcode, and
- #! compile the cell. The 'reg' is not really a register, but
- #! a value for the 'reg' field of the mod-r/m byte.
- pick fits-in-byte? [
- immediate-fits-in-size-bit immediate-1
- ] [
- immediate-4
- ] if ;
-
-: (2-operand) ( dst src op -- )
- >r 2dup t rex-prefix r> opcode,
- reg-code swap addressing ;
-
-: direction-bit ( dst src op -- dst' src' op' )
- pick register? [ BIN: 10 opcode-or swapd ] when ;
-
-: operand-size-bit ( dst src op -- dst' src' op' )
- over register-8? [ BIN: 1 opcode-or ] unless ;
-
-: 2-operand ( dst src op -- )
- #! Sets the opcode's direction bit. It is set if the
- #! destination is a direct register operand.
- 2over 16-prefix
- direction-bit
- operand-size-bit
- (2-operand) ;
-
-PRIVATE>
-
-: [] ( reg/displacement -- indirect )
- dup integer? [ >r f f f r> ] [ f f f ] if <indirect> ;
-
-: [+] ( reg displacement -- indirect )
- dup integer?
- [ dup zero? [ drop f ] when >r f f r> ]
- [ f f ] if
- <indirect> ;
-
-! Moving stuff
-GENERIC: PUSH ( op -- )
-M: register PUSH f HEX: 50 short-operand ;
-M: immediate PUSH HEX: 68 , 4, ;
-M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ;
-
-GENERIC: POP ( op -- )
-M: register POP f HEX: 58 short-operand ;
-M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
-
-! MOV where the src is immediate.
-GENERIC: (MOV-I) ( src dst -- )
-M: register (MOV-I) t HEX: b8 short-operand cell, ;
-M: operand (MOV-I)
- { BIN: 000 t HEX: c6 }
- pick byte? [ immediate-1 ] [ immediate-4 ] if ;
-
-GENERIC: MOV ( dst src -- )
-M: immediate MOV swap (MOV-I) ;
-M: word MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
-M: operand MOV HEX: 88 2-operand ;
-
-: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
-
-! Control flow
-GENERIC: JMP ( op -- )
-: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
-M: word JMP (JMP) rel-word ;
-M: label JMP (JMP) label-fixup ;
-M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
-
-GENERIC: CALL ( op -- )
-: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
-M: word CALL (CALL) rel-word ;
-M: label CALL (CALL) label-fixup ;
-M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
-
-GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
-M: word JUMPcc (JUMPcc) rel-word ;
-M: label JUMPcc (JUMPcc) label-fixup ;
-
-: JO ( dst -- ) HEX: 80 JUMPcc ;
-: JNO ( dst -- ) HEX: 81 JUMPcc ;
-: JB ( dst -- ) HEX: 82 JUMPcc ;
-: JAE ( dst -- ) HEX: 83 JUMPcc ;
-: JE ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
-: JNE ( dst -- ) HEX: 85 JUMPcc ;
-: JBE ( dst -- ) HEX: 86 JUMPcc ;
-: JA ( dst -- ) HEX: 87 JUMPcc ;
-: JS ( dst -- ) HEX: 88 JUMPcc ;
-: JNS ( dst -- ) HEX: 89 JUMPcc ;
-: JP ( dst -- ) HEX: 8a JUMPcc ;
-: JNP ( dst -- ) HEX: 8b JUMPcc ;
-: JL ( dst -- ) HEX: 8c JUMPcc ;
-: JGE ( dst -- ) HEX: 8d JUMPcc ;
-: JLE ( dst -- ) HEX: 8e JUMPcc ;
-: JG ( dst -- ) HEX: 8f JUMPcc ;
-
-: LEAVE ( -- ) HEX: c9 , ;
-: NOP ( -- ) HEX: 90 , ;
-
-: RET ( n -- )
- dup zero? [ drop HEX: c3 , ] [ HEX: C2 , 2, ] if ;
-
-! Arithmetic
-
-GENERIC: ADD ( dst src -- )
-M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
-M: operand ADD OCT: 000 2-operand ;
-
-GENERIC: OR ( dst src -- )
-M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
-M: operand OR OCT: 010 2-operand ;
-
-GENERIC: ADC ( dst src -- )
-M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
-M: operand ADC OCT: 020 2-operand ;
-
-GENERIC: SBB ( dst src -- )
-M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
-M: operand SBB OCT: 030 2-operand ;
-
-GENERIC: AND ( dst src -- )
-M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
-M: operand AND OCT: 040 2-operand ;
-
-GENERIC: SUB ( dst src -- )
-M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
-M: operand SUB OCT: 050 2-operand ;
-
-GENERIC: XOR ( dst src -- )
-M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
-M: operand XOR OCT: 060 2-operand ;
-
-GENERIC: CMP ( dst src -- )
-M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
-M: operand CMP OCT: 070 2-operand ;
-
-: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
-: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
-: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
-: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
-: DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
-: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
-
-: CDQ ( -- ) HEX: 99 , ;
-: CQO ( -- ) HEX: 48 , CDQ ;
-
-: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
-: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
-: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
-: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
-: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
-: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
-: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
-
-GENERIC: IMUL2 ( dst src -- )
-M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
-M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
-
-: MOVSX ( dst src -- )
- dup register-32? OCT: 143 OCT: 276 extended-opcode ?
- over register-16? [ BIN: 1 opcode-or ] when
- swapd
- (2-operand) ;
-
-! Conditional move
-: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
-
-: CMOVO ( dst src -- ) HEX: 40 MOVcc ;
-: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
-: CMOVB ( dst src -- ) HEX: 42 MOVcc ;
-: CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
-: CMOVE ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
-: CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
-: CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
-: CMOVA ( dst src -- ) HEX: 47 MOVcc ;
-: CMOVS ( dst src -- ) HEX: 48 MOVcc ;
-: CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
-: CMOVP ( dst src -- ) HEX: 4a MOVcc ;
-: CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
-: CMOVL ( dst src -- ) HEX: 4c MOVcc ;
-: CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
-: CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
-: CMOVG ( dst src -- ) HEX: 4f MOVcc ;
-
-! CPU Identification
-
-: CPUID ( -- ) HEX: a2 extended-opcode, ;
-
-! x87 Floating Point Unit
-
-: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
-: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
-
-: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
-: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
-
-! SSE multimedia instructions
-
-<PRIVATE
-
-: direction-bit-sse ( dst src op1 -- dst' src' op1' )
- pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
-
-: 2-operand-sse ( dst src op1 op2 -- )
- , direction-bit-sse extended-opcode (2-operand) ;
-
-: 2-operand-int/sse ( dst src op1 op2 -- )
- , swapd extended-opcode (2-operand) ;
-
-PRIVATE>
-
-: MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ;
-: MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ;
-: ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-sse ;
-: MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-sse ;
-: SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-sse ;
-: DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-sse ;
-: SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-sse ;
-: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-sse ;
-: COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-sse ;
-
-: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ;
-: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-sse ;
-
-: CVTSI2SD ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ;
-: CVTSD2SI ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ;
-: CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ;
+++ /dev/null
-Sampo Vuori
+++ /dev/null
-! Cairo "Hello World" demo
-! Copyright (c) 2007 Sampo Vuori
-! License: http://factorcode.org/license.txt
-!
-! This example is an adaptation of the following cairo sample code:
-! http://cairographics.org/samples/text/
-
-
-USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
- ui.gadgets opengl.gl ;
-
-IN: cairo-demo
-
-
-: make-image-array ( -- array )
- 384 256 4 * * <byte-array> ;
-
-: convert-array-to-surface ( array -- cairo_surface_t )
- CAIRO_FORMAT_ARGB32 384 256 over 4 *
- cairo_image_surface_create_for_data ;
-
-
-TUPLE: cairo-gadget image-array cairo-t ;
-
-M: cairo-gadget draw-gadget* ( gadget -- )
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
- cairo-gadget-image-array glDrawPixels ;
-
-: create-surface ( gadget -- cairo_surface_t )
- make-image-array
- [ swap set-cairo-gadget-image-array ] keep
- convert-array-to-surface ;
-
-: init-cairo ( gadget -- cairo_t )
- create-surface cairo_create ;
-
-M: cairo-gadget pref-dim* drop { 384 256 0 } ;
-
-: draw-hello-world ( gadget -- )
- cairo-gadget-cairo-t
- dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face
- dup 90.0 cairo_set_font_size
- dup 10.0 135.0 cairo_move_to
- dup "Hello" cairo_show_text
- dup 70.0 165.0 cairo_move_to
- dup "World" cairo_text_path
- dup 0.5 0.5 1 cairo_set_source_rgb
- dup cairo_fill_preserve
- dup 0 0 0 cairo_set_source_rgb
- dup 2.56 cairo_set_line_width
- dup cairo_stroke
- dup 1 0.2 0.2 0.6 cairo_set_source_rgba
- dup 10.0 135.0 5.12 0 pi 2 * cairo_arc
- dup cairo_close_path
- dup 70.0 165.0 5.12 0 pi 2 * cairo_arc
- cairo_fill ;
-
-M: cairo-gadget graft* ( gadget -- )
- dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
-
-M: cairo-gadget ungraft* ( gadget -- )
- cairo-gadget-cairo-t cairo_destroy ;
-
-: <cairo-gadget> ( -- gadget )
- cairo-gadget construct-gadget ;
-
-: run ( -- )
- [
- <cairo-gadget> "Hello World from Factor!" open-window
- ] with-ui ;
-
-MAIN: run
+++ /dev/null
-Sampo Vuori
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: cairo.ffi kernel accessors sequences
-namespaces fry continuations destructors ;
-IN: cairo
-
-TUPLE: cairo-t alien ;
-C: <cairo-t> cairo-t
-M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
-
-TUPLE: cairo-surface-t alien ;
-C: <cairo-surface-t> cairo-surface-t
-M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
-
-: check-cairo ( cairo_status_t -- )
- dup CAIRO_STATUS_SUCCESS = [ drop ]
- [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
-
-SYMBOL: cairo
-: cr ( -- cairo ) cairo get ;
-
-: (with-cairo) ( cairo-t quot -- )
- >r alien>> cairo r> [ cr cairo_status check-cairo ]
- compose with-variable ; inline
-
-: with-cairo ( cairo quot -- )
- >r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
-
-: (with-surface) ( cairo-surface-t quot -- )
- >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
-
-: with-surface ( cairo_surface quot -- )
- >r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
-
-: with-cairo-from-surface ( cairo_surface quot -- )
- '[ cairo_create , with-cairo ] with-surface ; inline
+++ /dev/null
-! Copyright (c) 2007 Sampo Vuori
-! Copyright (c) 2008 Matthew Willis
-!
-! Adapted from cairo.h, version 1.5.14
-! License: http://factorcode.org/license.txt
-
-USING: system combinators alien alien.syntax kernel
-alien.c-types accessors sequences arrays ui.gadgets ;
-
-IN: cairo.ffi
-<< "cairo" {
- { [ os winnt? ] [ "libcairo-2.dll" ] }
- { [ os macosx? ] [ "libcairo.dylib" ] }
- { [ os unix? ] [ "libcairo.so.2" ] }
-} cond "cdecl" add-library >>
-
-LIBRARY: cairo
-
-FUNCTION: int cairo_version ( ) ;
-FUNCTION: char* cairo_version_string ( ) ;
-
-TYPEDEF: int cairo_bool_t
-
-! I am leaving these and other void* types as opaque structures
-TYPEDEF: void* cairo_t
-TYPEDEF: void* cairo_surface_t
-
-C-STRUCT: cairo_matrix_t
- { "double" "xx" }
- { "double" "yx" }
- { "double" "xy" }
- { "double" "yy" }
- { "double" "x0" }
- { "double" "y0" } ;
-
-TYPEDEF: void* cairo_pattern_t
-
-TYPEDEF: void* cairo_destroy_func_t
-: cairo-destroy-func ( quot -- callback )
- >r "void" { "void*" } "cdecl" r> alien-callback ; inline
-
-! See cairo.h for details
-C-STRUCT: cairo_user_data_key_t
- { "int" "unused" } ;
-
-TYPEDEF: int cairo_status_t
-C-ENUM:
- CAIRO_STATUS_SUCCESS
- CAIRO_STATUS_NO_MEMORY
- CAIRO_STATUS_INVALID_RESTORE
- CAIRO_STATUS_INVALID_POP_GROUP
- CAIRO_STATUS_NO_CURRENT_POINT
- CAIRO_STATUS_INVALID_MATRIX
- CAIRO_STATUS_INVALID_STATUS
- CAIRO_STATUS_NULL_POINTER
- CAIRO_STATUS_INVALID_STRING
- CAIRO_STATUS_INVALID_PATH_DATA
- CAIRO_STATUS_READ_ERROR
- CAIRO_STATUS_WRITE_ERROR
- CAIRO_STATUS_SURFACE_FINISHED
- CAIRO_STATUS_SURFACE_TYPE_MISMATCH
- CAIRO_STATUS_PATTERN_TYPE_MISMATCH
- CAIRO_STATUS_INVALID_CONTENT
- CAIRO_STATUS_INVALID_FORMAT
- CAIRO_STATUS_INVALID_VISUAL
- CAIRO_STATUS_FILE_NOT_FOUND
- CAIRO_STATUS_INVALID_DASH
- CAIRO_STATUS_INVALID_DSC_COMMENT
- CAIRO_STATUS_INVALID_INDEX
- CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
- CAIRO_STATUS_TEMP_FILE_ERROR
- CAIRO_STATUS_INVALID_STRIDE ;
-
-TYPEDEF: int cairo_content_t
-: CAIRO_CONTENT_COLOR HEX: 1000 ;
-: CAIRO_CONTENT_ALPHA HEX: 2000 ;
-: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
-
-TYPEDEF: void* cairo_write_func_t
-: cairo-write-func ( quot -- callback )
- >r "cairo_status_t" { "void*" "uchar*" "int" }
- "cdecl" r> alien-callback ; inline
-
-TYPEDEF: void* cairo_read_func_t
-: cairo-read-func ( quot -- callback )
- >r "cairo_status_t" { "void*" "uchar*" "int" }
- "cdecl" r> alien-callback ; inline
-
-! Functions for manipulating state objects
-FUNCTION: cairo_t*
-cairo_create ( cairo_surface_t* target ) ;
-
-FUNCTION: cairo_t*
-cairo_reference ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_destroy ( cairo_t* cr ) ;
-
-FUNCTION: uint
-cairo_get_reference_count ( cairo_t* cr ) ;
-
-FUNCTION: void*
-cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-FUNCTION: void
-cairo_save ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_restore ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_push_group ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pop_group ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_pop_group_to_source ( cairo_t* cr ) ;
-
-! Modify state
-TYPEDEF: int cairo_operator_t
-C-ENUM:
- CAIRO_OPERATOR_CLEAR
-
- CAIRO_OPERATOR_SOURCE
- CAIRO_OPERATOR_OVER
- CAIRO_OPERATOR_IN
- CAIRO_OPERATOR_OUT
- CAIRO_OPERATOR_ATOP
-
- CAIRO_OPERATOR_DEST
- CAIRO_OPERATOR_DEST_OVER
- CAIRO_OPERATOR_DEST_IN
- CAIRO_OPERATOR_DEST_OUT
- CAIRO_OPERATOR_DEST_ATOP
-
- CAIRO_OPERATOR_XOR
- CAIRO_OPERATOR_ADD
- CAIRO_OPERATOR_SATURATE ;
-
-FUNCTION: void
-cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ;
-
-FUNCTION: void
-cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ;
-
-FUNCTION: void
-cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ;
-
-FUNCTION: void
-cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ;
-
-FUNCTION: void
-cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ;
-
-FUNCTION: void
-cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
-
-TYPEDEF: int cairo_antialias_t
-C-ENUM:
- CAIRO_ANTIALIAS_DEFAULT
- CAIRO_ANTIALIAS_NONE
- CAIRO_ANTIALIAS_GRAY
- CAIRO_ANTIALIAS_SUBPIXEL ;
-
-FUNCTION: void
-cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
-
-TYPEDEF: int cairo_fill_rule_t
-C-ENUM:
- CAIRO_FILL_RULE_WINDING
- CAIRO_FILL_RULE_EVEN_ODD ;
-
-FUNCTION: void
-cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
-
-FUNCTION: void
-cairo_set_line_width ( cairo_t* cr, double width ) ;
-
-TYPEDEF: int cairo_line_cap_t
-C-ENUM:
- CAIRO_LINE_CAP_BUTT
- CAIRO_LINE_CAP_ROUND
- CAIRO_LINE_CAP_SQUARE ;
-
-FUNCTION: void
-cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
-
-TYPEDEF: int cairo_line_join_t
-C-ENUM:
- CAIRO_LINE_JOIN_MITER
- CAIRO_LINE_JOIN_ROUND
- CAIRO_LINE_JOIN_BEVEL ;
-
-FUNCTION: void
-cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ;
-
-FUNCTION: void
-cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ;
-
-FUNCTION: void
-cairo_set_miter_limit ( cairo_t* cr, double limit ) ;
-
-FUNCTION: void
-cairo_translate ( cairo_t* cr, double tx, double ty ) ;
-
-FUNCTION: void
-cairo_scale ( cairo_t* cr, double sx, double sy ) ;
-
-FUNCTION: void
-cairo_rotate ( cairo_t* cr, double angle ) ;
-
-FUNCTION: void
-cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_identity_matrix ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ;
-
-FUNCTION: void
-cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ;
-
-FUNCTION: void
-cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ;
-
-FUNCTION: void
-cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
-
-! Path creation functions
-FUNCTION: void
-cairo_new_path ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_move_to ( cairo_t* cr, double x, double y ) ;
-
-FUNCTION: void
-cairo_new_sub_path ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_line_to ( cairo_t* cr, double x, double y ) ;
-
-FUNCTION: void
-cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ;
-
-FUNCTION: void
-cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
-
-FUNCTION: void
-cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
-
-FUNCTION: void
-cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ;
-
-FUNCTION: void
-cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ;
-
-FUNCTION: void
-cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ;
-
-FUNCTION: void
-cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ;
-
-FUNCTION: void
-cairo_close_path ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-! Painting functions
-FUNCTION: void
-cairo_paint ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ;
-
-FUNCTION: void
-cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ;
-
-FUNCTION: void
-cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ;
-
-FUNCTION: void
-cairo_stroke ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_stroke_preserve ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_fill ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_fill_preserve ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_copy_page ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_show_page ( cairo_t* cr ) ;
-
-! Insideness testing
-FUNCTION: cairo_bool_t
-cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
-
-FUNCTION: cairo_bool_t
-cairo_in_fill ( cairo_t* cr, double x, double y ) ;
-
-! Rectangular extents
-FUNCTION: void
-cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-FUNCTION: void
-cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-! Clipping
-FUNCTION: void
-cairo_reset_clip ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_clip ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_clip_preserve ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-C-STRUCT: cairo_rectangle_t
- { "double" "x" }
- { "double" "y" }
- { "double" "width" }
- { "double" "height" } ;
-
-C-STRUCT: cairo_rectangle_list_t
- { "cairo_status_t" "status" }
- { "cairo_rectangle_t*" "rectangles" }
- { "int" "num_rectangles" } ;
-
-FUNCTION: cairo_rectangle_list_t*
-cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ;
-
-! Font/Text functions
-
-TYPEDEF: void* cairo_scaled_font_t
-
-TYPEDEF: void* cairo_font_face_t
-
-C-STRUCT: cairo_glyph_t
- { "ulong" "index" }
- { "double" "x" }
- { "double" "y" } ;
-
-C-STRUCT: cairo_text_extents_t
- { "double" "x_bearing" }
- { "double" "y_bearing" }
- { "double" "width" }
- { "double" "height" }
- { "double" "x_advance" }
- { "double" "y_advance" } ;
-
-C-STRUCT: cairo_font_extents_t
- { "double" "ascent" }
- { "double" "descent" }
- { "double" "height" }
- { "double" "max_x_advance" }
- { "double" "max_y_advance" } ;
-
-TYPEDEF: int cairo_font_slant_t
-C-ENUM:
- CAIRO_FONT_SLANT_NORMAL
- CAIRO_FONT_SLANT_ITALIC
- CAIRO_FONT_SLANT_OBLIQUE ;
-
-TYPEDEF: int cairo_font_weight_t
-C-ENUM:
- CAIRO_FONT_WEIGHT_NORMAL
- CAIRO_FONT_WEIGHT_BOLD ;
-
-TYPEDEF: int cairo_subpixel_order_t
-C-ENUM:
- CAIRO_SUBPIXEL_ORDER_DEFAULT
- CAIRO_SUBPIXEL_ORDER_RGB
- CAIRO_SUBPIXEL_ORDER_BGR
- CAIRO_SUBPIXEL_ORDER_VRGB
- CAIRO_SUBPIXEL_ORDER_VBGR ;
-
-TYPEDEF: int cairo_hint_style_t
-C-ENUM:
- CAIRO_HINT_STYLE_DEFAULT
- CAIRO_HINT_STYLE_NONE
- CAIRO_HINT_STYLE_SLIGHT
- CAIRO_HINT_STYLE_MEDIUM
- CAIRO_HINT_STYLE_FULL ;
-
-TYPEDEF: int cairo_hint_metrics_t
-C-ENUM:
- CAIRO_HINT_METRICS_DEFAULT
- CAIRO_HINT_METRICS_OFF
- CAIRO_HINT_METRICS_ON ;
-
-TYPEDEF: void* cairo_font_options_t
-
-FUNCTION: cairo_font_options_t*
-cairo_font_options_create ( ) ;
-
-FUNCTION: cairo_font_options_t*
-cairo_font_options_copy ( cairo_font_options_t* original ) ;
-
-FUNCTION: void
-cairo_font_options_destroy ( cairo_font_options_t* options ) ;
-
-FUNCTION: cairo_status_t
-cairo_font_options_status ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
-
-FUNCTION: cairo_bool_t
-cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
-
-FUNCTION: ulong
-cairo_font_options_hash ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ;
-
-FUNCTION: cairo_antialias_t
-cairo_font_options_get_antialias ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ;
-
-FUNCTION: cairo_subpixel_order_t
-cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ;
-
-FUNCTION: cairo_hint_style_t
-cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ;
-
-FUNCTION: cairo_hint_metrics_t
-cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
-
-! This interface is for dealing with text as text, not caring about the
-! font object inside the the cairo_t.
-
-FUNCTION: void
-cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
-
-FUNCTION: void
-cairo_set_font_size ( cairo_t* cr, double size ) ;
-
-FUNCTION: void
-cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ;
-
-FUNCTION: cairo_font_face_t*
-cairo_get_font_face ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: cairo_scaled_font_t*
-cairo_get_scaled_font ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_show_text ( cairo_t* cr, char* utf8 ) ;
-
-FUNCTION: void
-cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
-
-FUNCTION: void
-cairo_text_path ( cairo_t* cr, char* utf8 ) ;
-
-FUNCTION: void
-cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
-
-FUNCTION: void
-cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ;
-
-! Generic identifier for a font style
-
-FUNCTION: cairo_font_face_t*
-cairo_font_face_reference ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: void
-cairo_font_face_destroy ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: uint
-cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: cairo_status_t
-cairo_font_face_status ( cairo_font_face_t* font_face ) ;
-
-TYPEDEF: int cairo_font_type_t
-C-ENUM:
- CAIRO_FONT_TYPE_TOY
- CAIRO_FONT_TYPE_FT
- CAIRO_FONT_TYPE_WIN32
- CAIRO_FONT_TYPE_QUARTZ ;
-
-FUNCTION: cairo_font_type_t
-cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: void*
-cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-! Portable interface to general font features.
-
-FUNCTION: cairo_scaled_font_t*
-cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ;
-
-FUNCTION: cairo_scaled_font_t*
-cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: void
-cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: uint
-cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: cairo_status_t
-cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: cairo_font_type_t
-cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: void*
-cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-FUNCTION: void
-cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
-
-FUNCTION: cairo_font_face_t*
-cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: void
-cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ;
-
-FUNCTION: void
-cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ;
-
-FUNCTION: void
-cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ;
-
-! Query functions
-
-FUNCTION: cairo_operator_t
-cairo_get_operator ( cairo_t* cr ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_get_source ( cairo_t* cr ) ;
-
-FUNCTION: double
-cairo_get_tolerance ( cairo_t* cr ) ;
-
-FUNCTION: cairo_antialias_t
-cairo_get_antialias ( cairo_t* cr ) ;
-
-FUNCTION: cairo_bool_t
-cairo_has_current_point ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ;
-
-FUNCTION: cairo_fill_rule_t
-cairo_get_fill_rule ( cairo_t* cr ) ;
-
-FUNCTION: double
-cairo_get_line_width ( cairo_t* cr ) ;
-
-FUNCTION: cairo_line_cap_t
-cairo_get_line_cap ( cairo_t* cr ) ;
-
-FUNCTION: cairo_line_join_t
-cairo_get_line_join ( cairo_t* cr ) ;
-
-FUNCTION: double
-cairo_get_miter_limit ( cairo_t* cr ) ;
-
-FUNCTION: int
-cairo_get_dash_count ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ;
-
-FUNCTION: void
-cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_get_target ( cairo_t* cr ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_get_group_target ( cairo_t* cr ) ;
-
-TYPEDEF: int cairo_path_data_type_t
-C-ENUM:
- CAIRO_PATH_MOVE_TO
- CAIRO_PATH_LINE_TO
- CAIRO_PATH_CURVE_TO
- CAIRO_PATH_CLOSE_PATH ;
-
-! NEED TO DO UNION HERE
-C-STRUCT: cairo_path_data_t-point
- { "double" "x" }
- { "double" "y" } ;
-
-C-STRUCT: cairo_path_data_t-header
- { "cairo_path_data_type_t" "type" }
- { "int" "length" } ;
-
-C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
-
-C-STRUCT: cairo_path_t
- { "cairo_status_t" "status" }
- { "cairo_path_data_t*" "data" }
- { "int" "num_data" } ;
-
-FUNCTION: cairo_path_t*
-cairo_copy_path ( cairo_t* cr ) ;
-
-FUNCTION: cairo_path_t*
-cairo_copy_path_flat ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ;
-
-FUNCTION: void
-cairo_path_destroy ( cairo_path_t* path ) ;
-
-! Error status queries
-
-FUNCTION: cairo_status_t
-cairo_status ( cairo_t* cr ) ;
-
-FUNCTION: char*
-cairo_status_to_string ( cairo_status_t status ) ;
-
-! Surface manipulation
-
-FUNCTION: cairo_surface_t*
-cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_surface_reference ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_finish ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_destroy ( cairo_surface_t* surface ) ;
-
-FUNCTION: uint
-cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_status ( cairo_surface_t* surface ) ;
-
-TYPEDEF: int cairo_surface_type_t
-C-ENUM:
- CAIRO_SURFACE_TYPE_IMAGE
- CAIRO_SURFACE_TYPE_PDF
- CAIRO_SURFACE_TYPE_PS
- CAIRO_SURFACE_TYPE_XLIB
- CAIRO_SURFACE_TYPE_XCB
- CAIRO_SURFACE_TYPE_GLITZ
- CAIRO_SURFACE_TYPE_QUARTZ
- CAIRO_SURFACE_TYPE_WIN32
- CAIRO_SURFACE_TYPE_BEOS
- CAIRO_SURFACE_TYPE_DIRECTFB
- CAIRO_SURFACE_TYPE_SVG
- CAIRO_SURFACE_TYPE_OS2
- CAIRO_SURFACE_TYPE_WIN32_PRINTING
- CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ;
-
-FUNCTION: cairo_surface_type_t
-cairo_surface_get_type ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_content_t
-cairo_surface_get_content ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
-
-FUNCTION: void*
-cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-FUNCTION: void
-cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_surface_flush ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_mark_dirty ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ;
-
-FUNCTION: void
-cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ;
-
-FUNCTION: void
-cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ;
-
-FUNCTION: void
-cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ;
-
-FUNCTION: void
-cairo_surface_copy_page ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_show_page ( cairo_surface_t* surface ) ;
-
-! Image-surface functions
-
-TYPEDEF: int cairo_format_t
-C-ENUM:
- CAIRO_FORMAT_ARGB32
- CAIRO_FORMAT_RGB24
- CAIRO_FORMAT_A8
- CAIRO_FORMAT_A1
- CAIRO_FORMAT_RGB16_565 ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create ( cairo_format_t format, int width, int height ) ;
-
-FUNCTION: int
-cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
-
-FUNCTION: uchar*
-cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_format_t
-cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
-
-FUNCTION: int
-cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
-
-FUNCTION: int
-cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
-
-FUNCTION: int
-cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create_from_png ( char* filename ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
-
-! Pattern creation functions
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_rgb ( double red, double green, double blue ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_reference ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: void
-cairo_pattern_destroy ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: uint
-cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_status ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: void*
-cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-TYPEDEF: int cairo_pattern_type_t
-C-ENUM:
- CAIRO_PATTERN_TYPE_SOLID
- CAIRO_PATTERN_TYPE_SURFACE
- CAIRO_PATTERN_TYPE_LINEAR
- CAIRO_PATTERN_TYPE_RADIA ;
-
-FUNCTION: cairo_pattern_type_t
-cairo_pattern_get_type ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: void
-cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ;
-
-FUNCTION: void
-cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ;
-
-FUNCTION: void
-cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
-
-TYPEDEF: int cairo_extend_t
-C-ENUM:
- CAIRO_EXTEND_NONE
- CAIRO_EXTEND_REPEAT
- CAIRO_EXTEND_REFLECT
- CAIRO_EXTEND_PAD ;
-
-FUNCTION: void
-cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
-
-FUNCTION: cairo_extend_t
-cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
-
-TYPEDEF: int cairo_filter_t
-C-ENUM:
- CAIRO_FILTER_FAST
- CAIRO_FILTER_GOOD
- CAIRO_FILTER_BEST
- CAIRO_FILTER_NEAREST
- CAIRO_FILTER_BILINEAR
- CAIRO_FILTER_GAUSSIAN ;
-
-FUNCTION: void
-cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ;
-
-FUNCTION: cairo_filter_t
-cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ;
-
-! Matrix functions
-
-FUNCTION: void
-cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ;
-
-FUNCTION: void
-cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
-
-FUNCTION: void
-cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
-
-FUNCTION: void
-cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ;
-
-FUNCTION: void
-cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
-
-FUNCTION: void
-cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
-
-FUNCTION: void
-cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ;
-
-FUNCTION: cairo_status_t
-cairo_matrix_invert ( cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ;
-
-FUNCTION: void
-cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ;
-
-FUNCTION: void
-cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ;
-
-! Functions to be used while debugging (not intended for use in production code)
-FUNCTION: void
-cairo_debug_reset_static_data ( ) ;
+++ /dev/null
-! Copyright (C) 2008 Matthew Willis.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences math opengl.gadgets kernel
-byte-arrays cairo.ffi cairo io.backend
-ui.gadgets accessors opengl.gl
-arrays ;
-
-IN: cairo.gadgets
-
-: width>stride ( width -- stride ) 4 * ;
-
-: copy-cairo ( dim quot -- byte-array )
- >r first2 over width>stride
- [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
- [ cairo_image_surface_create_for_data ] 3bi
- r> with-cairo-from-surface ; inline
-
-TUPLE: cairo-gadget < texture-gadget dim quot ;
-
-: <cairo-gadget> ( dim quot -- gadget )
- cairo-gadget construct-gadget
- swap >>quot
- swap >>dim ;
-
-M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
-
-: render-cairo ( dim quot -- bytes format )
- >r 2^-bounds r> copy-cairo GL_BGRA ; inline
-
-! M: cairo-gadget render*
-! [ dim>> dup ] [ quot>> ] bi
-! render-cairo render-bytes* ;
-
-! maybe also texture>png
-! : cairo>png ( gadget path -- )
-! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
-! [ height>> ] tri over width>stride
-! cairo_image_surface_create_for_data
-! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
-
-: copy-surface ( surface -- )
- cr swap 0 0 cairo_set_source_surface
- cr cairo_paint ;
-
-TUPLE: png-gadget < texture-gadget path ;
-: <png> ( path -- gadget )
- png-gadget construct-gadget
- swap >>path ;
-
-M: png-gadget render*
- path>> normalize-path cairo_image_surface_create_from_png
- [ cairo_image_surface_get_width ]
- [ cairo_image_surface_get_height 2array dup 2^-bounds ]
- [ [ copy-surface ] curry copy-cairo ] tri
- GL_BGRA render-bytes* ;
-
-M: png-gadget cache-key* path>> ;
+++ /dev/null
-! Copyright (C) 2008 Matthew Willis
-! See http://factorcode.org/license.txt for BSD license.
-!
-! these samples are a subset of the samples on
-! http://cairographics.org/samples/
-USING: cairo cairo.ffi locals math.constants math
-io.backend kernel alien.c-types libc namespaces ;
-
-IN: cairo.samples
-
-:: arc ( -- )
- [let | xc [ 128.0 ]
- yc [ 128.0 ]
- radius [ 100.0 ]
- angle1 [ pi 1/4 * ]
- angle2 [ pi ] |
- cr 10.0 cairo_set_line_width
- cr xc yc radius angle1 angle2 cairo_arc
- cr cairo_stroke
-
- ! draw helping lines
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 6.0 cairo_set_line_width
-
- cr xc yc 10.0 0 2 pi * cairo_arc
- cr cairo_fill
-
- cr xc yc radius angle1 angle1 cairo_arc
- cr xc yc cairo_line_to
- cr xc yc radius angle2 angle2 cairo_arc
- cr xc yc cairo_line_to
- cr cairo_stroke
- ] ;
-
-: clip ( -- )
- cr 128 128 76.8 0 2 pi * cairo_arc
- cr cairo_clip
- cr cairo_new_path
-
- cr 0 0 256 256 cairo_rectangle
- cr cairo_fill
- cr 0 1 0 cairo_set_source_rgb
- cr 0 0 cairo_move_to
- cr 256 256 cairo_line_to
- cr 256 0 cairo_move_to
- cr 0 256 cairo_line_to
- cr 10 cairo_set_line_width
- cr cairo_stroke ;
-
-:: clip-image ( -- )
- [let* | png [ "resource:misc/icons/Factor_128x128.png"
- normalize-path cairo_image_surface_create_from_png ]
- w [ png cairo_image_surface_get_width ]
- h [ png cairo_image_surface_get_height ] |
- cr 128 128 76.8 0 2 pi * cairo_arc
- cr cairo_clip
- cr cairo_new_path
-
- cr 192.0 w / 192.0 h / cairo_scale
- cr png 32 32 cairo_set_source_surface
- cr cairo_paint
- png cairo_surface_destroy
- ] ;
-
-:: dash ( -- )
- [let | dashes [ { 50 10 10 10 } >c-double-array ]
- ndash [ 4 ] |
- cr dashes ndash -50 cairo_set_dash
- cr 10 cairo_set_line_width
- cr 128.0 25.6 cairo_move_to
- cr 230.4 230.4 cairo_line_to
- cr -102.4 0 cairo_rel_line_to
- cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
- cr cairo_stroke
- ] ;
-
-:: gradient ( -- )
- [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
- radial [ 115.2 102.4 25.6 102.4 102.4 128.0
- cairo_pattern_create_radial ] |
- pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
- pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
- cr 0 0 256 256 cairo_rectangle
- cr pat cairo_set_source
- cr cairo_fill
- pat cairo_pattern_destroy
-
- radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
- radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
- cr radial cairo_set_source
- cr 128.0 128.0 76.8 0 2 pi * cairo_arc
- cr cairo_fill
- radial cairo_pattern_destroy
- ] ;
-
-: text ( -- )
- cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
- cairo_select_font_face
- cr 50 cairo_set_font_size
- cr 10 135 cairo_move_to
- cr "Hello" cairo_show_text
-
- cr 70 165 cairo_move_to
- cr "factor" cairo_text_path
- cr 0.5 0.5 1 cairo_set_source_rgb
- cr cairo_fill_preserve
- cr 0 0 0 cairo_set_source_rgb
- cr 2.56 cairo_set_line_width
- cr cairo_stroke
-
- ! draw helping lines
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 10 135 5.12 0 2 pi * cairo_arc
- cr cairo_close_path
- cr 70 165 5.12 0 2 pi * cairo_arc
- cr cairo_fill ;
-
-: utf8 ( -- )
- cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
- cairo_select_font_face
- cr 50 cairo_set_font_size
- "cairo_text_extents_t" malloc-object
- cr "日本語" pick cairo_text_extents
- cr over
- [ cairo_text_extents_t-width 2 / ]
- [ cairo_text_extents_t-x_bearing ] bi +
- 128 swap - pick
- [ cairo_text_extents_t-height 2 / ]
- [ cairo_text_extents_t-y_bearing ] bi +
- 128 swap - cairo_move_to
- free
- cr "日本語" cairo_show_text
-
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 6 cairo_set_line_width
- cr 128 0 cairo_move_to
- cr 0 256 cairo_rel_line_to
- cr 0 128 cairo_move_to
- cr 256 0 cairo_rel_line_to
- cr cairo_stroke ;
-
- USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
- : samples ( -- )
- { arc clip clip-image dash gradient text utf8 }
- [ { 256 256 } swap 1quotation <cairo-gadget> gadget. ] each ;
-
- MAIN: samples
+++ /dev/null
-Cairo graphics library binding
--- /dev/null
+
+USING: kernel namespaces sequences
+ io io.files io.launcher io.encodings.ascii
+ bake builder.util
+ accessors vars
+ math.parser ;
+
+IN: size-of
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: headers
+
+: include-headers ( -- seq )
+ headers> [ `{ "#include <" , ">" } to-string ] map ;
+
+: size-of-c-program ( type -- lines )
+ `{
+ "#include <stdio.h>"
+ include-headers
+ { "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" }
+ }
+ to-strings ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: c-file ( -- path ) "size-of.c" temp-file ;
+
+: exe ( -- path ) "size-of" temp-file ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: size-of ( type -- n )
+ size-of-c-program c-file ascii set-file-lines
+
+ { "gcc" c-file "-o" exe } to-strings
+ [ "Error compiling generated C program" print ] run-or-bail
+
+ exe ascii <process-reader> contents string>number ;
\ No newline at end of file
include vm/Config.macosx
include vm/Config.ppc
+CFLAGS += -arch ppc
#WIN64_PATH=/k/MinGW/win64/bin
-WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
+#WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
CC=$(WIN64_PATH)-gcc.exe
WINDRES=$(WIN64_PATH)-windres.exe
include vm/Config.windows.nt
/* :tabSize=2:indentSize=2:noTabs=true:
Copyright (C) 1989-94 Massachusetts Institute of Technology
-Portions copyright (C) 2004-2007 Slava Pestov
+Portions copyright (C) 2004-2008 Slava Pestov
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
* - Remove unused functions
* - Add local variable GC root recording
* - Remove s48 prefix from function names
+ * - Various fixes for Win64
*/
#include "master.h"
/* all below allocate memory */
FOO_TO_BIGNUM(cell,CELL,CELL)
FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL)
-FOO_TO_BIGNUM(long,long,unsigned long)
-FOO_TO_BIGNUM(ulong,unsigned long,unsigned long)
FOO_TO_BIGNUM(long_long,s64,u64)
FOO_TO_BIGNUM(ulong_long,u64,u64)
/* all of the below allocate memory */
BIGNUM_TO_FOO(cell,CELL,CELL);
BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL);
-BIGNUM_TO_FOO(long,long,unsigned long)
-BIGNUM_TO_FOO(ulong,unsigned long,unsigned long)
BIGNUM_TO_FOO(long_long,s64,u64)
BIGNUM_TO_FOO(ulong_long,u64,u64)
bignum_digit_type digit;
int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
if (odd_bits > 0)
- DTB_WRITE_DIGIT (1L << odd_bits);
+ DTB_WRITE_DIGIT ((F_FIXNUM)1 << odd_bits);
while (start < scan)
{
if (significand == 0)
bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
- bignum_digit_type mask = ((1L << shift_right) - 1);
+ bignum_digit_type mask = (((CELL)1 << shift_right) - 1);
while (scan_source < end_source)
{
digit = (*scan_source++);
bignum_digit_type digit;
bignum_digit_type carry = 0;
int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
- bignum_digit_type mask = ((1L << shift_right) - 1);
+ bignum_digit_type mask = (((F_FIXNUM)1 << shift_right) - 1);
while (start < scan)
{
digit = (*--scan);
/* allocates memory */
bignum_type
-bignum_arithmetic_shift(bignum_type arg1, long n)
+bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n)
{
if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
/* ash for the magnitude */
/* assume arg1 is a big number, n is a long */
bignum_type
-bignum_magnitude_ash(bignum_type arg1, long n)
+bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n)
{
bignum_type result = NULL;
bignum_digit_type *scan1;
bignum_digit_type *scanr;
bignum_digit_type *end;
- long digit_offset,bit_offset;
+ F_FIXNUM digit_offset,bit_offset;
if (BIGNUM_ZERO_P (arg1)) return (arg1);
while (scanr < endr) {
digit1 = (scan1 < end1) ? *scan1++ : 0;
digit2 = (scan2 < end2) ? *scan2++ : 0;
- /*
- fprintf(stderr, "[pospos op = %d, i = %ld, d1 = %lx, d2 = %lx]\n",
- op, endr - scanr, digit1, digit2);
- */
*scanr++ = (op == AND_OP) ? digit1 & digit2 :
(op == IOR_OP) ? digit1 | digit2 :
digit1 ^ digit2;
return (BIGNUM_ZERO ());
if (n_digits == 1)
{
- long digit = ((long) ((*producer) (0)));
- return (long_to_bignum (negative_p ? (- digit) : digit));
+ F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0)));
+ return (fixnum_to_bignum (negative_p ? (- digit) : digit));
}
{
bignum_length_type length;
bignum_type bignum_remainder(bignum_type, bignum_type);
DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM);
DLLEXPORT bignum_type cell_to_bignum(CELL);
-DLLEXPORT bignum_type long_to_bignum(long);
DLLEXPORT bignum_type long_long_to_bignum(s64 n);
DLLEXPORT bignum_type ulong_long_to_bignum(u64 n);
-DLLEXPORT bignum_type ulong_to_bignum(unsigned long);
F_FIXNUM bignum_to_fixnum(bignum_type);
CELL bignum_to_cell(bignum_type);
-long bignum_to_long(bignum_type);
-unsigned long bignum_to_ulong(bignum_type);
s64 bignum_to_long_long(bignum_type);
u64 bignum_to_ulong_long(bignum_type);
bignum_type double_to_bignum(double);
/* Added bitwise operators. */
DLLEXPORT bignum_type bignum_bitwise_not(bignum_type),
- bignum_arithmetic_shift(bignum_type, long),
+ bignum_arithmetic_shift(bignum_type, F_FIXNUM),
bignum_bitwise_and(bignum_type, bignum_type),
bignum_bitwise_ior(bignum_type, bignum_type),
bignum_bitwise_xor(bignum_type, bignum_type);
void bignum_destructive_copy(bignum_type, bignum_type);
/* Added for bitwise operations. */
-bignum_type bignum_magnitude_ash(bignum_type arg1, long n);
+bignum_type bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n);
bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type);
bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type);
bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type);
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
{
+ if(frame->size == 0)
+ critical_error("Stack frame has zero size",(CELL)frame);
return (F_STACK_FRAME *)((CELL)frame - frame->size);
}
/* Note that the XT is passed to the quotation in r11 */
#define CALL_OR_JUMP_QUOT \
- lwz r11,9(r3) /* load quotation-xt slot */ XX \
+ lwz r11,9(r3) /* load quotation-xt slot */ XX \
#define CALL_QUOT \
- CALL_OR_JUMP_QUOT XX \
- mtlr r11 /* prepare to call XT with quotation in r3 */ XX \
- blrl /* go */
+ CALL_OR_JUMP_QUOT XX \
+ mtlr r11 /* prepare to call XT with quotation in r3 */ XX \
+ blrl /* go */
#define JUMP_QUOT \
- CALL_OR_JUMP_QUOT XX \
- mtctr r11 /* prepare to call XT with quotation in r3 */ XX \
- bctr /* go */
+ CALL_OR_JUMP_QUOT XX \
+ mtctr r11 /* prepare to call XT with quotation in r3 */ XX \
+ bctr /* go */
#define PARAM_SIZE 32
-#define SAVED_REGS_SIZE 96
+#define SAVED_INT_REGS_SIZE 96
-#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_REGS_SIZE + 8)
+#define SAVED_FP_REGS_SIZE 144
+
+#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8)
#if defined( __APPLE__)
- #define LR_SAVE 8
- #define RESERVED_SIZE 24
+ #define LR_SAVE 8
+ #define RESERVED_SIZE 24
#else
- #define LR_SAVE 4
- #define RESERVED_SIZE 8
+ #define LR_SAVE 4
+ #define RESERVED_SIZE 8
#endif
#define SAVE_LR(reg) stw reg,(LR_SAVE + FRAME)(r1)
#define SAVE_AT(offset) (RESERVED_SIZE + PARAM_SIZE + 4 * offset)
-#define SAVE(register,offset) stw register,SAVE_AT(offset)(r1)
+#define SAVE_INT(register,offset) stw register,SAVE_AT(offset)(r1)
+#define RESTORE_INT(register,offset) lwz register,SAVE_AT(offset)(r1)
-#define RESTORE(register,offset) lwz register,SAVE_AT(offset)(r1)
+#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1)
+#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1)
#define PROLOGUE \
- mflr r0 XX /* get caller's return address */ \
- stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
- SAVE_LR(r0)
+ mflr r0 XX /* get caller's return address */ \
+ stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
+ SAVE_LR(r0)
#define EPILOGUE \
LOAD_LR(r0) XX \
- lwz r1,0(r1) XX /* destroy the stack frame */ \
- mtlr r0 /* get ready to return */
+ lwz r1,0(r1) XX /* destroy the stack frame */ \
+ mtlr r0 /* get ready to return */
+/* We have to save and restore nonvolatile registers because
+the Factor compiler treats the entire register file as volatile. */
DEF(void,c_to_factor,(CELL quot)):
- PROLOGUE
-
- SAVE(r13,0) /* save GPRs */
- /* don't save ds pointer */
- /* don't save rs pointer */
- SAVE(r16,3)
- SAVE(r17,4)
- SAVE(r18,5)
- SAVE(r19,6)
- SAVE(r20,7)
- SAVE(r21,8)
- SAVE(r22,9)
- SAVE(r23,10)
- SAVE(r24,11)
- SAVE(r25,12)
- SAVE(r26,13)
- SAVE(r27,14)
- SAVE(r28,15)
- SAVE(r29,16)
- SAVE(r30,17)
- SAVE(r31,18)
- SAVE(r3,19) /* save quotation since we're about to mangle it */
-
- mr r3,r1 /* pass call stack pointer as an argument */
+ PROLOGUE
+
+ SAVE_INT(r13,0) /* save GPRs */
+ SAVE_INT(r14,1)
+ SAVE_INT(r15,2)
+ SAVE_INT(r16,3)
+ SAVE_INT(r17,4)
+ SAVE_INT(r18,5)
+ SAVE_INT(r19,6)
+ SAVE_INT(r20,7)
+ SAVE_INT(r21,8)
+ SAVE_INT(r22,9)
+ SAVE_INT(r23,10)
+ SAVE_INT(r24,11)
+ SAVE_INT(r25,12)
+ SAVE_INT(r26,13)
+ SAVE_INT(r27,14)
+ SAVE_INT(r28,15)
+
+ SAVE_FP(f14,20) /* save FPRs */
+ SAVE_FP(f15,22)
+ SAVE_FP(f16,24)
+ SAVE_FP(f17,26)
+ SAVE_FP(f18,28)
+ SAVE_FP(f19,30)
+ SAVE_FP(f20,32)
+ SAVE_FP(f21,34)
+ SAVE_FP(f22,36)
+ SAVE_FP(f23,38)
+ SAVE_FP(f24,40)
+ SAVE_FP(f25,42)
+ SAVE_FP(f26,44)
+ SAVE_FP(f27,46)
+ SAVE_FP(f28,48)
+ SAVE_FP(f29,50)
+ SAVE_FP(f30,52)
+ SAVE_FP(f31,54)
+
+ SAVE_INT(r3,19) /* save quotation since we're about to mangle it */
+
+ mr r3,r1 /* pass call stack pointer as an argument */
bl MANGLE(save_callstack_bottom)
- RESTORE(r3,19) /* restore quotation */
- CALL_QUOT
-
- RESTORE(r31,18) /* restore GPRs */
- RESTORE(r30,17)
- RESTORE(r29,16)
- RESTORE(r28,15)
- RESTORE(r27,14)
- RESTORE(r26,13)
- RESTORE(r25,12)
- RESTORE(r24,11)
- RESTORE(r23,10)
- RESTORE(r22,9)
- RESTORE(r21,8)
- RESTORE(r20,7)
- RESTORE(r19,6)
- RESTORE(r18,5)
- RESTORE(r17,4)
- RESTORE(r16,3)
- /* don't restore rs pointer */
- /* don't restore ds pointer */
- RESTORE(r13,0)
-
- EPILOGUE
- blr
+ RESTORE_INT(r3,19) /* restore quotation */
+ CALL_QUOT
+
+ RESTORE_FP(f31,54)
+ RESTORE_FP(f30,52)
+ RESTORE_FP(f29,50)
+ RESTORE_FP(f28,48)
+ RESTORE_FP(f27,46)
+ RESTORE_FP(f26,44)
+ RESTORE_FP(f25,42)
+ RESTORE_FP(f24,40)
+ RESTORE_FP(f23,38)
+ RESTORE_FP(f22,36)
+ RESTORE_FP(f21,34)
+ RESTORE_FP(f20,32)
+ RESTORE_FP(f19,30)
+ RESTORE_FP(f18,28)
+ RESTORE_FP(f17,26)
+ RESTORE_FP(f16,24)
+ RESTORE_FP(f15,22)
+ RESTORE_FP(f14,20) /* save FPRs */
+
+ RESTORE_INT(r28,15) /* restore GPRs */
+ RESTORE_INT(r27,14)
+ RESTORE_INT(r26,13)
+ RESTORE_INT(r25,12)
+ RESTORE_INT(r24,11)
+ RESTORE_INT(r23,10)
+ RESTORE_INT(r22,9)
+ RESTORE_INT(r21,8)
+ RESTORE_INT(r20,7)
+ RESTORE_INT(r19,6)
+ RESTORE_INT(r18,5)
+ RESTORE_INT(r17,4)
+ RESTORE_INT(r16,3)
+ RESTORE_INT(r15,2)
+ RESTORE_INT(r14,1)
+ RESTORE_INT(r13,0)
+
+ EPILOGUE
+ blr
/* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI
limitation which would otherwise require us to do a bizzaro PC-relative
trampoline to retrieve the function address */
DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
- sub r1,r3,r5 /* compute new stack pointer */
- mr r3,r1 /* start of destination of memcpy() */
- stwu r1,-64(r1) /* setup fake stack frame for memcpy() */
- mtlr r6 /* prepare to call memcpy() */
- blrl /* go */
- lwz r1,0(r1) /* tear down fake stack frame */
- lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */
- mtlr r0 /* prepare to return to restored callstack */
- blr /* go */
+ sub r1,r3,r5 /* compute new stack pointer */
+ mr r3,r1 /* start of destination of memcpy() */
+ stwu r1,-64(r1) /* setup fake stack frame for memcpy() */
+ mtlr r6 /* prepare to call memcpy() */
+ blrl /* go */
+ lwz r1,0(r1) /* tear down fake stack frame */
+ lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */
+ mtlr r0 /* prepare to return to restored callstack */
+ blr /* go */
DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
- mr r1,r4 /* compute new stack pointer */
+ mr r1,r4 /* compute new stack pointer */
lwz r0,LR_SAVE(r1) /* we have rewound the stack; load return address */
mtlr r0
- JUMP_QUOT /* call the quotation */
+ JUMP_QUOT /* call the quotation */
DEF(void,lazy_jit_compile,(CELL quot)):
- mr r4,r1 /* save stack pointer */
+ mr r4,r1 /* save stack pointer */
PROLOGUE
bl MANGLE(primitive_jit_compile)
EPILOGUE
- JUMP_QUOT /* call the quotation */
+ JUMP_QUOT /* call the quotation */
/* Thanks to Joshua Grams for this code.
after writing to the code heap. */
DEF(void,flush_icache,(void *start, int len)):
- /* compute number of cache lines to flush */
- add r4,r4,r3
- clrrwi r3,r3,5 /* align addr to next lower cache line boundary */
- sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */
- addi r4,r4,0x1f
- srwi. r4,r4,5 /* note '.' suffix */
- beqlr /* if n_lines == 0, just return. */
- mtctr r4 /* flush cache lines */
-0: dcbf 0,r3 /* for each line... */
- sync
- icbi 0,r3
- addi r3,r3,0x20
- bdnz 0b
- sync /* finish up */
- isync
- blr
+ /* compute number of cache lines to flush */
+ add r4,r4,r3
+ clrrwi r3,r3,5 /* align addr to next lower cache line boundary */
+ sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */
+ addi r4,r4,0x1f
+ srwi. r4,r4,5 /* note '.' suffix */
+ beqlr /* if n_lines == 0, just return. */
+ mtctr r4 /* flush cache lines */
+0: dcbf 0,r3 /* for each line... */
+ sync
+ icbi 0,r3
+ addi r3,r3,0x20
+ bdnz 0b
+ sync /* finish up */
+ isync
+ blr
#define FACTOR_CPU_STRING "ppc"
#define F_FASTCALL
-register CELL ds asm("r14");
-register CELL rs asm("r15");
+register CELL ds asm("r29");
+register CELL rs asm("r30");
void c_to_factor(CELL quot);
void undefined(CELL word);
#define DS_REG %esi
#define RETURN_REG %eax
+#define NV_TEMP_REG %ebx
+
#define CELL_SIZE 4
+#define STACK_PADDING 12
#define PUSH_NONVOLATILE \
push %ebx ; \
+ push %ebp ; \
push %ebp
#define POP_NONVOLATILE \
+ pop %ebp ; \
pop %ebp ; \
pop %ebx
add $12,%esp /* pop args from the stack */
ret /* return _with new stack_ */
+/* cpu.x86.32 calls this */
+DEF(bool,check_sse2,(void)):
+ push %ebx
+ mov $1,%eax
+ cpuid
+ shr $26,%edx
+ and $1,%edx
+ pop %ebx
+ mov %edx,%eax
+ ret
+
#include "cpu-x86.S"
+
+#ifdef WINDOWS
+ .section .drectve
+ .ascii " -export:check_sse2"
+#endif
register CELL rs asm("edi");
#define F_FASTCALL __attribute__ ((regparm (2)))
-
#include "asm.h"
-#define ARG0 %rdi
-#define ARG1 %rsi
#define STACK_REG %rsp
#define DS_REG %r14
#define RETURN_REG %rax
#define CELL_SIZE 8
+#define STACK_PADDING 56
-#define PUSH_NONVOLATILE \
- push %rbx ; \
- push %rbp ; \
- push %r12 ; \
- push %r13 ;
+#define NV_TEMP_REG %rbp
-#define POP_NONVOLATILE \
- pop %r13 ; \
- pop %r12 ; \
- pop %rbp ; \
- pop %rbx
+#ifdef WINDOWS
+
+ #define ARG0 %rcx
+ #define ARG1 %rdx
+ #define ARG2 %r8
+ #define ARG3 %r9
+
+ #define PUSH_NONVOLATILE \
+ push %r12 ; \
+ push %r13 ; \
+ push %rdi ; \
+ push %rsi ; \
+ push %rbx ; \
+ push %rbp ; \
+ push %rbp
+
+ #define POP_NONVOLATILE \
+ pop %rbp ; \
+ pop %rbp ; \
+ pop %rbx ; \
+ pop %rsi ; \
+ pop %rdi ; \
+ pop %r13 ; \
+ pop %r12
+
+#else
+
+ #define ARG0 %rdi
+ #define ARG1 %rsi
+ #define ARG2 %rdx
+ #define ARG3 %rcx
+
+ #define PUSH_NONVOLATILE \
+ push %rbx ; \
+ push %rbp ; \
+ push %r12 ; \
+ push %r13 ; \
+ push %r13
+
+ #define POP_NONVOLATILE \
+ pop %r13 ; \
+ pop %r13 ; \
+ pop %r12 ; \
+ pop %rbp ; \
+ pop %rbx
+
+#endif
#define QUOT_XT_OFFSET 21
ABI limitation which would otherwise require us to do a bizzaro PC-relative
trampoline to retrieve the function address */
DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
- sub %rdx,%rdi /* compute new stack pointer */
- mov %rdi,%rsp
- call *%rcx /* call memcpy */
+ sub ARG2,ARG0 /* compute new stack pointer */
+ mov ARG0,%rsp
+ call *ARG3 /* call memcpy */
ret /* return _with new stack_ */
#include "cpu-x86.S"
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
PUSH_NONVOLATILE
- push ARG0 /* Save quot */
+ mov ARG0,NV_TEMP_REG
- lea -CELL_SIZE(STACK_REG),ARG0 /* Save stack pointer */
+ /* Create register shadow area for Win64 */
+ sub $32,STACK_REG
+
+ /* Save stack pointer */
+ lea -CELL_SIZE(STACK_REG),ARG0
call MANGLE(save_callstack_bottom)
- mov (STACK_REG),ARG0 /* Pass quot as arg 1 */
- call *QUOT_XT_OFFSET(ARG0) /* Call quot-xt */
+ /* Call quot-xt */
+ mov NV_TEMP_REG,ARG0
+ call *QUOT_XT_OFFSET(ARG0)
+
+ /* Tear down register shadow area */
+ add $32,STACK_REG
- POP ARG0
POP_NONVOLATILE
ret
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
- mov ARG1,STACK_REG /* rewind_to */
+ /* rewind_to */
+ mov ARG1,STACK_REG
jmp *QUOT_XT_OFFSET(ARG0)
DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
mov STACK_REG,ARG1 /* Save stack pointer */
- push ARG1 /* Alignment */
- push ARG1
- push ARG1
+ sub $STACK_PADDING,STACK_REG
call MANGLE(primitive_jit_compile)
mov RETURN_REG,ARG0 /* No-op on 32-bit */
- pop ARG1 /* OK to clobber ARG1 here */
- pop ARG1
- pop ARG1
+ add $STACK_PADDING,STACK_REG
jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
#ifdef WINDOWS
case CALLSTACK_TYPE:
return callstack_size(
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
- case TUPLE_LAYOUT_TYPE:
- return sizeof(F_TUPLE_LAYOUT);
default:
critical_error("Invalid header",pointer);
return -1; /* can't happen */
old->new references */
void collect_cards(void)
{
+ GC_PRINT("Collect cards\n");
+
int i;
for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
collect_gen_cards(i);
{
CELL top = (CELL)stacks->callstack_top;
CELL bottom = (CELL)stacks->callstack_bottom;
+
+ GC_PRINT("Collect callstack %ld %ld\n",top,bottom);
iterate_callstack(top,bottom,collect_stack_frame);
+ GC_PRINT("Done\n");
}
}
the user environment and extra roots registered with REGISTER_ROOT */
void collect_roots(void)
{
+ GC_PRINT("Collect roots\n");
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&bignum_pos_one);
#include "master.h"
+static bool full_output;
+
void print_chars(F_STRING* str)
{
CELL i;
CELL i;
bool trimmed;
- if(length > 10)
+ if(length > 10 && !full_output)
{
trimmed = true;
length = 10;
CELL i;
bool trimmed;
- if(length > 10)
+ if(length > 10 && !full_output)
{
trimmed = true;
length = 10;
void print_nested_obj(CELL obj, F_FIXNUM nesting)
{
- if(nesting <= 0)
+ if(nesting <= 0 && !full_output)
{
printf(" ... ");
return;
printf("d <addr> <count> -- dump memory\n");
printf("u <addr> -- dump object at tagged <addr>\n");
printf(". <addr> -- print object at tagged <addr>\n");
+ printf("t -- toggle output trimming\n");
printf("s r -- dump data, retain stacks\n");
printf(".s .r .c -- print data, retain, call stacks\n");
printf("e -- dump environment\n");
print_obj(addr);
printf("\n");
}
+ else if(strcmp(cmd,"t") == 0)
+ full_output = !full_output;
else if(strcmp(cmd,"s") == 0)
dump_memory(ds_bot,ds);
else if(strcmp(cmd,"r") == 0)
void memory_signal_handler_impl(void)
{
- memory_protection_error(signal_fault_addr,signal_callstack_top);
+ memory_protection_error(signal_fault_addr,signal_callstack_top);
}
void divide_by_zero_signal_handler_impl(void)
{
- divide_by_zero_error(signal_callstack_top);
+ divide_by_zero_error(signal_callstack_top);
}
void misc_signal_handler_impl(void)
{
- signal_error(signal_number,signal_callstack_top);
+ signal_error(signal_number,signal_callstack_top);
}
DEFINE_PRIMITIVE(throw)
}
init_factor(&p);
-
nest_stacks();
F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
-fraptor ICON "misc/icons/Factor.ico"\r
-\r
+fraptor ICON "misc/icons/Factor.ico"
+
#define BYTE_ARRAY_TYPE 10
#define CALLSTACK_TYPE 11
#define STRING_TYPE 12
-#define TUPLE_LAYOUT_TYPE 13
+#define WORD_TYPE 13
#define QUOTATION_TYPE 14
#define DLL_TYPE 15
#define ALIEN_TYPE 16
-#define WORD_TYPE 17
-#define TYPE_COUNT 20
+#define TYPE_COUNT 17
INLINE bool immediate_p(CELL obj)
{
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
-/* C sucks. */
+/* We use a union here to force the float value to be aligned on an
+8-byte boundary. */
union {
CELL header;
long long padding;
CELL size;
} F_STACK_FRAME;
+/* These are really just arrays, but certain elements have special
+significance */
typedef struct
{
CELL header;
- /* tagged fixnum */
- CELL hashcode;
+ /* tagged */
+ CELL capacity;
/* tagged */
CELL class;
/* tagged fixnum */
CELL size;
- /* tagged array */
- CELL superclasses;
/* tagged fixnum */
CELL echelon;
} F_TUPLE_LAYOUT;
dpush(tag_fixnum(x % y));
}
-DEFINE_PRIMITIVE(fixnum_mod)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x % y));
-}
-
/*
* Note the hairy overflow check.
* If we're shifting right by n bits, we won't overflow as long as none of the
fixnum_to_bignum(x),y)));
}
-DEFINE_PRIMITIVE(fixnum_shift_fast)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y)));
-}
-
/* Bignums */
DEFINE_PRIMITIVE(fixnum_to_bignum)
{
case BIGNUM_TYPE:
{
bignum_type zero = untag_object(bignum_zero);
- bignum_type max = ulong_to_bignum(ARRAY_SIZE_MAX);
+ bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX);
bignum_type n = untag_object(dpeek());
if(bignum_compare(n,zero) != bignum_comparison_less
&& bignum_compare(n,max) == bignum_comparison_less)
{
dpop();
- return bignum_to_ulong(n);
+ return bignum_to_cell(n);
}
break;
}
DECLARE_PRIMITIVE(fixnum_multiply);
DECLARE_PRIMITIVE(fixnum_divint);
DECLARE_PRIMITIVE(fixnum_divmod);
-DECLARE_PRIMITIVE(fixnum_mod);
DECLARE_PRIMITIVE(fixnum_shift);
-DECLARE_PRIMITIVE(fixnum_shift_fast);
CELL bignum_zero;
CELL bignum_pos_one;
primitive_fixnum_subtract,
primitive_fixnum_multiply,
primitive_fixnum_divint,
- primitive_fixnum_mod,
primitive_fixnum_divmod,
primitive_fixnum_shift,
- primitive_fixnum_shift_fast,
primitive_bignum_eq,
primitive_bignum_add,
primitive_bignum_subtract,
primitive_array_to_quotation,
primitive_quotation_xt,
primitive_tuple,
- primitive_tuple_layout,
primitive_profiling,
primitive_become,
primitive_sleep,
return result;
}
-/* Tuple layouts */
-DEFINE_PRIMITIVE(tuple_layout)
-{
- F_TUPLE_LAYOUT *layout = allot_object(TUPLE_LAYOUT_TYPE,sizeof(F_TUPLE_LAYOUT));
- layout->echelon = dpop();
- layout->superclasses = dpop();
- layout->size = dpop();
- layout->class = dpop();
- layout->hashcode = untag_word(layout->class)->hashcode;
- dpush(tag_object(layout));
-}
-
/* Tuples */
/* push a new tuple on the stack */
DEFINE_PRIMITIVE(tuple)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = to_fixnum(layout->size);
+ F_FIXNUM size = untag_fixnum_fast(layout->size);
F_TUPLE *tuple = allot_tuple(layout);
F_FIXNUM i;
DEFINE_PRIMITIVE(tuple_boa)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = to_fixnum(layout->size);
+ F_FIXNUM size = untag_fixnum_fast(layout->size);
REGISTER_UNTAGGED(layout);
F_TUPLE *tuple = allot_tuple(layout);
projects / factor.git / commitdiff