*.res
*.RES
*.image
+factor.image.fresh
*.dylib
factor
factor.com
@echo "NO_UI=1 don't link with X11 libraries (ignored on Mac OS X)"
@echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)"
+ALL = factor factor-ffi-test factor-lib
+
openbsd-x86-32:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.32
+ $(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.32
openbsd-x86-64:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.64
+ $(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.64
freebsd-x86-32:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.32
+ $(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.32
freebsd-x86-64:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.64
+ $(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.64
netbsd-x86-32:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.32
+ $(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.32
netbsd-x86-64:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.64
+ $(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.64
macosx-ppc:
- $(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.ppc
+ $(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.ppc
macosx-x86-32:
- $(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.32
+ $(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.32
macosx-x86-64:
- $(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.64
+ $(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.64
linux-x86-32:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.32
+ $(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.32
linux-x86-64:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.64
+ $(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.64
linux-ppc:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.ppc
+ $(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc
linux-arm:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.arm
+ $(MAKE) $(ALL) CONFIG=vm/Config.linux.arm
solaris-x86-32:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.32
+ $(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.32
solaris-x86-64:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.64
+ $(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.64
winnt-x86-32:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.32
+ $(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.64
+ $(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
- $(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.ce.arm
+ $(MAKE) $(ALL) CONFIG=vm/Config.windows.ce.arm
ifdef CONFIG
$(ENGINE): $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
+factor-lib: $(ENGINE)
+
factor: $(EXE_OBJS) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
tags:
etags vm/*.{cpp,hpp,mm,S,c}
-.PHONY: factor factor-console factor-ffi-test tags clean macosx.app
+.PHONY: factor factor-lib factor-console factor-ffi-test tags clean macosx.app
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays arrays assocs kernel kernel.private math
+USING: byte-arrays arrays assocs delegate kernel kernel.private math
math.order math.parser namespaces make parser sequences strings
words splitting cpu.architecture alien alien.accessors
alien.strings quotations layouts system compiler.units io
M: abstract-c-type c-type-class class>> ;
-M: c-type-name c-type-class c-type c-type-class ;
-
GENERIC: c-type-boxed-class ( name -- class )
M: abstract-c-type c-type-boxed-class boxed-class>> ;
-M: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
-
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
-M: c-type-name c-type-boxer c-type c-type-boxer ;
-
GENERIC: c-type-boxer-quot ( name -- quot )
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
-M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
-
GENERIC: c-type-unboxer ( name -- boxer )
M: c-type c-type-unboxer unboxer>> ;
-M: c-type-name c-type-unboxer c-type c-type-unboxer ;
-
GENERIC: c-type-unboxer-quot ( name -- quot )
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
-M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
-
GENERIC: c-type-rep ( name -- rep )
M: c-type c-type-rep rep>> ;
-M: c-type-name c-type-rep c-type c-type-rep ;
-
GENERIC: c-type-getter ( name -- quot )
M: c-type c-type-getter getter>> ;
-M: c-type-name c-type-getter c-type c-type-getter ;
-
GENERIC: c-type-setter ( name -- quot )
M: c-type c-type-setter setter>> ;
-M: c-type-name c-type-setter c-type c-type-setter ;
-
GENERIC: c-type-align ( name -- n )
M: abstract-c-type c-type-align align>> ;
-M: c-type-name c-type-align c-type c-type-align ;
-
GENERIC: c-type-align-first ( name -- n )
-M: c-type-name c-type-align-first c-type c-type-align-first ;
-
M: abstract-c-type c-type-align-first align-first>> ;
GENERIC: c-type-stack-align? ( name -- ? )
M: c-type c-type-stack-align? stack-align?>> ;
-M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
-
: c-type-box ( n c-type -- )
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
%box ;
M: c-type box-parameter c-type-box ;
-M: c-type-name box-parameter c-type box-parameter ;
-
GENERIC: box-return ( c-type -- )
M: c-type box-return f swap c-type-box ;
-M: c-type-name box-return c-type box-return ;
-
GENERIC: unbox-parameter ( n c-type -- )
M: c-type unbox-parameter c-type-unbox ;
-M: c-type-name unbox-parameter c-type unbox-parameter ;
-
GENERIC: unbox-return ( c-type -- )
M: c-type unbox-return f swap c-type-unbox ;
-M: c-type-name unbox-return c-type unbox-return ;
-
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
GENERIC: heap-size ( name -- size )
-M: c-type-name heap-size c-type heap-size ;
-
M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( name -- size )
-M: c-type-name stack-size c-type stack-size ;
-
M: c-type stack-size size>> cell align ;
: >c-bool ( ? -- int ) 1 0 ? ; inline
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make ;
+PROTOCOL: c-type-protocol
+ c-type-class
+ c-type-boxed-class
+ c-type-boxer
+ c-type-boxer-quot
+ c-type-unboxer
+ c-type-unboxer-quot
+ c-type-rep
+ c-type-getter
+ c-type-setter
+ c-type-align
+ c-type-align-first
+ c-type-stack-align?
+ box-parameter
+ box-return
+ unbox-parameter
+ unbox-return
+ heap-size
+ stack-size ;
+
+CONSULT: c-type-protocol c-type-name
+ c-type ;
+
PREDICATE: typedef-word < c-type-word
"c-type" word-prop c-type-name? ;
"Important guidelines for passing data in byte arrays:"
{ $subsections "byte-arrays-gc" }
"C-style enumerated types are supported:"
-{ $subsections POSTPONE: C-ENUM: }
+{ $subsections "alien.enums" POSTPONE: ENUM: }
"C types can be aliased for convenience and consistency with native library documentation:"
{ $subsections POSTPONE: TYPEDEF: }
"A utility for defining " { $link "destructors" } " for deallocating memory:"
! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
-USING: accessors alien alien.c-types alien.arrays alien.strings arrays
-byte-arrays cpu.architecture fry io io.encodings.binary
-io.files io.streams.memory kernel libc math sequences words
-byte-vectors ;
+USING: accessors alien alien.c-types alien.arrays alien.strings
+arrays byte-arrays cpu.architecture fry io io.encodings.binary
+io.files io.streams.memory kernel libc math sequences words ;
IN: alien.data
GENERIC: require-c-array ( c-type -- )
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;
-M: byte-vector stream-write
- [ dup byte-length tail-slice ]
- [ [ [ byte-length ] bi@ + ] keep lengthen ]
- [ drop byte-length ]
- 2tri
- [ >c-ptr swap >c-ptr ] dip memcpy ;
-
M: value-type c-type-rep drop int-rep ;
M: value-type c-type-getter
unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
-
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax help.markup help.syntax words ;
+IN: alien.enums
+
+HELP: define-enum
+{ $values
+ { "word" word } { "base-type" c-type } { "members" "sequence of word and value pairs" }
+}
+{ $description "Defines an enum. This is the run-time equivalent of " { $link POSTPONE: ENUM: } "." } ;
+
+HELP: enum>number
+{ $values
+ { "enum" "an enum word" }
+ { "number" "the corresponding number value" }
+}
+{ $description "Converts an enum to a number." } ;
+
+HELP: number>enum
+{ $values
+ { "number" "an enum number" } { "enum-c-type" "an enum type" }
+ { "enum" "the corresponding enum word" }
+}
+{ $description "Convert a number to an enum." } ;
+
+ARTICLE: "alien.enums" "Enumeration types"
+"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum symbols and integers."
+$nl
+"Defining enums at run-time:"
+{ $subsection define-enum }
+"Conversions between enums and integers:"
+{ $subsections enum>number number>enum } ;
+
+{ POSTPONE: ENUM: define-enum enum>number number>enum } related-words
+
+ABOUT: "alien.enums"
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.enums alien.enums.private
+alien.syntax sequences tools.test words ;
+IN: alien.enums.tests
+
+ENUM: color_t red { green 3 } blue ;
+ENUM: instrument_t < ushort trombone trumpet ;
+
+{ { red green blue 5 } }
+[ { 0 3 4 5 } [ <color_t> ] map ] unit-test
+
+{ { 0 3 4 5 } }
+[ { red green blue 5 } [ enum>number ] map ] unit-test
+
+{ { -1 trombone trumpet } }
+[ { -1 0 1 } [ <instrument_t> ] map ] unit-test
+
+{ { -1 0 1 } }
+[ { -1 trombone trumpet } [ enum>number ] map ] unit-test
+
+{ t }
+[ color_t "c-type" word-prop enum-c-type? ] unit-test
+
+{ f }
+[ ushort "c-type" word-prop enum-c-type? ] unit-test
+
+{ int }
+[ color_t "c-type" word-prop base-type>> ] unit-test
+
+{ ushort }
+[ instrument_t "c-type" word-prop base-type>> ] unit-test
+
+{ V{ { red 0 } { green 3 } { blue 4 } } }
+[ color_t "c-type" word-prop members>> ] unit-test
--- /dev/null
+! (c)2010 Joe Groff, Erik Charlebois bsd license
+USING: accessors alien.c-types arrays combinators delegate fry
+generic.parser kernel macros math parser sequences words words.symbol ;
+IN: alien.enums
+
+<PRIVATE
+TUPLE: enum-c-type base-type members ;
+C: <enum-c-type> enum-c-type
+CONSULT: c-type-protocol enum-c-type
+ base-type>> ;
+PRIVATE>
+
+GENERIC: enum>number ( enum -- number ) foldable
+M: integer enum>number ;
+M: symbol enum>number "enum-value" word-prop ;
+
+<PRIVATE
+: enum-boxer ( members -- quot )
+ [ first2 swap '[ _ ] 2array ]
+ { } map-as [ ] suffix '[ _ case ] ;
+PRIVATE>
+
+MACRO: number>enum ( enum-c-type -- )
+ c-type members>> enum-boxer ;
+
+M: enum-c-type c-type-boxed-class drop object ;
+M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
+M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
+M: enum-c-type c-type-setter
+ [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
+
+<PRIVATE
+
+: define-enum-value ( class value -- )
+ "enum-value" set-word-prop ;
+
+: define-enum-members ( member-names -- )
+ [
+ [ first define-symbol ]
+ [ first2 define-enum-value ] bi
+ ] each ;
+
+: define-enum-constructor ( word -- )
+ [ name>> "<" ">" surround create-in ] keep
+ [ number>enum ] curry (( number -- enum )) define-inline ;
+
+PRIVATE>
+
+: define-enum ( word base-type members -- )
+ [ dup define-enum-constructor ] 2dip
+ dup define-enum-members
+ <enum-c-type> swap typedef ;
+
+PREDICATE: enum-c-type-word < c-type-word
+ "c-type" word-prop enum-c-type? ;
"*" ?head
[ [ <pointer> ] dip parse-pointers ] when ;
-PRIVATE>
+: next-enum-member ( members name value -- members value' )
+ [ 2array suffix! ] [ 1 + ] bi ;
+
+: parse-enum-name ( -- name )
+ scan (CREATE-C-TYPE) dup save-location ;
+
+: parse-enum-base-type ( -- base-type token )
+ scan dup "<" =
+ [ drop scan-object scan ]
+ [ [ int ] dip ] if ;
-: define-enum-member ( word-string value -- next-value )
- [ create-in ] dip [ define-constant ] keep 1 + ;
+: parse-enum-member ( members name value -- members value' )
+ over "{" =
+ [ 2drop scan create-in scan-object next-enum-member "}" expect ]
+ [ [ create-in ] dip next-enum-member ] if ;
-: parse-enum-member ( word-string value -- next-value )
- over "{" =
- [ 2drop scan scan-object define-enum-member "}" expect ]
- [ define-enum-member ] if ;
+: parse-enum-members ( members counter token -- members )
+ dup ";" = not
+ [ swap parse-enum-member scan parse-enum-members ] [ 2drop ] if ;
+
+PRIVATE>
-: parse-enum-members ( counter -- )
- scan dup ";" = not
- [ swap parse-enum-member parse-enum-members ] [ 2drop ] if ;
+: parse-enum ( -- name base-type members )
+ parse-enum-name
+ parse-enum-base-type
+ [ V{ } clone 0 ] dip parse-enum-members ;
: scan-function-name ( -- return function )
scan-c-type scan parse-pointers ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel combinators alien alien.strings alien.c-types
-alien.parser alien.syntax arrays assocs effects math.parser
-prettyprint.backend prettyprint.custom prettyprint.sections
-definitions see see.private sequences strings words ;
+USING: accessors kernel combinators alien alien.enums
+alien.strings alien.c-types alien.parser alien.syntax arrays
+assocs effects math.parser prettyprint.backend prettyprint.custom
+prettyprint.sections definitions see see.private sequences
+strings words ;
IN: alien.prettyprint
M: alien pprint*
")" text block>
]
} cleave ;
+
+M: enum-c-type-word definer
+ drop \ ENUM: \ ; ;
+M: enum-c-type-word synopsis*
+ {
+ [ seeing-word ]
+ [ definer. ]
+ [ pprint-word ]
+ [ c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ]
+ } cleave ;
+M: enum-c-type-word definition
+ c-type members>> ;
IN: alien.syntax
-USING: alien alien.c-types alien.parser alien.libraries
-classes.struct help.markup help.syntax see ;
+USING: alien alien.c-types alien.enums alien.libraries classes.struct
+help.markup help.syntax see ;
HELP: DLL"
{ $syntax "DLL\" path\"" }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
-HELP: C-ENUM:
-{ $syntax "C-ENUM: type/f words... ;" }
+HELP: ENUM:
+{ $syntax "ENUM: type words... ;" "ENUM: type < base-type words..." }
{ $values { "type" "a name to typedef to int or f" } { "words" "a sequence of word names" } }
-{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to the rules of C enums." }
-{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." }
+{ $description "Creates a c-type that boxes and unboxes integer values to symbols. A symbol is defined for each member word. The base c-type can optionally be specified and defaults to " { $link int } ". A constructor word " { $snippet "<type>" } " is defined for converting from integers to singletons. The generic word " { $link enum>number } " converts from singletons to integers. Enum-typed values are automatically prettyprinted as their singleton words. Unrecognizing enum numbers are kept as numbers." }
{ $examples
"Here is an example enumeration definition:"
- { $code "C-ENUM: color_t red { green 3 } blue ;" }
- "It is equivalent to the following series of definitions:"
- { $code "CONSTANT: red 0" "CONSTANT: green 3" "CONSTANT: blue 4" }
+ { $code "ENUM: color_t red { green 3 } blue ;" }
+ "The following expression returns true:"
+ { $code "3 <color_t> [ green = ] [ enum>number 3 = ] bi and" }
} ;
HELP: C-TYPE:
! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays alien alien.c-types alien.arrays
+USING: accessors arrays alien alien.c-types alien.enums alien.arrays
alien.strings kernel math namespaces parser sequences words
quotations math.parser splitting grouping effects assocs
combinators lexer strings.parser alien.parser fry vocabs.parser
SYNTAX: TYPEDEF:
scan-c-type CREATE-C-TYPE dup save-location typedef ;
-SYNTAX: C-ENUM:
- scan dup "f" =
- [ drop ]
- [ (CREATE-C-TYPE) dup save-location int swap typedef ] if
- 0 parse-enum-members ;
+SYNTAX: ENUM:
+ parse-enum define-enum ;
SYNTAX: C-TYPE:
void CREATE-C-TYPE typedef ;
M: biassoc assoc-size from>> assoc-size ;
-M: biassoc at* from>> at* ;
+M: biassoc at* from>> at* ; inline
-M: biassoc value-at* to>> at* ;
+M: biassoc value-at* to>> at* ; inline
: once-at ( value key assoc -- )
2dup key? [ 3drop ] [ set-at ] if ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators hints kernel locals math
-math.order sequences ;
+math.order sequences sequences.private ;
IN: binary-search
<PRIVATE
:: (search) ( seq from to quot: ( elt -- <=> ) -- i elt )
from to + 2/ :> midpoint@
- midpoint@ seq nth :> midpoint
+ midpoint@ seq nth-unsafe :> midpoint
to from - 1 <= [
midpoint@ midpoint
T{ bit-set f ?{ f f t f t f } } intersect
] unit-test
+[ f ] [ T{ bit-set f ?{ t f f f t f } } null? ] unit-test
+[ t ] [ T{ bit-set f ?{ f f f f f f } } null? ] unit-test
+
[ T{ bit-set f ?{ t f t f f f } } ] [
T{ bit-set f ?{ t t t f f f } }
T{ bit-set f ?{ f t f f t t } } diff
"alien.remote-control" require
] unless
-"prettyprint" "alien.prettyprint" require-when
-"debugger" "alien.debugger" require-when
+{ "boostrap.compiler" "prettyprint" } "alien.prettyprint" require-when
+{ "boostrap.compiler" "debugger" } "alien.debugger" require-when
"cpu." cpu name>> append require
[ optimized? not ] filter compile ;
"debug-compiler" get [
-
+
nl
"Compiling..." write flush
curry compose uncurry
- array-nth set-array-nth length>>
+ array-nth set-array-nth
wrap probe
" done" print flush
+ "io.streams.byte-array.fast" require
+
] unless
USING: vocabs.loader vocabs kernel ;\r
IN: bootstrap.handbook\r
\r
-"bootstrap.help" "help.handbook" require-when\r
+{ "bootstrap.handbook" "bootstrap.help" } "help.handbook" require-when\r
: save/restore-error ( quot -- )
error get-global
+ original-error get-global
error-continuation get-global
- [ call ] 2dip
+ [ call ] 3dip
error-continuation set-global
+ original-error set-global
error set-global ; inline
run-bootstrap-init
f error set-global
+ f original-error set-global
f error-continuation set-global
nano-count swap - bootstrap-time set-global
compiler.utilities namespaces ;
IN: bootstrap.threads
-"debugger" "debugger.threads" require-when
+{ "bootstrap.threads" "debugger" } "debugger.threads" require-when
[ yield ] yield-hook set-global
[ "bootstrap." prepend vocab ] all? [
"ui.tools" require
- "ui.backend.cocoa" "ui.backend.cocoa.tools" require-when
+ { "ui.backend.cocoa" } "ui.backend.cocoa.tools" require-when
"ui.tools.walker" require
] when
STRUCT: cairo_user_data_key_t
{ unused int } ;
-C-ENUM: cairo_status_t
+ENUM: cairo_status_t
CAIRO_STATUS_SUCCESS
CAIRO_STATUS_NO_MEMORY
CAIRO_STATUS_INVALID_RESTORE
cairo_pop_group_to_source ( cairo_t* cr ) ;
! Modify state
-C-ENUM: cairo_operator_t
+ENUM: cairo_operator_t
CAIRO_OPERATOR_CLEAR
CAIRO_OPERATOR_SOURCE
FUNCTION: void
cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
-C-ENUM: cairo_antialias_t
+ENUM: cairo_antialias_t
CAIRO_ANTIALIAS_DEFAULT
CAIRO_ANTIALIAS_NONE
CAIRO_ANTIALIAS_GRAY
FUNCTION: void
cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
-C-ENUM: cairo_fill_rule_t
+ENUM: cairo_fill_rule_t
CAIRO_FILL_RULE_WINDING
CAIRO_FILL_RULE_EVEN_ODD ;
FUNCTION: void
cairo_set_line_width ( cairo_t* cr, double width ) ;
-C-ENUM: cairo_line_cap_t
+ENUM: cairo_line_cap_t
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 ) ;
-C-ENUM: cairo_line_join_t
+ENUM: cairo_line_join_t
CAIRO_LINE_JOIN_MITER
CAIRO_LINE_JOIN_ROUND
CAIRO_LINE_JOIN_BEVEL ;
{ max_x_advance double }
{ max_y_advance double } ;
-C-ENUM: cairo_font_slant_t
+ENUM: cairo_font_slant_t
CAIRO_FONT_SLANT_NORMAL
CAIRO_FONT_SLANT_ITALIC
CAIRO_FONT_SLANT_OBLIQUE ;
-C-ENUM: cairo_font_weight_t
+ENUM: cairo_font_weight_t
CAIRO_FONT_WEIGHT_NORMAL
CAIRO_FONT_WEIGHT_BOLD ;
-C-ENUM: cairo_subpixel_order_t
+ENUM: cairo_subpixel_order_t
CAIRO_SUBPIXEL_ORDER_DEFAULT
CAIRO_SUBPIXEL_ORDER_RGB
CAIRO_SUBPIXEL_ORDER_BGR
CAIRO_SUBPIXEL_ORDER_VRGB
CAIRO_SUBPIXEL_ORDER_VBGR ;
-C-ENUM: cairo_hint_style_t
+ENUM: cairo_hint_style_t
CAIRO_HINT_STYLE_DEFAULT
CAIRO_HINT_STYLE_NONE
CAIRO_HINT_STYLE_SLIGHT
CAIRO_HINT_STYLE_MEDIUM
CAIRO_HINT_STYLE_FULL ;
-C-ENUM: cairo_hint_metrics_t
+ENUM: cairo_hint_metrics_t
CAIRO_HINT_METRICS_DEFAULT
CAIRO_HINT_METRICS_OFF
CAIRO_HINT_METRICS_ON ;
FUNCTION: cairo_status_t
cairo_font_face_status ( cairo_font_face_t* font_face ) ;
-C-ENUM: cairo_font_type_t
+ENUM: cairo_font_type_t
CAIRO_FONT_TYPE_TOY
CAIRO_FONT_TYPE_FT
CAIRO_FONT_TYPE_WIN32
FUNCTION: cairo_surface_t*
cairo_get_group_target ( cairo_t* cr ) ;
-C-ENUM: cairo_path_data_type_t
+ENUM: cairo_path_data_type_t
CAIRO_PATH_MOVE_TO
CAIRO_PATH_LINE_TO
CAIRO_PATH_CURVE_TO
FUNCTION: cairo_status_t
cairo_surface_status ( cairo_surface_t* surface ) ;
-C-ENUM: cairo_surface_type_t
+ENUM: cairo_surface_type_t
CAIRO_SURFACE_TYPE_IMAGE
CAIRO_SURFACE_TYPE_PDF
CAIRO_SURFACE_TYPE_PS
! Image-surface functions
-C-ENUM: cairo_format_t
+ENUM: cairo_format_t
CAIRO_FORMAT_ARGB32
CAIRO_FORMAT_RGB24
CAIRO_FORMAT_A8
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 ) ;
-C-ENUM: cairo_pattern_type_t
+ENUM: cairo_pattern_type_t
CAIRO_PATTERN_TYPE_SOLID
CAIRO_PATTERN_TYPE_SURFACE
CAIRO_PATTERN_TYPE_LINEAR
FUNCTION: void
cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
-C-ENUM: cairo_extend_t
+ENUM: cairo_extend_t
CAIRO_EXTEND_NONE
CAIRO_EXTEND_REPEAT
CAIRO_EXTEND_REFLECT
FUNCTION: cairo_extend_t
cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
-C-ENUM: cairo_filter_t
+ENUM: cairo_filter_t
CAIRO_FILTER_FAST
CAIRO_FILTER_GOOD
CAIRO_FILTER_BEST
{ "Struct classes cannot have a superclass defined." }
{ "The slots of a struct must all have a type declared. The type must be a C type." }
{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
-} } ;
+}
+"Additionally, structs may use bit fields. A slot specifier may use the syntax " { $snippet "bits: n" } " to specify that the bit width of the slot is " { $snippet "n" } ". Bit width may be specified on signed or unsigned integer slots. The layout of bit fields is not guaranteed to match that of any particular C compiler." } ;
HELP: S{
{ $syntax "S{ class slots... }" }
USING: vocabs vocabs.loader ;
-"prettyprint" "classes.struct.prettyprint" require-when
+{ "classes.struct" "prettyprint" } "classes.struct.prettyprint" require-when
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
-C-ENUM: f
-NSApplicationDelegateReplySuccess
-NSApplicationDelegateReplyCancel
-NSApplicationDelegateReplyFailure ;
+CONSTANT: NSApplicationDelegateReplySuccess 0
+CONSTANT: NSApplicationDelegateReplyCancel 1
+CONSTANT: NSApplicationDelegateReplyFailure 2
: with-autorelease-pool ( quot -- )
NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 3 smart-apply ] unit-test
[ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 2 smart-apply ] unit-test
+
+[ 4 ] [ 2 [ even? ] [ 2 + ] smart-when ] unit-test
+[ 3 ] [ 3 [ even? ] [ 2 + ] smart-when ] unit-test
+[ 4 ] [ 2 [ odd? ] [ 2 + ] smart-unless ] unit-test
+[ 3 ] [ 3 [ odd? ] [ 2 + ] smart-unless ] unit-test
+
+[ 4 ] [ 2 [ even? ] [ 2 + ] smart-when* ] unit-test
+[ ] [ 3 [ even? ] [ 2 + ] smart-when* ] unit-test
+[ 3 ] [ 2 [ odd? ] [ 3 ] smart-unless* ] unit-test
+[ 3 ] [ 3 [ odd? ] [ 5 ] smart-unless* ] unit-test
+
+[ -1 ] [ 1 2 [ + odd? ] [ - ] smart-when* ] unit-test
+[ ] [ 2 2 [ + odd? ] [ ] smart-unless* ] unit-test
MACRO: nullary ( quot -- quot' )
dup outputs '[ @ _ ndrop ] ;
-MACRO: smart-if ( pred true false -- )
+MACRO: dropping ( quot -- quot' )
+ inputs '[ [ _ ndrop ] ] ;
+
+MACRO: balancing ( quot -- quot' )
+ '[ _ [ preserving ] [ dropping ] bi ] ;
+
+MACRO: smart-if ( pred true false -- quot )
'[ _ preserving _ _ if ] ;
-MACRO: smart-apply ( quot n -- )
+MACRO: smart-when ( pred true -- quot )
+ '[ _ _ [ ] smart-if ] ;
+
+MACRO: smart-unless ( pred false -- quot )
+ '[ _ [ ] _ smart-if ] ;
+
+MACRO: smart-if* ( pred true false -- quot )
+ '[ _ balancing _ swap _ compose if ] ;
+
+MACRO: smart-when* ( pred true -- quot )
+ '[ _ _ [ ] smart-if* ] ;
+
+MACRO: smart-unless* ( pred false -- quot )
+ '[ _ [ ] _ smart-if* ] ;
+
+MACRO: smart-apply ( quot n -- quot )
[ dup inputs ] dip '[ _ _ _ mnapply ] ;
--- /dev/null
+USING: arrays compiler.cfg.alias-analysis compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
+cpu.architecture tools.test ;
+IN: compiler.cfg.alias-analysis.tests
+
+! Redundant load elimination
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##copy f 2 1 any-rep }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##slot-imm f 2 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Store-load forwarding
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##copy f 2 1 any-rep }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##slot-imm f 2 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Dead store elimination
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Redundant store elimination
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##copy f 2 1 any-rep }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##copy f 2 1 any-rep }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Not a redundant load
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##set-slot-imm f 0 1 1 0 }
+ T{ ##slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##set-slot-imm f 0 1 1 0 }
+ T{ ##slot-imm f 2 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Not a redundant store
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##set-slot-imm f 2 1 1 0 }
+ T{ ##slot-imm f 4 0 1 0 }
+ T{ ##set-slot-imm f 3 1 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##set-slot-imm f 2 1 1 0 }
+ T{ ##slot-imm f 4 0 1 0 }
+ T{ ##set-slot-imm f 3 1 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! There's a redundant load, but not a redundant store
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##slot-imm f 4 0 1 0 }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ T{ ##slot f 5 0 3 0 0 }
+ T{ ##set-slot-imm f 3 0 1 0 }
+ T{ ##copy f 6 3 any-rep }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##slot-imm f 4 0 1 0 }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ T{ ##slot f 5 0 3 0 0 }
+ T{ ##set-slot-imm f 3 0 1 0 }
+ T{ ##slot-imm f 6 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Fresh allocations don't alias existing values
+
+! Redundant load elimination
+[
+ V{
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##allot f 4 16 array }
+ T{ ##set-slot-imm f 3 4 1 0 }
+ T{ ##set-slot-imm f 2 1 1 0 }
+ T{ ##copy f 5 3 any-rep }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##allot f 4 16 array }
+ T{ ##set-slot-imm f 3 4 1 0 }
+ T{ ##set-slot-imm f 2 1 1 0 }
+ T{ ##slot-imm f 5 4 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Redundant store elimination
+[
+ V{
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##allot f 4 16 array }
+ T{ ##slot-imm f 5 1 1 0 }
+ T{ ##set-slot-imm f 3 4 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##allot f 4 16 array }
+ T{ ##set-slot-imm f 1 4 1 0 }
+ T{ ##slot-imm f 5 1 1 0 }
+ T{ ##set-slot-imm f 3 4 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Storing a new alias class into another object means that heap-ac
+! can now alias the new ac
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##allot f 4 16 array }
+ T{ ##set-slot-imm f 0 4 1 0 }
+ T{ ##set-slot-imm f 4 2 1 0 }
+ T{ ##slot-imm f 5 3 1 0 }
+ T{ ##set-slot-imm f 1 5 1 0 }
+ T{ ##slot-imm f 6 4 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##allot f 4 16 array }
+ T{ ##set-slot-imm f 0 4 1 0 }
+ T{ ##set-slot-imm f 4 2 1 0 }
+ T{ ##slot-imm f 5 3 1 0 }
+ T{ ##set-slot-imm f 1 5 1 0 }
+ T{ ##slot-imm f 6 4 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Compares between objects which cannot alias are eliminated
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##allot f 1 16 array }
+ T{ ##load-reference f 2 f }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##allot f 1 16 array }
+ T{ ##compare f 2 0 1 cc= }
+ } alias-analysis-step
+] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
accessors words vectors combinators combinators.short-circuit
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.liveness
-compiler.cfg.copy-prop
compiler.cfg.registers
+compiler.cfg.utilities
compiler.cfg.comparisons
compiler.cfg.instructions
compiler.cfg.representations.preferred ;
! e = c
! x[1] = c
+! Local copy propagation
+SYMBOL: copies
+
+: resolve ( vreg -- vreg ) copies get ?at drop ;
+
+: record-copy ( ##copy -- )
+ [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
+
! Map vregs -> alias classes
SYMBOL: vregs>acs
: ac>vregs ( ac -- vregs ) acs>vregs get at ;
-GENERIC: aliases ( vreg -- vregs )
-
-M: integer aliases
+: aliases ( vreg -- vregs )
#! All vregs which may contain the same value as vreg.
vreg>ac ac>vregs ;
-M: word aliases
- 1array ;
-
: each-alias ( vreg quot -- )
[ aliases ] dip each ; inline
[ 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 ;
-
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
-M: ##slot insn-slot# slot>> constant ;
+M: ##slot insn-slot# drop f ;
M: ##slot-imm insn-slot# slot>> ;
-M: ##set-slot insn-slot# slot>> constant ;
+M: ##set-slot insn-slot# drop f ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: ##vm-field insn-slot# offset>> ;
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
! a new value, except boxing instructions haven't been
! inserted yet.
dup defs-vreg [
- over defs-vreg-rep int-rep eq?
+ over defs-vreg-rep { int-rep tagged-rep } member?
[ set-heap-ac ] [ set-new-ac ] if
] when* ;
M: ##phi analyze-aliases*
dup defs-vreg set-heap-ac ;
-M: ##load-immediate analyze-aliases*
- call-next-method
- dup [ val>> ] [ dst>> ] bi constants get set-at ;
-
M: ##allocation analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
M: ##read analyze-aliases*
call-next-method
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
- 2dup live-slot dup [
- 2nip any-rep \ ##copy new-insn analyze-aliases* nip
- ] [
- drop remember-slot
- ] if ;
+ 2dup live-slot dup
+ [ 2nip <copy> 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
M: ##write analyze-aliases*
dup
[ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
- [ remember-set-slot drop ] [ load-slot ] 3bi ;
+ 3dup idempotent? [ 3drop ] [
+ [ remember-set-slot drop ] [ load-slot ] 3bi
+ ] if ;
M: ##copy analyze-aliases*
#! The output vreg gets the same alias class as the input
M: ##compare analyze-aliases*
call-next-method
dup useless-compare? [
- dst>> \ f type-number \ ##load-immediate new-insn
+ dst>> f \ ##load-reference new-insn
analyze-aliases*
] when ;
compute-live-stores
eliminate-dead-stores ;
-: alias-analysis ( cfg -- cfg' )
- [ alias-analysis-step ] local-optimization ;
+: alias-analysis ( cfg -- cfg )
+ dup [ alias-analysis-step ] simple-optimization ;
! Copyright (C) 2008, 2010 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 layouts
-compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.stack-frame ;
+combinators classes words cpu.architecture layouts compiler.cfg
+compiler.cfg.rpo compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.stack-frame ;
IN: compiler.cfg.build-stack-frame
SYMBOL: frame-required?
M: ##call compute-stack-frame* drop frame-required? on ;
-M: ##gc compute-stack-frame*
+M: ##call-gc compute-stack-frame*
+ drop
frame-required? on
- stack-frame new
- swap tagged-values>> length cells >>gc-root-size
- t >>calls-vm?
- request-stack-frame ;
-
-M: _spill-area-size compute-stack-frame*
- n>> stack-frame get (>>spill-area-size) ;
+ stack-frame new t >>calls-vm? request-stack-frame ;
M: insn compute-stack-frame*
- class frame-required? word-prop [
- frame-required? on
- ] when ;
+ class "frame-required?" word-prop
+ [ frame-required? on ] when ;
-\ _spill t frame-required? set-word-prop
-\ ##unary-float-function t frame-required? set-word-prop
-\ ##binary-float-function t frame-required? set-word-prop
+: initial-stack-frame ( -- stack-frame )
+ stack-frame new cfg get spill-area-size>> >>spill-area-size ;
: compute-stack-frame ( insns -- )
frame-required? off
- stack-frame new stack-frame set
- [ compute-stack-frame* ] each
+ initial-stack-frame stack-frame set
+ [ instructions>> [ compute-stack-frame* ] each ] each-basic-block
stack-frame get dup stack-frame-size >>total-size drop ;
-GENERIC: insert-pro/epilogues* ( insn -- )
-
-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 )
+: build-stack-frame ( cfg -- cfg )
[
+ [ compute-stack-frame ]
[
- [ compute-stack-frame ]
- [ insert-pro/epilogues ]
- bi
- ] change-instructions
+ frame-required? get stack-frame get f ?
+ >>stack-frame
+ ] bi
] with-scope ;
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
-compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
-compiler.cfg arrays locals byte-arrays kernel.private math
-slots.private vectors sbufs strings math.partial-dispatch
-hashtables assocs combinators.short-circuit
-strings.private accessors compiler.cfg.instructions ;
+prettyprint alien alien.accessors math.private
+compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.debugger
+compiler.cfg.optimizer compiler.cfg.rpo
+compiler.cfg.predecessors compiler.cfg.checker compiler.cfg
+arrays locals byte-arrays kernel.private math slots.private
+vectors sbufs strings math.partial-dispatch hashtables assocs
+combinators.short-circuit strings.private accessors
+compiler.cfg.instructions compiler.cfg.representations ;
FROM: alien.c-types => int ;
IN: compiler.cfg.builder.tests
! Just ensure that various CFGs build correctly.
-: unit-test-cfg ( quot -- )
- '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
+: unit-test-builder ( quot -- )
+ '[ _ test-builder [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
: blahblah ( nodes -- ? )
{ fixnum } declare [
set-string-nth-fast
]
} [
- unit-test-cfg
+ unit-test-builder
] each
: test-1 ( -- ) test-1 ;
test-1
test-2
test-3
-} [ unit-test-cfg ] each
+} [ unit-test-builder ] each
{
byte-array
alien-float
alien-double
} [| word |
- { class } word '[ _ declare 10 _ execute ] unit-test-cfg
- { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+ { class } word '[ _ declare 10 _ execute ] unit-test-builder
+ { class fixnum } word '[ _ declare _ execute ] unit-test-builder
] each
{
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
+ { fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder
+ { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
] 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-float '[ _ declare 10 _ execute ] unit-test-builder
+ { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-builder
- { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
- { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
+ { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-builder
+ { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-builder
- { 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
+ { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-builder
+ { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
] each
: count-insns ( quot insn-check -- ? )
- [ test-mr [ instructions>> ] map ] dip
- '[ _ count ] map-sum ; inline
+ [ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip
+ count ; inline
: contains-insn? ( quot insn-check -- ? )
count-insns 0 > ; inline
[ t ] [
[ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
- [ ##set-alien-integer-1? ] contains-insn?
+ [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
] unit-test
[ t ] [
[ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
- [ ##set-alien-integer-1? ] contains-insn?
+ [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
] unit-test
[ f ] [
[ { byte-array fixnum } declare set-alien-unsigned-1 ]
- [ ##set-alien-integer-1? ] contains-insn?
+ [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
+] unit-test
+
+[ t t ] [
+ [ { byte-array fixnum } declare alien-cell ]
+ [ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn? ]
+ [ [ ##box-alien? ] contains-insn? ]
+ bi
+] unit-test
+
+[ f ] [
+ [ { byte-array integer } declare alien-cell ]
+ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn?
] unit-test
[ f ] [
[ [ ##allot? ] contains-insn? ] bi
] unit-test
- [ 1 ] [ [ dup float+ ] [ ##alien-double? ] count-insns ] unit-test
+ [ 1 ] [ [ dup float+ ] [ ##load-memory-imm? ] count-insns ] unit-test
] when
! Regression. Make sure everything is inlined correctly
and ;
: emit-trivial-if ( -- )
- ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
+ [ f cc/= ^^compare-imm ] unary-op ;
: trivial-not-if? ( #if -- ? )
children>> first2
and ;
: emit-trivial-not-if ( -- )
- ds-pop \ f type-number cc= ^^compare-imm ds-push ;
+ [ f cc= ^^compare-imm ] unary-op ;
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
- ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
+ ds-pop any-rep ^^copy f cc/= ##compare-imm-branch emit-if ;
M: #if emit-node
{
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math vectors arrays accessors namespaces ;
IN: compiler.cfg
number
{ instructions vector }
{ successors vector }
-{ predecessors vector } ;
+{ predecessors vector }
+{ unlikely? boolean } ;
: <basic-block> ( -- bb )
basic-block new
M: basic-block hashcode* nip id>> ;
TUPLE: cfg { entry basic-block } word label
-spill-area-size reps
+spill-area-size
+stack-frame
post-order linear-order
predecessors-valid? dominance-valid? loops-valid? ;
: with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
[ dup cfg ] dip with-variable ; inline
-
-TUPLE: mr { instructions array } word label ;
-
-: <mr> ( instructions word label -- mr )
- mr new
- swap >>label
- swap >>word
- swap >>instructions ;
USING: kernel combinators.short-circuit accessors math sequences
sets assocs compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.def-use compiler.cfg.linearization
-compiler.cfg.utilities compiler.cfg.mr compiler.utilities ;
+compiler.cfg.utilities compiler.cfg.finalization
+compiler.utilities ;
IN: compiler.cfg.checker
! Check invariants
dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
- [ ##compare-branch? ]
- [ ##compare-imm-branch? ]
- [ ##compare-float-ordered-branch? ]
- [ ##compare-float-unordered-branch? ]
- [ ##fixnum-add? ]
- [ ##fixnum-sub? ]
- [ ##fixnum-mul? ]
+ [ conditional-branch-insn? ]
[ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
[ check-successors ]
bi ;
-ERROR: bad-live-in ;
-
-ERROR: undefined-values uses defs ;
-
-: check-mr ( mr -- )
- ! Check that every used register has a definition
- instructions>>
- [ [ uses-vregs ] map concat ]
- [ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi
- 2dup subset? [ 2drop ] [ undefined-values ] if ;
-
: check-cfg ( cfg -- )
- [ [ check-basic-block ] each-basic-block ]
- [ build-mr check-mr ]
- bi ;
+ [ check-basic-block ] each-basic-block ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs math.order sequences ;
IN: compiler.cfg.comparisons
SYMBOLS:
vcc-all vcc-notall vcc-any vcc-none ;
+SYMBOLS: cc-o cc/o ;
+
: negate-cc ( cc -- cc' )
H{
{ cc< cc/< }
{ cc/= cc= }
{ cc/<> cc<> }
{ cc/<>= cc<>= }
+ { cc-o cc/o }
+ { cc/o cc-o }
} at ;
: negate-vcc ( cc -- cc' )
--- /dev/null
+USING: compiler.cfg.copy-prop tools.test namespaces kernel
+compiler.cfg.debugger compiler.cfg accessors
+compiler.cfg.registers compiler.cfg.instructions
+cpu.architecture ;
+IN: compiler.cfg.copy-prop.tests
+
+: test-copy-propagation ( -- )
+ cfg new 0 get >>entry copy-propagation drop ;
+
+! Simple example
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 0 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##peek f 1 D 1 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##copy f 2 0 any-rep }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##phi f 3 H{ { 2 0 } { 3 2 } } }
+ T{ ##phi f 4 H{ { 2 1 } { 3 2 } } }
+ T{ ##phi f 5 H{ { 2 1 } { 3 0 } } }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##copy f 6 4 any-rep }
+ T{ ##replace f 3 D 0 }
+ T{ ##replace f 5 D 1 }
+ T{ ##replace f 6 D 2 }
+ T{ ##branch }
+} 5 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 6 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 5 edge
+
+[ ] [ test-copy-propagation ] unit-test
+
+[
+ V{
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 4 D 1 }
+ T{ ##replace f 4 D 2 }
+ T{ ##branch }
+ }
+] [ 5 get instructions>> ] unit-test
+
+! Test optimistic assumption
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 0 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##phi f 1 H{ { 1 0 } { 2 2 } } }
+ T{ ##copy f 2 1 any-rep }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##replace f 2 D 1 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 2 edge
+2 { 2 3 } edges
+3 4 edge
+
+[ ] [ test-copy-propagation ] unit-test
+
+[
+ V{
+ T{ ##replace f 0 D 1 }
+ T{ ##branch }
+ }
+] [ 3 get instructions>> ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs accessors sequences grouping
-combinators compiler.cfg.rpo compiler.cfg.renaming
-compiler.cfg.instructions compiler.cfg.predecessors ;
+USING: sets kernel namespaces assocs accessors sequences grouping
+combinators fry compiler.cfg.def-use compiler.cfg.rpo
+compiler.cfg.renaming compiler.cfg.instructions
+compiler.cfg.predecessors ;
+FROM: namespaces => set ;
IN: compiler.cfg.copy-prop
-! The first three definitions are also used in compiler.cfg.alias-analysis.
+<PRIVATE
+
+SYMBOL: changed?
+
SYMBOL: copies
-! Initialized per-basic-block; a mapping from inputs to dst for eliminating
-! redundant phi instructions
+! Initialized per-basic-block; a mapping from inputs to dst for
+! eliminating redundant ##phi instructions
SYMBOL: phis
: resolve ( vreg -- vreg )
- copies get ?at drop ;
-
-: (record-copy) ( dst src -- )
- swap copies get set-at ; inline
+ copies get at ;
-: record-copy ( ##copy -- )
- [ dst>> ] [ src>> resolve ] bi (record-copy) ; inline
-
-<PRIVATE
+: record-copy ( dst src -- )
+ swap copies get maybe-set-at [ changed? on ] when ; inline
GENERIC: visit-insn ( insn -- )
-M: ##copy visit-insn record-copy ;
+M: ##copy visit-insn
+ [ dst>> ] [ src>> resolve ] bi
+ dup [ record-copy ] [ 2drop ] if ;
-: useless-phi ( dst inputs -- ) first (record-copy) ;
+: useless-phi ( dst inputs -- ) first record-copy ;
-: redundant-phi ( dst inputs -- ) phis get at (record-copy) ;
+: redundant-phi ( dst inputs -- ) phis get at record-copy ;
-: record-phi ( dst inputs -- ) phis get set-at ;
+: record-phi ( dst inputs -- )
+ [ phis get set-at ] [ drop dup record-copy ] 2bi ;
M: ##phi visit-insn
[ dst>> ] [ inputs>> values [ resolve ] map ] bi
- {
- { [ dup all-equal? ] [ useless-phi ] }
- { [ dup phis get key? ] [ redundant-phi ] }
- [ record-phi ]
- } cond ;
+ dup phis get key? [ redundant-phi ] [
+ dup sift
+ dup all-equal?
+ [ nip useless-phi ]
+ [ drop record-phi ] if
+ ] if ;
+
+M: vreg-insn visit-insn
+ defs-vreg [ dup record-copy ] when* ;
M: insn visit-insn drop ;
-: collect-copies ( cfg -- )
- H{ } clone copies set
+: (collect-copies) ( cfg -- )
[
- H{ } clone phis set
+ phis get clear-assoc
instructions>> [ visit-insn ] each
] each-basic-block ;
+: collect-copies ( cfg -- )
+ H{ } clone copies set
+ H{ } clone phis set
+ '[
+ changed? off
+ _ (collect-copies)
+ changed? get
+ ] loop ;
+
GENERIC: update-insn ( insn -- keep? )
M: ##copy update-insn drop f ;
M: ##phi update-insn
- dup dst>> copies get key? [ drop f ] [ call-next-method ] if ;
+ dup call-next-method drop
+ [ dst>> ] [ inputs>> values ] bi [ = not ] with any? ;
+
+M: vreg-insn update-insn rename-insn-uses t ;
-M: insn update-insn rename-insn-uses t ;
+M: insn update-insn drop t ;
: rename-copies ( cfg -- )
- copies get dup assoc-empty? [ 2drop ] [
- renamings set
- [
- instructions>> [ update-insn ] filter! drop
- ] each-basic-block
- ] if ;
+ copies get renamings set
+ [ [ update-insn ] filter! ] simple-optimization ;
PRIVATE>
: copy-propagation ( cfg -- cfg' )
needs-predecessors
- [ collect-copies ]
- [ rename-copies ]
- [ ]
- tri ;
+ dup collect-copies
+ dup rename-copies ;
entry>> instructions>> ;
[ V{
- T{ ##load-immediate { dst 1 } { val 8 } }
- T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##load-integer { dst 1 } { val 8 } }
+ T{ ##load-integer { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
T{ ##replace { src 3 } { loc D 0 } }
} ] [ V{
- T{ ##load-immediate { dst 1 } { val 8 } }
- T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##load-integer { dst 1 } { val 8 } }
+ T{ ##load-integer { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
T{ ##replace { src 3 } { loc D 0 } }
} test-dce ] unit-test
[ V{ } ] [ V{
- T{ ##load-immediate { dst 1 } { val 8 } }
- T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##load-integer { dst 1 } { val 8 } }
+ T{ ##load-integer { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
- T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
- T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
} test-dce ] unit-test
[ V{
- T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
T{ ##replace { src 1 } { loc D 0 } }
} ] [ V{
- T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
T{ ##replace { src 1 } { loc D 0 } }
[ V{
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc D 0 } }
- T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##load-integer { dst 3 } { val 8 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
} ] [ V{
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc D 0 } }
- T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##load-integer { dst 3 } { val 8 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
} test-dce ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io vectors
arrays hashtables classes.tuple accessors prettyprint
compiler.tree.optimizer cpu.architecture compiler.cfg.builder
compiler.cfg.linearization compiler.cfg.registers
compiler.cfg.stack-frame compiler.cfg.linear-scan
-compiler.cfg.optimizer compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.def-use compiler.cfg.rpo
-compiler.cfg.mr compiler.cfg.representations.preferred
-compiler.cfg ;
+compiler.cfg.optimizer compiler.cfg.finalization
+compiler.cfg.instructions compiler.cfg.utilities
+compiler.cfg.def-use compiler.cfg.rpo
+compiler.cfg.representations compiler.cfg.gc-checks
+compiler.cfg.save-contexts compiler.cfg
+compiler.cfg.representations.preferred ;
+FROM: compiler.cfg.linearization => number-blocks ;
IN: compiler.cfg.debugger
-GENERIC: test-cfg ( quot -- cfgs )
+GENERIC: test-builder ( quot -- cfgs )
-M: callable test-cfg
+M: callable test-builder
0 vreg-counter set-global
build-tree optimize-tree gensym build-cfg ;
-M: word test-cfg
+M: word test-builder
0 vreg-counter set-global
[ build-tree optimize-tree ] keep build-cfg ;
-: test-mr ( quot -- mrs )
- test-cfg [
+: test-optimizer ( quot -- cfgs )
+ test-builder [ [ optimize-cfg ] with-cfg ] map ;
+
+: test-ssa ( quot -- cfgs )
+ test-builder [
[
optimize-cfg
- build-mr
] with-cfg
] map ;
-: insn. ( insn -- )
- tuple>array but-last [ pprint bl ] each nl ;
+: test-flat ( quot -- cfgs )
+ test-builder [
+ [
+ optimize-cfg
+ select-representations
+ insert-gc-checks
+ insert-save-contexts
+ ] with-cfg
+ ] map ;
-: mr. ( mrs -- )
+: test-regs ( quot -- cfgs )
+ test-builder [
+ [
+ optimize-cfg
+ finalize-cfg
+ ] with-cfg
+ ] map ;
+
+GENERIC: insn. ( insn -- )
+
+M: ##phi insn.
+ clone [ [ [ number>> ] dip ] assoc-map ] change-inputs
+ call-next-method ;
+
+M: insn insn. tuple>array but-last [ bl ] [ pprint ] interleave nl ;
+
+: block. ( bb -- )
+ "=== Basic block #" write dup block-number . nl
+ dup instructions>> [ insn. ] each nl
+ successors>> [
+ "Successors: " write
+ [ block-number unparse ] map ", " join print nl
+ ] unless-empty ;
+
+: cfg. ( cfg -- )
[
+ dup linearization-order number-blocks
"=== word: " write
dup word>> pprint
", label: " write
dup label>> pprint nl nl
- instructions>> [ insn. ] each
- nl
- ] each ;
+ dup linearization-order [ block. ] each
+ "=== stack frame: " write
+ stack-frame>> .
+ ] with-scope ;
+
+: cfgs. ( cfgs -- )
+ [ nl ] [ cfg. ] interleave ;
-: test-mr. ( quot -- )
- test-mr mr. ; inline
+: ssa. ( quot -- ) test-ssa cfgs. ;
+: flat. ( quot -- ) test-flat cfgs. ;
+: regs. ( quot -- ) test-regs cfgs. ;
! Prettyprinting
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
-! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays classes combinators
compiler.units fry generalizations generic kernel locals
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg.empty-blocks compiler.cfg.gc-checks
+compiler.cfg.representations compiler.cfg.save-contexts
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
+compiler.cfg.linear-scan compiler.cfg.scheduling ;
+IN: compiler.cfg.finalization
+
+: finalize-cfg ( cfg -- cfg' )
+ select-representations
+ schedule-instructions
+ insert-gc-checks
+ insert-save-contexts
+ destruct-ssa
+ linear-scan
+ build-stack-frame ;
-USING: compiler.cfg.gc-checks compiler.cfg.debugger
+USING: arrays compiler.cfg.gc-checks
+compiler.cfg.gc-checks.private compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
-compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
-namespaces accessors sequences ;
+compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
+tools.test kernel vectors namespaces accessors sequences alien
+memory classes make combinators.short-circuit byte-arrays ;
IN: compiler.cfg.gc-checks.tests
: test-gc-checks ( -- )
H{ } clone representations set
- cfg new 0 get >>entry
- insert-gc-checks
- drop ;
+ cfg new 0 get >>entry cfg set ;
V{
T{ ##inc-d f 3 }
[ ] [ test-gc-checks ] unit-test
-[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
+[ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
+
+[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
+
+2 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##load-tagged f 3 0 }
+ T{ ##replace f 3 D 0 }
+ T{ ##replace f 3 R 3 }
+ }
+] [ [ { D 0 R 3 } wipe-locs ] V{ } make ] unit-test
+
+: gc-check? ( bb -- ? )
+ instructions>>
+ {
+ [ length 1 = ]
+ [ first ##check-nursery-branch? ]
+ } 1&& ;
+
+[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
+
+4 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##load-tagged f 5 0 }
+ T{ ##replace f 5 D 0 }
+ T{ ##replace f 5 R 3 }
+ T{ ##call-gc f { 0 1 2 } }
+ T{ ##branch }
+ }
+]
+[
+ { D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
+] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##branch }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get needs-predecessors drop ] unit-test
+
+[ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 2 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 2 D 0 }
+ T{ ##inc-d f 3 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##allot f 1 64 byte-array }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##replace f 2 D 1 }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 5 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 5 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+H{
+ { 2 tagged-rep }
+} representations set
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[ 2 ] [ 2 get predecessors>> length ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ 64 ] [ 1 get successors>> first instructions>> first size>> ] unit-test
+
+[ t ] [ 2 get predecessors>> first gc-check? ] unit-test
+
+[
+ V{
+ T{ ##load-tagged f 31 0 }
+ T{ ##replace f 31 D 0 }
+ T{ ##replace f 31 D 1 }
+ T{ ##replace f 31 D 2 }
+ T{ ##call-gc f { 2 } }
+ T{ ##branch }
+ }
+] [ 2 get predecessors>> second instructions>> ] unit-test
+
+! Don't forget to invalidate RPO after inserting basic blocks!
+[ 8 ] [ cfg get reverse-post-order length ] unit-test
+
+! Do the right thing with ##phi instructions
+V{
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##load-reference f 1 "hi" }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##load-reference f 2 "bye" }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
+ T{ ##allot f 1 64 byte-array }
+ T{ ##branch }
+} 3 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+H{
+ { 1 tagged-rep }
+ { 2 tagged-rep }
+ { 3 tagged-rep }
+} representations set
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
+[ 2 ] [ 3 get instructions>> length ] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs fry math
-cpu.architecture layouts namespaces
+USING: accessors assocs combinators fry kernel layouts locals
+math make namespaces sequences cpu.architecture
+compiler.cfg
compiler.cfg.rpo
+compiler.cfg.hats
compiler.cfg.registers
+compiler.cfg.utilities
+compiler.cfg.comparisons
compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.liveness
+compiler.cfg.liveness.ssa
compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.gc-checks
-! Garbage collection check insertion. This pass runs after representation
-! selection, so it must keep track of representations.
+<PRIVATE
+
+! Garbage collection check insertion. This pass runs after
+! representation selection, since it needs to know which vregs
+! can contain tagged pointers.
: insert-gc-check? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
: blocks-with-gc ( cfg -- bbs )
post-order [ insert-gc-check? ] filter ;
+! A GC check for bb consists of two new basic blocks, gc-check
+! and gc-call:
+!
+! gc-check
+! / \
+! | gc-call
+! \ /
+! bb
+
+! Any ##phi instructions at the start of bb are transplanted
+! into the gc-check block.
+
+: <gc-check> ( phis size -- bb )
+ [ <basic-block> ] 2dip
+ [
+ [ % ]
+ [
+ cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+ ##check-nursery-branch
+ ] bi*
+ ] V{ } make >>instructions ;
+
+: wipe-locs ( uninitialized-locs -- )
+ '[
+ int-rep next-vreg-rep
+ [ 0 ##load-tagged ]
+ [ '[ [ _ ] dip ##replace ] each ] bi
+ ] unless-empty ;
+
+: <gc-call> ( uninitialized-locs gc-roots -- bb )
+ [ <basic-block> ] 2dip
+ [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
+ >>instructions t >>unlikely? ;
+
+:: insert-guard ( body check bb -- )
+ bb predecessors>> check (>>predecessors)
+ V{ bb body } check (>>successors)
+
+ V{ check } body (>>predecessors)
+ V{ bb } body (>>successors)
+
+ V{ check body } bb (>>predecessors)
+
+ check predecessors>> [ bb check update-successors ] each ;
+
+: (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
+ [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
+
GENERIC: allocation-size* ( insn -- n )
M: ##allot allocation-size* size>> ;
[ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ;
+: gc-live-in ( bb -- vregs )
+ [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
+ append ;
+
+: live-tagged ( bb -- vregs )
+ gc-live-in [ rep-of tagged-rep? ] filter ;
+
+: remove-phis ( bb -- phis )
+ [ [ ##phi? ] partition ] change-instructions drop ;
+
: insert-gc-check ( bb -- )
- dup dup '[
- int-rep next-vreg-rep
- int-rep next-vreg-rep
- _ allocation-size
- f
- f
- _ uninitialized-locs
- \ ##gc new-insn
- prefix
- ] change-instructions drop ;
+ {
+ [ uninitialized-locs ]
+ [ live-tagged ]
+ [ remove-phis ]
+ [ allocation-size ]
+ [ ]
+ } cleave
+ (insert-gc-check) ;
+
+PRIVATE>
: insert-gc-checks ( cfg -- cfg' )
dup blocks-with-gc [
- over compute-uninitialized-sets
+ [
+ needs-predecessors
+ dup compute-ssa-live-sets
+ dup compute-uninitialized-sets
+ ] dip
[ insert-gc-check ] each
+ cfg-changed
] unless-empty ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays kernel layouts math
-namespaces sequences combinators splitting parser effects
-words cpu.architecture compiler.cfg.registers
+USING: accessors alien arrays byte-arrays classes.algebra
+combinators.short-circuit kernel layouts math namespaces
+sequences combinators splitting parser effects words
+cpu.architecture compiler.constants compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions.syntax ;
IN: compiler.cfg.hats
>>
: ^^load-literal ( obj -- dst )
- [ next-vreg dup ] dip {
- { [ dup not ] [ drop \ f type-number ##load-immediate ] }
- { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
- { [ dup float? ] [ ##load-constant ] }
- [ ##load-reference ]
- } cond ;
+ dup fixnum? [ ^^load-integer ] [ ^^load-reference ] if ;
: ^^offset>slot ( slot -- vreg' )
- cell 4 = 2 1 ? ^^shr-imm ;
+ cell 4 = 2 3 ? ^^shl-imm ;
+
+: ^^unbox-f ( src -- dst )
+ drop 0 ^^load-literal ;
-: ^^tag-fixnum ( src -- dst )
- tag-bits get ^^shl-imm ;
+: ^^unbox-byte-array ( src -- dst )
+ ^^tagged>integer byte-array-offset ^^add-imm ;
-: ^^untag-fixnum ( src -- dst )
- tag-bits get ^^sar-imm ;
+: ^^unbox-c-ptr ( src class -- dst )
+ {
+ { [ dup \ f class<= ] [ drop ^^unbox-f ] }
+ { [ dup alien class<= ] [ drop ^^unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop ^^unbox-byte-array ] }
+ [ drop ^^unbox-any-c-ptr ]
+ } cond ;
! Copyright (C) 2008, 2010 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 classes.union
-compiler.units alien byte-arrays compiler.constants combinators
-compiler.cfg.registers compiler.cfg.instructions.syntax ;
+math math.order layouts classes.union compiler.units alien
+byte-arrays combinators compiler.cfg.registers
+compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
<<
! value numbering
TUPLE: pure-insn < insn ;
-! Stack operations
-INSN: ##load-immediate
+! Constants
+INSN: ##load-integer
def: dst/int-rep
-constant: val ;
+literal: val ;
INSN: ##load-reference
-def: dst/int-rep
-constant: obj ;
+def: dst/tagged-rep
+literal: obj ;
-INSN: ##load-constant
-def: dst/int-rep
-constant: obj ;
+! These three are inserted by representation selection
+INSN: ##load-tagged
+def: dst/tagged-rep
+literal: val ;
+
+INSN: ##load-double
+def: dst/double-rep
+literal: val ;
+INSN: ##load-vector
+def: dst
+literal: val rep ;
+
+! Stack operations
INSN: ##peek
-def: dst/int-rep
+def: dst/tagged-rep
literal: loc ;
INSN: ##replace
-use: src/int-rep
+use: src/tagged-rep
literal: loc ;
+INSN: ##replace-imm
+literal: src loc ;
+
INSN: ##inc-d
literal: n ;
INSN: ##jump
literal: word ;
+INSN: ##prologue ;
+
+INSN: ##epilogue ;
+
INSN: ##return ;
! Dummy instruction that simply inhibits TCO
! Slot access
INSN: ##slot
-def: dst/int-rep
-use: obj/int-rep slot/int-rep ;
+def: dst/tagged-rep
+use: obj/tagged-rep slot/int-rep
+literal: scale tag ;
INSN: ##slot-imm
-def: dst/int-rep
-use: obj/int-rep
+def: dst/tagged-rep
+use: obj/tagged-rep
literal: slot tag ;
INSN: ##set-slot
-use: src/int-rep obj/int-rep slot/int-rep ;
+use: src/tagged-rep obj/tagged-rep slot/int-rep
+literal: scale tag ;
INSN: ##set-slot-imm
-use: src/int-rep obj/int-rep
+use: src/tagged-rep obj/tagged-rep
literal: slot tag ;
-! String element access
-INSN: ##string-nth
-def: dst/int-rep
-use: obj/int-rep index/int-rep
-temp: temp/int-rep ;
-
-INSN: ##set-string-nth-fast
-use: src/int-rep obj/int-rep index/int-rep
-temp: temp/int-rep ;
-
-PURE-INSN: ##copy
+! Register transfers
+INSN: ##copy
def: dst
use: src
literal: rep ;
+PURE-INSN: ##tagged>integer
+def: dst/int-rep
+use: src/tagged-rep ;
+
! Integer arithmetic
PURE-INSN: ##add
def: dst/int-rep
PURE-INSN: ##add-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##sub
def: dst/int-rep
PURE-INSN: ##sub-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##mul
def: dst/int-rep
PURE-INSN: ##mul-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##and
def: dst/int-rep
PURE-INSN: ##and-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##or
def: dst/int-rep
PURE-INSN: ##or-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##xor
def: dst/int-rep
PURE-INSN: ##xor-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##shl
def: dst/int-rep
PURE-INSN: ##shl-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##shr
def: dst/int-rep
PURE-INSN: ##shr-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##sar
def: dst/int-rep
PURE-INSN: ##sar-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##min
def: dst/int-rep
literal: rep cc ;
PURE-INSN: ##test-vector
-def: dst/int-rep
+def: dst/tagged-rep
use: src1
temp: temp/int-rep
literal: rep vcc ;
! Boxing and unboxing aliens
PURE-INSN: ##box-alien
-def: dst/int-rep
+def: dst/tagged-rep
use: src/int-rep
temp: temp/int-rep ;
PURE-INSN: ##box-displaced-alien
-def: dst/int-rep
-use: displacement/int-rep base/int-rep
+def: dst/tagged-rep
+use: displacement/int-rep base/tagged-rep
temp: temp/int-rep
literal: base-class ;
PURE-INSN: ##unbox-any-c-ptr
def: dst/int-rep
-use: src/int-rep ;
-
-: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
-: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
+use: src/tagged-rep ;
PURE-INSN: ##unbox-alien
def: dst/int-rep
-use: src/int-rep ;
-
-: ##unbox-c-ptr ( dst src class -- )
- {
- { [ dup \ f class<= ] [ drop ##unbox-f ] }
- { [ dup alien class<= ] [ drop ##unbox-alien ] }
- { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
- [ drop ##unbox-any-c-ptr ]
- } cond ;
-
-! Alien accessors
-INSN: ##alien-unsigned-1
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-unsigned-2
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-unsigned-4
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-1
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-2
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-4
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-cell
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-float
-def: dst/float-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-double
-def: dst/double-rep
-use: src/int-rep
-literal: offset ;
+use: src/tagged-rep ;
-INSN: ##alien-vector
+! Raw memory accessors
+INSN: ##load-memory
def: dst
-use: src/int-rep
-literal: offset rep ;
-
-INSN: ##set-alien-integer-1
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
+use: base/int-rep displacement/int-rep
+literal: scale offset rep c-type ;
-INSN: ##set-alien-integer-2
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
-
-INSN: ##set-alien-integer-4
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
-
-INSN: ##set-alien-cell
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
+INSN: ##load-memory-imm
+def: dst
+use: base/int-rep
+literal: offset rep c-type ;
-INSN: ##set-alien-float
-use: src/int-rep
-literal: offset
-use: value/float-rep ;
+INSN: ##store-memory
+use: src base/int-rep displacement/int-rep
+literal: scale offset rep c-type ;
-INSN: ##set-alien-double
-use: src/int-rep
-literal: offset
-use: value/double-rep ;
-
-INSN: ##set-alien-vector
-use: src/int-rep
-literal: offset
-use: value
-literal: rep ;
+INSN: ##store-memory-imm
+use: src base/int-rep
+literal: offset rep c-type ;
! Memory allocation
INSN: ##allot
-def: dst/int-rep
+def: dst/tagged-rep
literal: size class
temp: temp/int-rep ;
INSN: ##write-barrier
-use: src/int-rep slot/int-rep
+use: src/tagged-rep slot/int-rep
+literal: scale tag
temp: temp1/int-rep temp2/int-rep ;
INSN: ##write-barrier-imm
-use: src/int-rep
-literal: slot
+use: src/tagged-rep
+literal: slot tag
temp: temp1/int-rep temp2/int-rep ;
INSN: ##alien-global
literal: symbol library ;
INSN: ##vm-field
-def: dst/int-rep
+def: dst/tagged-rep
literal: offset ;
INSN: ##set-vm-field
-use: src/int-rep
+use: src/tagged-rep
literal: offset ;
! FFI
INSN: ##alien-callback
literal: params stack-frame ;
-! Instructions used by CFG IR only.
-INSN: ##prologue ;
-INSN: ##epilogue ;
-
-INSN: ##branch ;
-
+! Control flow
INSN: ##phi
def: dst
literal: inputs ;
-! Conditionals
+INSN: ##branch ;
+
+! Tagged conditionals
INSN: ##compare-branch
-use: src1/int-rep src2/int-rep
+use: src1/tagged-rep src2/tagged-rep
literal: cc ;
INSN: ##compare-imm-branch
-use: src1/int-rep
-constant: src2
-literal: cc ;
+use: src1/tagged-rep
+literal: src2 cc ;
PURE-INSN: ##compare
-def: dst/int-rep
-use: src1/int-rep src2/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep
literal: cc
temp: temp/int-rep ;
PURE-INSN: ##compare-imm
-def: dst/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
+literal: src2 cc
+temp: temp/int-rep ;
+
+! Integer conditionals
+INSN: ##compare-integer-branch
+use: src1/int-rep src2/int-rep
+literal: cc ;
+
+INSN: ##compare-integer-imm-branch
use: src1/int-rep
-constant: src2
+literal: src2 cc ;
+
+PURE-INSN: ##compare-integer
+def: dst/tagged-rep
+use: src1/int-rep src2/int-rep
literal: cc
temp: temp/int-rep ;
+PURE-INSN: ##compare-integer-imm
+def: dst/tagged-rep
+use: src1/int-rep
+literal: src2 cc
+temp: temp/int-rep ;
+
+! Float conditionals
INSN: ##compare-float-ordered-branch
use: src1/double-rep src2/double-rep
literal: cc ;
literal: cc ;
PURE-INSN: ##compare-float-ordered
-def: dst/int-rep
+def: dst/tagged-rep
use: src1/double-rep src2/double-rep
literal: cc
temp: temp/int-rep ;
PURE-INSN: ##compare-float-unordered
-def: dst/int-rep
+def: dst/tagged-rep
use: src1/double-rep src2/double-rep
literal: cc
temp: temp/int-rep ;
! Overflowing arithmetic
INSN: ##fixnum-add
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
INSN: ##fixnum-sub
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
INSN: ##fixnum-mul
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
-
-INSN: ##gc
-temp: temp1/int-rep temp2/int-rep
-literal: size data-values tagged-values uninitialized-locs ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/int-rep
+literal: cc ;
INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ;
-! Instructions used by machine IR only.
-INSN: _prologue
-literal: stack-frame ;
-
-INSN: _epilogue
-literal: stack-frame ;
-
-INSN: _label
-literal: label ;
-
-INSN: _branch
-literal: label ;
-
-INSN: _loop-entry ;
-
-INSN: _dispatch
-use: src/int-rep
-temp: temp ;
-
-INSN: _dispatch-label
-literal: label ;
-
-INSN: _compare-branch
-literal: label
-use: src1/int-rep src2/int-rep
-literal: cc ;
-
-INSN: _compare-imm-branch
-literal: label
-use: src1/int-rep
-constant: src2
-literal: cc ;
-
-INSN: _compare-float-unordered-branch
-literal: label
-use: src1/int-rep src2/int-rep
-literal: cc ;
-
-INSN: _compare-float-ordered-branch
-literal: label
-use: src1/int-rep src2/int-rep
-literal: cc ;
-
-! Overflowing arithmetic
-INSN: _fixnum-add
-literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
-
-INSN: _fixnum-sub
-literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+! GC checks
+INSN: ##check-nursery-branch
+literal: size cc
+temp: temp1/int-rep temp2/int-rep ;
-INSN: _fixnum-mul
-literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+INSN: ##call-gc
+literal: gc-roots ;
+! Spills and reloads, inserted by register allocator
TUPLE: spill-slot { n integer } ;
C: <spill-slot> spill-slot
-! These instructions operate on machine registers and not
-! virtual registers
-INSN: _spill
+INSN: ##spill
use: src
literal: rep dst ;
-INSN: _reload
+INSN: ##reload
def: dst
literal: rep src ;
-INSN: _spill-area-size
-literal: n ;
-
UNION: ##allocation
##allot
##box-alien
##box-displaced-alien ;
+UNION: conditional-branch-insn
+##compare-branch
+##compare-imm-branch
+##compare-integer-branch
+##compare-integer-imm-branch
+##compare-float-ordered-branch
+##compare-float-unordered-branch
+##test-vector-branch
+##check-nursery-branch
+##fixnum-add
+##fixnum-sub
+##fixnum-mul ;
+
! For alias analysis
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
-! Instructions that kill all live vregs but cannot trigger GC
-UNION: partial-sync-insn
+! Instructions that clobber registers
+UNION: clobber-insn
+##call-gc
##unary-float-function
##binary-float-function ;
UNION: def-is-use-insn
##box-alien
##box-displaced-alien
-##string-nth
##unbox-any-c-ptr ;
SYMBOL: vreg-insn
combinators splitting classes.parser lexer quotations ;
IN: compiler.cfg.instructions.syntax
-SYMBOLS: def use temp literal constant ;
+SYMBOLS: def use temp literal ;
SYMBOL: scalar-rep
{ "use:" [ drop use ] }
{ "temp:" [ drop temp ] }
{ "literal:" [ drop literal ] }
- { "constant:" [ drop constant ] }
[ dupd parse-insn-slot-spec , ]
} case
] reduce drop
] { } make ;
-: insn-def-slot ( class -- slot/f )
- "insn-slots" word-prop
+: find-def-slot ( slots -- slot/f )
[ type>> def eq? ] find nip ;
+: insn-def-slot ( class -- slot/f )
+ "insn-slots" word-prop find-def-slot ;
+
: insn-use-slots ( class -- slots )
- "insn-slots" word-prop
- [ type>> use eq? ] filter ;
+ "insn-slots" word-prop [ type>> use eq? ] filter ;
: insn-temp-slots ( class -- slots )
- "insn-slots" word-prop
- [ type>> temp eq? ] filter ;
+ "insn-slots" word-prop [ type>> temp eq? ] filter ;
! We cannot reference words in compiler.cfg.instructions directly
! since that would create circularity.
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences alien math classes.algebra fry
locals combinators combinators.short-circuit cpu.architecture
: emit-<displaced-alien> ( node -- )
dup emit-<displaced-alien>? [
- [ 2inputs [ ^^untag-fixnum ] dip ] dip
- node-input-infos second class>>
- ^^box-displaced-alien ds-push
+ '[
+ _ node-input-infos second class>>
+ ^^box-displaced-alien
+ ] binary-op
] [ emit-primitive ] if ;
-:: inline-alien ( node quot test -- )
+:: inline-accessor ( node quot test -- )
node node-input-infos :> infos
infos test call
[ infos quot call ]
[ node emit-primitive ] if ; inline
-: inline-alien-getter? ( infos -- ? )
+: inline-load-memory? ( infos -- ? )
[ first class>> c-ptr class<= ]
[ second class>> fixnum class<= ]
bi and ;
-: ^^unbox-c-ptr ( src class -- dst )
- [ next-vreg dup ] 2dip ##unbox-c-ptr ;
+: prepare-accessor ( base offset info -- base offset )
+ class>> swap [ ^^unbox-c-ptr ] dip ^^add 0 ;
-: prepare-alien-accessor ( info -- ptr-vreg offset )
- class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
+: prepare-load-memory ( infos -- base offset )
+ [ 2inputs ] dip first prepare-accessor ;
-: prepare-alien-getter ( infos -- ptr-vreg offset )
- first prepare-alien-accessor ;
+: (emit-load-memory) ( node rep c-type quot -- )
+ '[ prepare-load-memory _ _ ^^load-memory-imm @ ds-push ]
+ [ inline-load-memory? ]
+ inline-accessor ; inline
-: inline-alien-getter ( node quot -- )
- '[ prepare-alien-getter @ ds-push ]
- [ inline-alien-getter? ] inline-alien ; inline
+: emit-load-memory ( node rep c-type -- )
+ [ ] (emit-load-memory) ;
-: inline-alien-setter? ( infos class -- ? )
+: emit-alien-cell ( node -- )
+ int-rep f [ ^^box-alien ] (emit-load-memory) ;
+
+: inline-store-memory? ( infos class -- ? )
'[ first class>> _ class<= ]
[ second class>> c-ptr class<= ]
[ third class>> fixnum class<= ]
tri and and ;
-: prepare-alien-setter ( infos -- ptr-vreg offset )
- second prepare-alien-accessor ;
-
-: inline-alien-integer-setter ( node quot -- )
- '[ prepare-alien-setter ds-pop ^^untag-fixnum @ ]
- [ fixnum inline-alien-setter? ]
- inline-alien ; inline
-
-: inline-alien-cell-setter ( node quot -- )
- '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
- [ pinned-c-ptr inline-alien-setter? ]
- inline-alien ; inline
-
-: inline-alien-float-setter ( node quot -- )
- '[ prepare-alien-setter ds-pop @ ]
- [ 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 rep -- )
- '[
- _ {
- { float-rep [ ^^alien-float ] }
- { double-rep [ ^^alien-double ] }
- } case
- ] inline-alien-getter ;
-
-: emit-alien-float-setter ( node rep -- )
- '[
- _ {
- { float-rep [ ##set-alien-float ] }
- { double-rep [ ##set-alien-double ] }
+: prepare-store-memory ( infos -- value base offset )
+ [ 3inputs ] dip second prepare-accessor ;
+
+:: (emit-store-memory) ( node rep c-type prepare-quot test-quot -- )
+ node
+ [ prepare-quot call rep c-type ##store-memory-imm ]
+ [ test-quot call inline-store-memory? ]
+ inline-accessor ; inline
+
+:: emit-store-memory ( node rep c-type -- )
+ node rep c-type
+ [ prepare-store-memory ]
+ [
+ rep {
+ { int-rep [ fixnum ] }
+ { float-rep [ float ] }
+ { double-rep [ float ] }
} case
- ] inline-alien-float-setter ;
+ ]
+ (emit-store-memory) ;
+
+: emit-set-alien-cell ( node -- )
+ int-rep f
+ [
+ [ first class>> ] [ prepare-store-memory ] bi
+ [ swap ^^unbox-c-ptr ] 2dip
+ ]
+ [ pinned-c-ptr ]
+ (emit-store-memory) ;
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math math.intervals
namespaces combinators fry arrays
cpu.architecture
compiler.tree.propagation.info
+compiler.cfg
compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.instructions
IN: compiler.cfg.intrinsics.fixnum
: emit-both-fixnums? ( -- )
- 2inputs
- ^^or
- tag-mask get ^^and-imm
- 0 cc= ^^compare-imm
- ds-push ;
-
-: tag-literal ( n -- tagged )
- literal>> [ tag-fixnum ] [ \ f type-number ] if* ;
-
-: emit-fixnum-op ( insn -- )
- [ 2inputs ] dip call ds-push ; inline
+ [
+ [ ^^tagged>integer ] bi@
+ ^^or tag-mask get ^^and-imm
+ 0 cc= ^^compare-integer-imm
+ ] binary-op ;
: emit-fixnum-left-shift ( -- )
- [ ^^untag-fixnum ^^shl ] emit-fixnum-op ;
+ [ ^^shl ] binary-op ;
: emit-fixnum-right-shift ( -- )
- [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
+ [
+ [ tag-bits get ^^shl-imm ] dip
+ ^^neg ^^sar
+ tag-bits get ^^sar-imm
+ ] binary-op ;
: emit-fixnum-shift-general ( -- )
- ds-peek 0 cc> ##compare-imm-branch
+ ds-peek 0 cc> ##compare-integer-imm-branch
[ emit-fixnum-left-shift ] with-branch
[ emit-fixnum-right-shift ] with-branch
2array emit-conditional ;
{ [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] }
[ drop emit-fixnum-shift-general ]
} cond ;
-
-: emit-fixnum-bitnot ( -- )
- ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
-
-: emit-fixnum-log2 ( -- )
- ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
-
-: emit-fixnum*fast ( -- )
- 2inputs ^^untag-fixnum ^^mul ds-push ;
: emit-fixnum-comparison ( cc -- )
- '[ _ ^^compare ] emit-fixnum-op ;
+ '[ _ ^^compare-integer ] binary-op ;
: emit-no-overflow-case ( dst -- final-bb )
[ ds-drop ds-drop ds-push ] with-branch ;
: emit-fixnum-overflow-op ( quot word -- )
! Inputs to the final instruction need to be copied because
! of loc>vreg sync
- [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
+ [ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
emit-conditional ; inline
[ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
: emit-fixnum* ( -- )
- [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
\ No newline at end of file
+ [ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
\ No newline at end of file
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.stacks compiler.cfg.hats
+USING: fry kernel compiler.cfg.stacks compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.float
-: emit-float-op ( insn -- )
- [ 2inputs ] dip call ds-push ; inline
-
: emit-float-ordered-comparison ( cc -- )
- [ 2inputs ] dip ^^compare-float-ordered ds-push ; inline
+ '[ _ ^^compare-float-ordered ] binary-op ; inline
: emit-float-unordered-comparison ( cc -- )
- [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
-
-: emit-float>fixnum ( -- )
- ds-pop ^^float>integer ^^tag-fixnum ds-push ;
-
-: emit-fixnum>float ( -- )
- ds-pop ^^untag-fixnum ^^integer>float ds-push ;
-
-: emit-fsqrt ( -- )
- ds-pop ^^sqrt ds-push ;
+ '[ _ ^^compare-float-unordered ] binary-op ; inline
: emit-unary-float-function ( func -- )
- [ ds-pop ] dip ^^unary-float-function ds-push ;
+ '[ _ ^^unary-float-function ] unary-op ;
: emit-binary-float-function ( func -- )
- [ 2inputs ] dip ^^binary-float-function ds-push ;
+ '[ _ ^^binary-float-function ] binary-op ;
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel combinators cpu.architecture assocs
compiler.cfg.hats
+compiler.cfg.stacks
compiler.cfg.instructions
compiler.cfg.intrinsics.alien
compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots
+compiler.cfg.intrinsics.strings
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
QUALIFIED: alien
QUALIFIED: alien.accessors
+QUALIFIED: alien.c-types
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
{ math.private:fixnum+ [ drop emit-fixnum+ ] }
{ math.private:fixnum- [ drop emit-fixnum- ] }
{ math.private:fixnum* [ drop emit-fixnum* ] }
- { math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
- { math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
- { math.private:fixnum*fast [ drop emit-fixnum*fast ] }
- { math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
- { math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
- { math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
+ { math.private:fixnum+fast [ drop [ ^^add ] binary-op ] }
+ { math.private:fixnum-fast [ drop [ ^^sub ] binary-op ] }
+ { math.private:fixnum*fast [ drop [ ^^mul ] binary-op ] }
+ { math.private:fixnum-bitand [ drop [ ^^and ] binary-op ] }
+ { math.private:fixnum-bitor [ drop [ ^^or ] binary-op ] }
+ { math.private:fixnum-bitxor [ drop [ ^^xor ] binary-op ] }
{ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
- { math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+ { math.private:fixnum-bitnot [ drop [ ^^not ] unary-op ] }
{ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
{ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
{ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
{ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
- { kernel:eq? [ drop cc= emit-fixnum-comparison ] }
+ { kernel:eq? [ emit-eq ] }
{ slots.private:slot [ emit-slot ] }
{ slots.private:set-slot [ emit-set-slot ] }
- { strings.private:string-nth [ drop emit-string-nth ] }
+ { strings.private:string-nth-fast [ drop emit-string-nth-fast ] }
{ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
{ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
{ arrays:<array> [ emit-<array> ] }
{ byte-arrays:(byte-array) [ emit-(byte-array) ] }
{ kernel:<wrapper> [ emit-simple-allot ] }
{ alien:<displaced-alien> [ emit-<displaced-alien> ] }
- { 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-cell [ emit-alien-cell-getter ] }
- { alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+ { alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] }
+ { alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] }
+ { alien.accessors:alien-signed-1 [ int-rep alien.c-types:char emit-load-memory ] }
+ { alien.accessors:set-alien-signed-1 [ int-rep alien.c-types:char emit-store-memory ] }
+ { alien.accessors:alien-unsigned-2 [ int-rep alien.c-types:ushort emit-load-memory ] }
+ { alien.accessors:set-alien-unsigned-2 [ int-rep alien.c-types:ushort emit-store-memory ] }
+ { alien.accessors:alien-signed-2 [ int-rep alien.c-types:short emit-load-memory ] }
+ { alien.accessors:set-alien-signed-2 [ int-rep alien.c-types:short emit-store-memory ] }
+ { alien.accessors:alien-cell [ emit-alien-cell ] }
+ { alien.accessors:set-alien-cell [ emit-set-alien-cell ] }
} enable-intrinsics
: enable-alien-4-intrinsics ( -- )
{
- { 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-signed-4 [ int-rep alien.c-types:int emit-load-memory ] }
+ { alien.accessors:set-alien-signed-4 [ int-rep alien.c-types:int emit-store-memory ] }
+ { alien.accessors:alien-unsigned-4 [ int-rep alien.c-types:uint emit-load-memory ] }
+ { alien.accessors:set-alien-unsigned-4 [ int-rep alien.c-types:uint emit-store-memory ] }
} enable-intrinsics ;
: enable-float-intrinsics ( -- )
{
- { 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 [ ^^add-float ] binary-op ] }
+ { math.private:float- [ drop [ ^^sub-float ] binary-op ] }
+ { math.private:float* [ drop [ ^^mul-float ] binary-op ] }
+ { math.private:float/f [ drop [ ^^div-float ] binary-op ] }
{ math.private:float< [ drop cc< emit-float-ordered-comparison ] }
{ math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
{ math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
{ math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
{ math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
{ math.private:float= [ drop cc= emit-float-unordered-comparison ] }
- { math.private:float>fixnum [ drop emit-float>fixnum ] }
- { math.private:fixnum>float [ drop emit-fixnum>float ] }
+ { math.private:float>fixnum [ drop [ ^^float>integer ] unary-op ] }
+ { math.private:fixnum>float [ drop [ ^^integer>float ] unary-op ] }
{ math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
- { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
- { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
- { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] }
- { alien.accessors:set-alien-double [ double-rep emit-alien-float-setter ] }
+ { alien.accessors:alien-float [ float-rep f emit-load-memory ] }
+ { alien.accessors:set-alien-float [ float-rep f emit-store-memory ] }
+ { alien.accessors:alien-double [ double-rep f emit-load-memory ] }
+ { alien.accessors:set-alien-double [ double-rep f emit-store-memory ] }
} enable-intrinsics ;
: enable-fsqrt ( -- )
{
- { math.libm:fsqrt [ drop emit-fsqrt ] }
+ { math.libm:fsqrt [ drop [ ^^sqrt ] unary-op ] }
} enable-intrinsics ;
: enable-float-min/max ( -- )
{
- { math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
- { math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
+ { math.floats.private:float-min [ drop [ ^^min-float ] binary-op ] }
+ { math.floats.private:float-max [ drop [ ^^max-float ] binary-op ] }
} enable-intrinsics ;
: enable-float-functions ( -- )
: enable-min/max ( -- )
{
- { math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
- { math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
+ { math.integers.private:fixnum-min [ drop [ ^^min ] binary-op ] }
+ { math.integers.private:fixnum-max [ drop [ ^^max ] binary-op ] }
} enable-intrinsics ;
-: enable-fixnum-log2 ( -- )
+: enable-log2 ( -- )
{
- { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
+ { math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-op ] }
} enable-intrinsics ;
: emit-intrinsic ( node word -- )
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces layouts sequences kernel math accessors
-compiler.tree.propagation.info compiler.cfg.stacks
-compiler.cfg.hats compiler.cfg.instructions
+USING: accessors classes.algebra layouts kernel math namespaces
+sequences cpu.architecture
+compiler.tree.propagation.info
+compiler.cfg.stacks
+compiler.cfg.hats
+compiler.cfg.comparisons
+compiler.cfg.instructions
compiler.cfg.builder.blocks
compiler.cfg.utilities ;
FROM: vm => context-field-offset vm-field-offset ;
+QUALIFIED-WITH: alien.c-types c
IN: compiler.cfg.intrinsics.misc
: emit-tag ( -- )
- ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
+ [ ^^tagged>integer tag-mask get ^^and-imm ] unary-op ;
+
+: emit-eq ( node -- )
+ node-input-infos first2 [ class>> fixnum class<= ] both?
+ [ [ cc= ^^compare-integer ] binary-op ] [ [ cc= ^^compare ] binary-op ] if ;
: special-object-offset ( n -- offset )
cells "special-objects" vm-field-offset + ;
] [ emit-primitive ] ?if ;
: emit-identity-hashcode ( -- )
- ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm
- hashcode-shift ^^shr-imm
- ^^tag-fixnum
- ds-push ;
+ [
+ ^^tagged>integer
+ tag-mask get bitnot ^^load-integer ^^and
+ 0 int-rep f ^^load-memory-imm
+ hashcode-shift ^^shr-imm
+ ] unary-op ;
M: ##fill-vector insn-available? rep>> %fill-vector-reps member? ;
M: ##gather-vector-2 insn-available? rep>> %gather-vector-2-reps member? ;
M: ##gather-vector-4 insn-available? rep>> %gather-vector-4-reps member? ;
-M: ##alien-vector insn-available? rep>> %alien-vector-reps member? ;
+M: ##store-memory-imm insn-available? rep>> %alien-vector-reps member? ;
M: ##shuffle-vector insn-available? rep>> %shuffle-vector-reps member? ;
M: ##shuffle-vector-imm insn-available? rep>> %shuffle-vector-imm-reps member? ;
M: ##merge-vector-head insn-available? rep>> %merge-vector-reps member? ;
unit-test
! vneg
-[ { ##load-constant ##sub-vector } ]
+[ { ##load-reference ##sub-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vneg ] test-emit ]
unit-test
[ addsub-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
-[ { ##load-constant ##xor-vector ##add-vector } ]
+[ { ##load-reference ##xor-vector ##add-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
-[ { ##load-constant ##xor-vector ##sub-vector ##add-vector } ]
+[ { ##load-reference ##xor-vector ##sub-vector ##add-vector } ]
[ simple-ops-cpu int-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
[ abs-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
-[ { ##load-constant ##andn-vector } ]
+[ { ##load-reference ##andn-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
M: shuffle-cpu %shuffle-vector-reps signed-reps ;
! vshuffle-elements
-[ { ##load-constant ##shuffle-vector } ]
+[ { ##load-reference ##shuffle-vector } ]
[ shuffle-cpu { 0 1 2 3 } int-4-rep [ emit-simd-vshuffle-elements ] test-emit-literal ]
unit-test
[ minmax-cpu int-4-rep [ emit-simd-v<= ] test-emit ]
unit-test
-[ { ##load-constant ##xor-vector ##xor-vector ##compare-vector } ]
+[ { ##load-reference ##xor-vector ##xor-vector ##compare-vector } ]
[ compare-cpu uint-4-rep [ emit-simd-v<= ] test-emit ]
unit-test
: ^load-neg-zero-vector ( rep -- dst )
{
- { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
- { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
+ { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-literal ] }
+ { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-literal ] }
} case ;
: ^load-add-sub-vector ( rep -- dst )
signed-rep {
- { float-4-rep [ float-array{ -0.0 0.0 -0.0 0.0 } underlying>> ^^load-constant ] }
- { double-2-rep [ double-array{ -0.0 0.0 } underlying>> ^^load-constant ] }
- { char-16-rep [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
- { short-8-rep [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
- { int-4-rep [ int-array{ -1 0 -1 0 } underlying>> ^^load-constant ] }
- { longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-constant ] }
+ { float-4-rep [ float-array{ -0.0 0.0 -0.0 0.0 } underlying>> ^^load-literal ] }
+ { double-2-rep [ double-array{ -0.0 0.0 } underlying>> ^^load-literal ] }
+ { char-16-rep [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-literal ] }
+ { short-8-rep [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-literal ] }
+ { int-4-rep [ int-array{ -1 0 -1 0 } underlying>> ^^load-literal ] }
+ { longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-literal ] }
} case ;
: ^load-half-vector ( rep -- dst )
{
- { float-4-rep [ float-array{ 0.5 0.5 0.5 0.5 } underlying>> ^^load-constant ] }
- { double-2-rep [ double-array{ 0.5 0.5 } underlying>> ^^load-constant ] }
+ { float-4-rep [ float-array{ 0.5 0.5 0.5 0.5 } underlying>> ^^load-literal ] }
+ { double-2-rep [ double-array{ 0.5 0.5 } underlying>> ^^load-literal ] }
} case ;
: >variable-shuffle ( shuffle rep -- shuffle' )
'[ _ n*v _ v+ ] map concat ;
: ^load-immediate-shuffle ( shuffle rep -- dst )
- >variable-shuffle ^^load-constant ;
+ >variable-shuffle ^^load-literal ;
:: ^blend-vector ( mask true false rep -- dst )
true mask rep ^^and-vector
[ ^(compare-vector) ]
[ ^minmax-compare-vector ]
{ unsigned-int-vector-rep [| src1 src2 rep cc |
- rep sign-bit-mask ^^load-constant :> sign-bits
+ rep sign-bit-mask ^^load-literal :> sign-bits
src1 sign-bits rep ^^xor-vector
src2 sign-bits rep ^^xor-vector
rep signed-rep cc ^(compare-vector)
: emit-alien-vector ( node -- )
dup [
'[
- ds-drop prepare-alien-getter
- _ ^^alien-vector ds-push
+ ds-drop prepare-load-memory
+ _ f ^^load-memory-imm ds-push
]
- [ inline-alien-getter? ] inline-alien
+ [ inline-load-memory? ] inline-accessor
] with { [ %alien-vector-reps member? ] } if-literals-match ;
: emit-set-alien-vector ( node -- )
dup [
'[
- ds-drop prepare-alien-setter ds-pop
- _ ##set-alien-vector
+ ds-drop prepare-store-memory
+ _ f ##store-memory-imm
]
- [ byte-array inline-alien-setter? ]
- inline-alien
+ [ byte-array inline-store-memory? ]
+ inline-accessor
] with { [ %alien-vector-reps member? ] } if-literals-match ;
: enable-simd ( -- )
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences math
classes.algebra classes.builtin locals combinators
-cpu.architecture compiler.tree.propagation.info
-compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
+combinators.short-circuit cpu.architecture
+compiler.tree.propagation.info compiler.cfg.stacks
+compiler.cfg.hats compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots
: value-tag ( info -- n ) class>> class-tag ;
-: ^^tag-offset>slot ( slot tag -- vreg' )
- [ ^^offset>slot ] dip ^^sub-imm ;
+: slot-indexing ( slot tag -- slot scale tag )
+ complex-addressing?
+ [ [ cell log2 ] dip ] [ [ ^^offset>slot ] dip ^^sub-imm 0 0 ] if ;
: (emit-slot) ( infos -- dst )
[ 2inputs ] [ first value-tag ] bi*
- ^^tag-offset>slot ^^slot ;
+ slot-indexing ^^slot ;
: (emit-slot-imm) ( infos -- dst )
ds-drop
: immediate-slot-offset? ( value-info -- ? )
literal>> {
- { [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
- [ drop f ]
- } cond ;
+ [ fixnum? ]
+ [ cell * immediate-arithmetic? ]
+ } 1&& ;
: emit-slot ( node -- )
dup node-input-infos
:: (emit-set-slot) ( infos -- )
3inputs :> ( src obj slot )
- slot infos second value-tag ^^tag-offset>slot :> slot
+ infos second value-tag :> tag
- src obj slot ##set-slot
+ slot tag slot-indexing :> ( slot scale tag )
+ src obj slot scale tag ##set-slot
infos emit-write-barrier?
- [ obj slot next-vreg next-vreg ##write-barrier ] when ;
+ [ obj slot scale tag next-vreg next-vreg ##write-barrier ] when ;
:: (emit-set-slot-imm) ( infos -- )
ds-drop
src obj slot tag ##set-slot-imm
infos emit-write-barrier?
- [ obj slot tag slot-offset next-vreg next-vreg ##write-barrier-imm ] when ;
+ [ obj slot tag next-vreg next-vreg ##write-barrier-imm ] when ;
: emit-set-slot ( node -- )
dup node-input-infos
dup third immediate-slot-offset?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ drop emit-primitive ] if ;
-
-: emit-string-nth ( -- )
- 2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
-
-: emit-set-string-nth-fast ( -- )
- 3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
- swap next-vreg ##set-string-nth-fast ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel compiler.constants compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.stacks cpu.architecture ;
+IN: compiler.cfg.intrinsics.strings
+
+: (string-nth) ( n string -- base offset rep c-type )
+ ^^tagged>integer swap ^^add string-offset int-rep uchar ; inline
+
+: emit-string-nth-fast ( -- )
+ 2inputs (string-nth) ^^load-memory-imm ds-push ;
+
+: emit-set-string-nth-fast ( -- )
+ 3inputs (string-nth) ##store-memory-imm ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs heaps kernel namespaces sequences fry math
math.order combinators arrays sorting compiler.utilities locals
IN: compiler.cfg.linear-scan.allocation
: active-positions ( new assoc -- )
- [ vreg>> active-intervals-for ] dip
+ [ active-intervals-for ] dip
'[ [ 0 ] dip reg>> _ add-use-position ] each ;
: inactive-positions ( new assoc -- )
- [ [ vreg>> inactive-intervals-for ] keep ] dip
+ [ [ inactive-intervals-for ] keep ] dip
'[
[ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi
_ add-use-position
! If the live interval has a usage at 'n', don't spill it,
! since this means its being defined by the sync point
! instruction. Output t if this is the case.
- 2dup [ uses>> ] dip swap member? [ 2drop t ] [ spill f ] if ;
+ 2dup [ uses>> ] dip '[ n>> _ = ] any?
+ [ 2drop t ] [ spill f ] if ;
: handle-sync-point ( n -- )
[ active-intervals get values ] dip
: smallest-heap ( heap1 heap2 -- heap )
! If heap1 and heap2 have the same key, favors heap1.
- [ [ heap-peek nip ] bi@ <= ] most ;
+ {
+ { [ dup heap-empty? ] [ drop ] }
+ { [ over heap-empty? ] [ nip ] }
+ [ [ [ heap-peek nip ] bi@ <= ] most ]
+ } cond ;
: (allocate-registers) ( -- )
- {
- { [ unhandled-intervals get heap-empty? ] [ unhandled-sync-points get ] }
- { [ unhandled-sync-points get heap-empty? ] [ unhandled-intervals get ] }
- ! If a live interval begins at the same location as a sync point,
- ! process the sync point before the live interval. This ensures that the
- ! return value of C function calls doesn't get spilled and reloaded
- ! unnecessarily.
- [ unhandled-sync-points get unhandled-intervals get smallest-heap ]
- } cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
+ ! If a live interval begins at the same location as a sync point,
+ ! process the sync point before the live interval. This ensures that the
+ ! return value of C function calls doesn't get spilled and reloaded
+ ! unnecessarily.
+ unhandled-sync-points get unhandled-intervals get smallest-heap
+ dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
: finish-allocation ( -- )
active-intervals inactive-intervals
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting namespaces linked-assocs
] [ drop ] if ;
: trim-before-ranges ( live-interval -- )
- [ ranges>> ] [ uses>> last 1 + ] bi
+ [ ranges>> ] [ last-use n>> 1 + ] bi
[ '[ from>> _ <= ] filter! drop ]
[ swap last (>>to) ]
2bi ;
: trim-after-ranges ( live-interval -- )
- [ ranges>> ] [ uses>> first ] bi
+ [ ranges>> ] [ first-use n>> ] bi
[ '[ to>> _ >= ] filter! drop ]
[ swap first (>>from) ]
2bi ;
: assign-spill ( live-interval -- )
- dup vreg>> vreg-spill-slot >>spill-to drop ;
+ dup [ vreg>> ] [ last-use rep>> ] bi
+ assign-spill-slot >>spill-to drop ;
: spill-before ( before -- before/f )
! If the interval does not have any usages before the spill location,
] if ;
: assign-reload ( live-interval -- )
- dup vreg>> vreg-spill-slot >>reload-from drop ;
+ dup [ vreg>> ] [ first-use rep>> ] bi
+ assign-spill-slot >>reload-from drop ;
: spill-after ( after -- after/f )
! If the interval has no more usages after the spill location,
split-interval [ spill-before ] [ spill-after ] bi* ;
: find-use-position ( live-interval new -- n )
- [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
+ [ uses>> ] [ start>> '[ n>> _ >= ] ] bi* find nip
+ [ n>> ] [ 1/0. ] if* ;
: find-use-positions ( live-intervals new assoc -- )
'[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
: active-positions ( new assoc -- )
- [ [ vreg>> active-intervals-for ] keep ] dip
+ [ [ active-intervals-for ] keep ] dip
find-use-positions ;
: inactive-positions ( new assoc -- )
[
- [ vreg>> inactive-intervals-for ] keep
+ [ inactive-intervals-for ] keep
[ '[ _ intervals-intersect? ] filter ] keep
] dip
find-use-positions ;
>alist alist-max ;
: spill-new? ( new pair -- ? )
- [ uses>> first ] [ second ] bi* > ;
+ [ first-use n>> ] [ second ] bi* > ;
: spill-new ( new pair -- )
drop spill-after add-unhandled ;
! If there is an active interval using 'reg' (there should be at
! most one) are split and spilled and removed from the inactive
! set.
- new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
+ new active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
'[ _ remove-nth! drop new start>> spill ] [ 2drop ] if ;
:: spill-intersecting-inactive ( new reg -- )
! Any inactive intervals using 'reg' are split and spilled
! and removed from the inactive set.
- new vreg>> inactive-intervals-for [
+ new inactive-intervals-for [
dup reg>> reg = [
dup new intervals-intersect? [
new start>> spill f
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting namespaces
] bi ;
: split-uses ( uses n -- before after )
- '[ _ <= ] partition ;
+ '[ n>> _ <= ] partition ;
ERROR: splitting-too-early ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators cpu.architecture fry heaps
-kernel math math.order namespaces sequences vectors
+USING: arrays accessors assocs combinators cpu.architecture fry
+heaps kernel math math.order namespaces sequences vectors
linked-assocs compiler.cfg compiler.cfg.registers
-compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ;
+compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
! Start index of current live interval. We ensure that all
! Vector of active live intervals
SYMBOL: active-intervals
-: active-intervals-for ( vreg -- seq )
- rep-of reg-class-of active-intervals get at ;
+: active-intervals-for ( live-interval -- seq )
+ reg-class>> active-intervals get at ;
: add-active ( live-interval -- )
- dup vreg>> active-intervals-for push ;
+ dup active-intervals-for push ;
: delete-active ( live-interval -- )
- dup vreg>> active-intervals-for remove-eq! drop ;
+ dup active-intervals-for remove-eq! drop ;
: assign-free-register ( new registers -- )
pop >>reg add-active ;
! Vector of inactive live intervals
SYMBOL: inactive-intervals
-: inactive-intervals-for ( vreg -- seq )
- rep-of reg-class-of inactive-intervals get at ;
+: inactive-intervals-for ( live-interval -- seq )
+ reg-class>> inactive-intervals get at ;
: add-inactive ( live-interval -- )
- dup vreg>> inactive-intervals-for push ;
+ dup inactive-intervals-for push ;
: delete-inactive ( live-interval -- )
- dup vreg>> inactive-intervals-for remove-eq! drop ;
+ dup inactive-intervals-for remove-eq! drop ;
! Vector of handled live intervals
SYMBOL: handled-intervals
: check-activate ( live-interval -- )
check-allocation? get [
- dup [ reg>> ] [ vreg>> active-intervals-for [ reg>> ] map ] bi member?
+ dup [ reg>> ] [ active-intervals-for [ reg>> ] map ] bi member?
[ register-already-used ] [ drop ] if
] [ drop ] if ;
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
-: next-spill-slot ( rep -- n )
- rep-size cfg get
+: next-spill-slot ( size -- n )
+ cfg get
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
<spill-slot> ;
! Mapping from vregs to spill slots
SYMBOL: spill-slots
-: vreg-spill-slot ( vreg -- spill-slot )
- spill-slots get [ rep-of next-spill-slot ] cache ;
+: assign-spill-slot ( coalesced-vreg rep -- spill-slot )
+ rep-size spill-slots get [ nip next-spill-slot ] 2cache ;
+
+: lookup-spill-slot ( coalesced-vreg rep -- spill-slot )
+ rep-size 2array spill-slots get ?at [ ] [ bad-vreg ] if ;
: init-allocator ( registers -- )
registers set
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )
- vreg>> rep-of reg-class-of registers get at
+ reg-class>> registers get at
[ 1/0. ] H{ } <linked-assoc> map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets locals arrays
+fry make combinators combinators.short-circuit sets locals arrays
cpu.architecture layouts
compiler.cfg
compiler.cfg.def-use
compiler.cfg.liveness
+compiler.cfg.liveness.ssa
compiler.cfg.registers
compiler.cfg.instructions
+compiler.cfg.linearization
+compiler.cfg.ssa.destruction
compiler.cfg.renaming.functor
-compiler.cfg.linearization.order
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
: remove-pending ( live-interval -- )
vreg>> pending-interval-assoc get delete-at ;
-ERROR: bad-vreg vreg ;
-
-: (vreg>reg) ( vreg pending -- reg )
+:: vreg>reg ( vreg -- reg )
! If a live vreg is not in the pending set, then it must
! have been spilled.
- ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ;
-
-: vreg>reg ( vreg -- reg )
- pending-interval-assoc get (vreg>reg) ;
+ vreg leader :> leader
+ leader pending-interval-assoc get at* [
+ drop leader vreg rep-of lookup-spill-slot
+ ] unless ;
: vregs>regs ( vregs -- assoc )
- dup assoc-empty? [
- pending-interval-assoc get
- '[ _ (vreg>reg) ] assoc-map
- ] unless ;
+ [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
: init-unhandled ( live-intervals -- )
[ add-unhandled ] each ;
+! Liveness info is used by resolve pass
+
! Mapping from basic blocks to values which are live at the start
-SYMBOL: register-live-ins
+! on all incoming CFG edges
+SYMBOL: machine-live-ins
+
+: machine-live-in ( bb -- assoc )
+ machine-live-ins get at ;
+
+: compute-live-in ( bb -- )
+ [ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
+
+! Mapping from basic blocks to predecessors to values which are
+! live on a particular incoming edge
+SYMBOL: machine-edge-live-ins
+
+: machine-edge-live-in ( predecessor bb -- assoc )
+ machine-edge-live-ins get at at ;
+
+: compute-edge-live-in ( bb -- )
+ [ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
+ machine-edge-live-ins get set-at ;
! Mapping from basic blocks to values which are live at the end
-SYMBOL: register-live-outs
+SYMBOL: machine-live-outs
+
+: machine-live-out ( bb -- assoc )
+ machine-live-outs get at ;
+
+: compute-live-out ( bb -- )
+ [ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
: init-assignment ( live-intervals -- )
<min-heap> pending-interval-heap set
H{ } clone pending-interval-assoc set
<min-heap> unhandled-intervals set
- H{ } clone register-live-ins set
- H{ } clone register-live-outs set
+ H{ } clone machine-live-ins set
+ H{ } clone machine-edge-live-ins set
+ H{ } clone machine-live-outs set
init-unhandled ;
: insert-spill ( live-interval -- )
- [ reg>> ] [ vreg>> rep-of ] [ spill-to>> ] tri _spill ;
+ [ reg>> ] [ last-use rep>> ] [ spill-to>> ] tri ##spill ;
: handle-spill ( live-interval -- )
dup spill-to>> [ insert-spill ] [ drop ] if ;
pending-interval-heap get (expire-old-intervals) ;
: insert-reload ( live-interval -- )
- [ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ;
+ [ reg>> ] [ first-use rep>> ] [ reload-from>> ] tri ##reload ;
+
+: insert-reload? ( live-interval -- ? )
+ ! Don't insert a reload if the register will be written to
+ ! before being read again.
+ {
+ [ reload-from>> ]
+ [ first-use type>> +use+ eq? ]
+ } 1&& ;
: handle-reload ( live-interval -- )
- dup reload-from>> [ insert-reload ] [ drop ] if ;
+ dup insert-reload? [ insert-reload ] [ drop ] if ;
: activate-interval ( live-interval -- )
[ add-pending ] [ handle-reload ] bi ;
M: vreg-insn assign-registers-in-insn
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
-: trace-on-gc ( assoc -- assoc' )
- ! When a GC occurs, virtual registers which contain tagged data
- ! are traced by the GC. Outputs a sequence physical registers.
- [ drop rep-of int-rep eq? ] { } assoc-filter-as values ;
-
-: spill-on-gc? ( vreg reg -- ? )
- [ rep-of int-rep? not ] [ spill-slot? not ] bi* and ;
-
-: spill-on-gc ( assoc -- assoc' )
- ! When a GC occurs, virtual registers which contain untagged data,
- ! and are stored in physical registers, are saved to their spill
- ! slots. Outputs sequence of triples:
- ! - physical register
- ! - spill slot
- ! - representation
- [
- [
- 2dup spill-on-gc?
- [ swap [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if
- ] assoc-each
- ] { } make ;
-
-: gc-root-offsets ( registers -- alist )
- ! Outputs a sequence of { offset register/spill-slot } pairs
- [ length iota [ cell * ] map ] keep zip ;
-
-M: ##gc assign-registers-in-insn
- ! Since ##gc is always the first instruction in a block, the set of
- ! values live at the ##gc is just live-in.
+M: ##call-gc assign-registers-in-insn
dup call-next-method
- basic-block get register-live-ins get at
- [ trace-on-gc gc-root-offsets >>tagged-values ] [ spill-on-gc >>data-values ] bi
- drop ;
+ [ [ vreg>reg ] map ] change-gc-roots drop ;
M: insn assign-registers-in-insn drop ;
: begin-block ( bb -- )
- dup basic-block set
- dup block-from activate-new-intervals
- [ live-in vregs>regs ] keep register-live-ins get set-at ;
-
-: end-block ( bb -- )
- [ live-out vregs>regs ] keep register-live-outs get set-at ;
-
-: vreg-at-start ( vreg bb -- state )
- register-live-ins get at ?at [ bad-vreg ] unless ;
-
-: vreg-at-end ( vreg bb -- state )
- register-live-outs get at ?at [ bad-vreg ] unless ;
+ {
+ [ basic-block set ]
+ [ block-from activate-new-intervals ]
+ [ compute-edge-live-in ]
+ [ compute-live-in ]
+ } cleave ;
:: assign-registers-in-block ( bb -- )
bb [
[ , ]
} cleave
] each
- bb end-block
+ bb compute-live-out
] V{ } make
] change-instructions drop ;
compiler.cfg.registers
compiler.cfg.predecessors
compiler.cfg.rpo
-compiler.cfg.linearization
compiler.cfg.debugger
compiler.cfg.def-use
compiler.cfg.comparisons
[
T{ live-interval
{ vreg 1 }
+ { reg-class float-regs }
{ start 0 }
{ end 2 }
- { uses V{ 0 1 } }
+ { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } } }
{ ranges V{ T{ live-range f 0 2 } } }
{ spill-to T{ spill-slot f 0 } }
}
T{ live-interval
{ vreg 1 }
+ { reg-class float-regs }
{ start 5 }
{ end 5 }
- { uses V{ 5 } }
+ { uses V{ T{ vreg-use f float-rep 5 } } }
{ ranges V{ T{ live-range f 5 5 } } }
{ reload-from T{ spill-slot f 0 } }
}
] [
T{ live-interval
{ vreg 1 }
+ { reg-class float-regs }
{ start 0 }
{ end 5 }
- { uses V{ 0 1 5 } }
+ { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
{ ranges V{ T{ live-range f 0 5 } } }
} 2 split-for-spill
] unit-test
[
T{ live-interval
{ vreg 2 }
+ { reg-class float-regs }
{ start 0 }
{ end 1 }
- { uses V{ 0 } }
+ { uses V{ T{ vreg-use f float-rep 0 } } }
{ ranges V{ T{ live-range f 0 1 } } }
{ spill-to T{ spill-slot f 4 } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class float-regs }
{ start 1 }
{ end 5 }
- { uses V{ 1 5 } }
+ { uses V{ T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
{ ranges V{ T{ live-range f 1 5 } } }
{ reload-from T{ spill-slot f 4 } }
}
] [
T{ live-interval
{ vreg 2 }
+ { reg-class float-regs }
{ start 0 }
{ end 5 }
- { uses V{ 0 1 5 } }
+ { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
{ ranges V{ T{ live-range f 0 5 } } }
} 0 split-for-spill
] unit-test
[
T{ live-interval
{ vreg 3 }
+ { reg-class float-regs }
{ start 0 }
{ end 1 }
- { uses V{ 0 } }
+ { uses V{ T{ vreg-use f float-rep 0 } } }
{ ranges V{ T{ live-range f 0 1 } } }
{ spill-to T{ spill-slot f 8 } }
}
T{ live-interval
{ vreg 3 }
+ { reg-class float-regs }
{ start 20 }
{ end 30 }
- { uses V{ 20 30 } }
+ { uses V{ T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } }
{ ranges V{ T{ live-range f 20 30 } } }
{ reload-from T{ spill-slot f 8 } }
}
] [
T{ live-interval
{ vreg 3 }
+ { reg-class float-regs }
{ start 0 }
{ end 30 }
- { uses V{ 0 20 30 } }
+ { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } }
{ ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
} 10 split-for-spill
] unit-test
V{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ reg 1 }
{ start 1 }
{ end 15 }
- { uses V{ 1 3 7 10 15 } }
+ { uses V{ T{ vreg-use f int-rep 1 } T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 7 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 15 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ reg 2 }
{ start 3 }
{ end 8 }
- { uses V{ 3 4 8 } }
+ { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 4 } T{ vreg-use f int-rep 8 } } }
}
T{ live-interval
{ vreg 3 }
+ { reg-class int-regs }
{ reg 3 }
{ start 3 }
{ end 10 }
- { uses V{ 3 10 } }
+ { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 10 } } }
}
}
}
H{ } inactive-intervals set
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 5 }
{ end 5 }
- { uses V{ 5 } }
+ { uses V{ T{ vreg-use f int-rep 5 } } }
}
spill-status
] unit-test
V{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ reg 1 }
{ start 1 }
{ end 15 }
- { uses V{ 1 } }
+ { uses V{ T{ vreg-use f int-rep 1 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ reg 2 }
{ start 3 }
{ end 8 }
- { uses V{ 3 8 } }
+ { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 8 } } }
}
}
}
H{ } inactive-intervals set
T{ live-interval
{ vreg 3 }
+ { reg-class int-regs }
{ start 5 }
{ end 5 }
- { uses V{ 5 } }
+ { uses V{ T{ vreg-use f int-rep 5 } } }
}
spill-status
] unit-test
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ 0 100 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 10 }
- { uses V{ 0 10 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 11 }
{ end 20 }
- { uses V{ 11 20 } }
+ { uses V{ T{ vreg-use f int-rep 11 } T{ vreg-use f int-rep 20 } } }
{ ranges V{ T{ live-range f 11 20 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ 0 100 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 30 }
{ end 60 }
- { uses V{ 30 60 } }
+ { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 60 } } }
{ ranges V{ T{ live-range f 30 60 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ 0 100 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 30 }
{ end 200 }
- { uses V{ 30 200 } }
+ { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 200 } } }
{ ranges V{ T{ live-range f 30 200 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ 0 100 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 30 }
{ end 100 }
- { uses V{ 30 100 } }
+ { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 100 } } }
{ ranges V{ T{ live-range f 30 100 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 20 }
- { uses V{ 0 10 20 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 0 }
{ end 20 }
- { uses V{ 0 10 20 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
{ vreg 3 }
+ { reg-class int-regs }
{ start 4 }
{ end 8 }
- { uses V{ 6 } }
+ { uses V{ T{ vreg-use f int-rep 6 } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
T{ live-interval
{ vreg 4 }
+ { reg-class int-regs }
{ start 4 }
{ end 8 }
- { uses V{ 8 } }
+ { uses V{ T{ vreg-use f int-rep 8 } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
! This guy will invoke the 'spill partially available' code path
T{ live-interval
{ vreg 5 }
+ { reg-class int-regs }
{ start 4 }
{ end 8 }
- { uses V{ 8 } }
+ { uses V{ T{ vreg-use f int-rep 8 } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 10 }
- { uses V{ 0 6 10 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 6 } T{ vreg-use f int-rep 10 } } }
{ ranges V{ T{ live-range f 0 10 } } }
}
! This guy will invoke the 'spill new' code path
T{ live-interval
{ vreg 5 }
+ { reg-class int-regs }
{ start 2 }
{ end 8 }
- { uses V{ 8 } }
+ { uses V{ T{ vreg-use f int-rep 8 } } }
{ ranges V{ T{ live-range f 2 8 } } }
}
}
[ 5 ] [
T{ live-interval
{ start 0 }
+ { reg-class int-regs }
{ end 10 }
{ uses { 0 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
{ start 5 }
+ { reg-class int-regs }
{ end 10 }
{ uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 20 }
{ reg 0 }
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 4 }
{ end 40 }
{ reg 0 }
{
T{ live-interval
{ vreg 3 }
+ { reg-class int-regs }
{ start 0 }
{ end 40 }
{ reg 1 }
} active-intervals set
T{ live-interval
- { vreg 4 }
+ { vreg 4 }
+ { reg-class int-regs }
{ start 8 }
{ end 10 }
{ ranges V{ T{ live-range f 8 10 } } }
- { uses V{ 8 10 } }
+ { uses V{ T{ vreg-use f int-rep 8 } T{ vreg-use f int-rep 10 } } }
}
register-status
] unit-test
-
-:: test-linear-scan-on-cfg ( regs -- )
- [
- cfg new 0 get >>entry
- dup cfg set
- dup fake-representations
- dup { { int-regs regs } } (linear-scan)
- flatten-cfg 1array mr.
- ] with-scope ;
-
-! Bug in live spill slots calculation
-
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek
- { dst 703128 }
- { loc D 1 }
- }
- T{ ##peek
- { dst 703129 }
- { loc D 0 }
- }
- T{ ##copy
- { dst 703134 }
- { src 703128 }
- }
- T{ ##copy
- { dst 703135 }
- { src 703129 }
- }
- T{ ##compare-imm-branch
- { src1 703128 }
- { src2 5 }
- { cc cc/= }
- }
-} 1 test-bb
-
-V{
- T{ ##copy
- { dst 703134 }
- { src 703129 }
- }
- T{ ##copy
- { dst 703135 }
- { src 703128 }
- }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##replace
- { src 703134 }
- { loc D 0 }
- }
- T{ ##replace
- { src 703135 }
- { loc D 1 }
- }
- T{ ##epilogue }
- T{ ##return }
-} 3 test-bb
-
-0 1 edge
-1 { 2 3 } edges
-2 3 edge
-
-! Bug in inactive interval handling
-! [ rot dup [ -rot ] when ]
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek
- { dst 689473 }
- { loc D 2 }
- }
- T{ ##peek
- { dst 689474 }
- { loc D 1 }
- }
- T{ ##peek
- { dst 689475 }
- { loc D 0 }
- }
- T{ ##compare-imm-branch
- { src1 689473 }
- { src2 5 }
- { cc cc/= }
- }
-} 1 test-bb
-
-V{
- T{ ##copy
- { dst 689481 }
- { src 689475 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689482 }
- { src 689474 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689483 }
- { src 689473 }
- { rep int-rep }
- }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##copy
- { dst 689481 }
- { src 689473 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689482 }
- { src 689475 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689483 }
- { src 689474 }
- { rep int-rep }
- }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##replace
- { src 689481 }
- { loc D 0 }
- }
- T{ ##replace
- { src 689482 }
- { loc D 1 }
- }
- T{ ##replace
- { src 689483 }
- { loc D 2 }
- }
- T{ ##epilogue }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-! Similar to the above
-! [ swap dup [ rot ] when ]
-
-T{ basic-block
- { id 201537 }
- { number 0 }
- { instructions V{ T{ ##prologue } T{ ##branch } } }
-} 0 set
-
-V{
- T{ ##peek
- { dst 689600 }
- { loc D 1 }
- }
- T{ ##peek
- { dst 689601 }
- { loc D 0 }
- }
- T{ ##compare-imm-branch
- { src1 689600 }
- { src2 5 }
- { cc cc/= }
- }
-} 1 test-bb
-
-V{
- T{ ##peek
- { dst 689604 }
- { loc D 2 }
- }
- T{ ##copy
- { dst 689607 }
- { src 689604 }
- }
- T{ ##copy
- { dst 689608 }
- { src 689600 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689610 }
- { src 689601 }
- { rep int-rep }
- }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##peek
- { dst 689609 }
- { loc D 2 }
- }
- T{ ##copy
- { dst 689607 }
- { src 689600 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689608 }
- { src 689601 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689610 }
- { src 689609 }
- { rep int-rep }
- }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##replace
- { src 689607 }
- { loc D 0 }
- }
- T{ ##replace
- { src 689608 }
- { loc D 1 }
- }
- T{ ##replace
- { src 689610 }
- { loc D 2 }
- }
- T{ ##epilogue }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-! compute-live-registers was inaccurate since it didn't take
-! lifetime holes into account
-
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek
- { dst 0 }
- { loc D 0 }
- }
- T{ ##compare-imm-branch
- { src1 0 }
- { src2 5 }
- { cc cc/= }
- }
-} 1 test-bb
-
-V{
- T{ ##peek
- { dst 1 }
- { loc D 1 }
- }
- T{ ##copy
- { dst 2 }
- { src 1 }
- { rep int-rep }
- }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##peek
- { dst 3 }
- { loc D 2 }
- }
- T{ ##copy
- { dst 2 }
- { src 3 }
- { rep int-rep }
- }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##replace
- { src 2 }
- { loc D 0 }
- }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-! Inactive interval handling: splitting active interval
-! if it fits in lifetime hole only partially
-
-V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek f 2 R 0 }
- T{ ##compare-imm-branch f 2 5 cc= }
-} 1 test-bb
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##branch }
-} 2 test-bb
-
-
-V{
- T{ ##peek f 1 D 1 }
- T{ ##peek f 0 D 0 }
- T{ ##replace f 1 D 2 }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##replace f 3 R 2 }
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-! Not until splitting is finished
-! [ _copy ] [ 3 get instructions>> second class ] unit-test
-
-! Resolve pass; make sure the spilling is done correctly
-V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek f 2 R 0 }
- T{ ##compare-imm-branch f 2 5 cc= }
-} 1 test-bb
-
-V{
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##replace f 3 R 1 }
- T{ ##peek f 1 D 1 }
- T{ ##peek f 0 D 0 }
- T{ ##replace f 1 D 2 }
- T{ ##replace f 0 D 2 }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##replace f 3 R 2 }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test
-
-[ _spill ] [ 3 get instructions>> second class ] unit-test
-
-[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test
-
-[ _reload ] [ 4 get instructions>> first class ] unit-test
-
-! Resolve pass
-V{
- T{ ##branch }
-} 0 test-bb
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##compare-imm-branch f 0 5 cc= }
-} 1 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##peek f 1 D 0 }
- T{ ##peek f 2 D 0 }
- T{ ##replace f 1 D 0 }
- T{ ##replace f 2 D 0 }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##peek f 1 D 0 }
- T{ ##compare-imm-branch f 1 5 cc= }
-} 4 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 5 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 6 test-bb
-
-0 1 edge
-1 { 2 3 } edges
-2 4 edge
-3 4 edge
-4 { 5 6 } edges
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
-
-[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test
-
-[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
-
-! A more complicated failure case with resolve that came up after the above
-! got fixed
-V{ T{ ##branch } } 0 test-bb
-V{
- T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##peek f 2 D 2 }
- T{ ##peek f 3 D 3 }
- T{ ##peek f 4 D 0 }
- T{ ##branch }
-} 1 test-bb
-V{ T{ ##branch } } 2 test-bb
-V{ T{ ##branch } } 3 test-bb
-V{
-
- T{ ##replace f 1 D 1 }
- T{ ##replace f 2 D 2 }
- T{ ##replace f 3 D 3 }
- T{ ##replace f 4 D 4 }
- T{ ##replace f 0 D 0 }
- T{ ##branch }
-} 4 test-bb
-V{ T{ ##replace f 0 D 0 } T{ ##branch } } 5 test-bb
-V{ T{ ##return } } 6 test-bb
-V{ T{ ##branch } } 7 test-bb
-V{
- T{ ##replace f 1 D 1 }
- T{ ##replace f 2 D 2 }
- T{ ##replace f 3 D 3 }
- T{ ##peek f 5 D 1 }
- T{ ##peek f 6 D 2 }
- T{ ##peek f 7 D 3 }
- T{ ##peek f 8 D 4 }
- T{ ##replace f 5 D 1 }
- T{ ##replace f 6 D 2 }
- T{ ##replace f 7 D 3 }
- T{ ##replace f 8 D 4 }
- T{ ##branch }
-} 8 test-bb
-V{
- T{ ##replace f 1 D 1 }
- T{ ##replace f 2 D 2 }
- T{ ##replace f 3 D 3 }
- T{ ##return }
-} 9 test-bb
-
-0 1 edge
-1 { 2 7 } edges
-7 8 edge
-8 9 edge
-2 { 3 5 } edges
-3 4 edge
-4 9 edge
-5 6 edge
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-[ _spill ] [ 1 get instructions>> second class ] unit-test
-[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
-[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ dst>> n>> cell / ] map ] unit-test
-[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ src>> n>> cell / ] map ] unit-test
-
-! Resolve pass should insert this
-[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
-
-! Some random bug
-V{
- T{ ##peek f 1 D 1 }
- T{ ##peek f 2 D 2 }
- T{ ##replace f 1 D 1 }
- T{ ##replace f 2 D 2 }
- T{ ##peek f 3 D 0 }
- T{ ##peek f 0 D 0 }
- T{ ##branch }
-} 0 test-bb
-
-V{ T{ ##branch } } 1 test-bb
-
-V{
- T{ ##peek f 1 D 1 }
- T{ ##peek f 2 D 2 }
- T{ ##replace f 3 D 3 }
- T{ ##replace f 1 D 1 }
- T{ ##replace f 2 D 2 }
- T{ ##replace f 0 D 3 }
- T{ ##branch }
-} 2 test-bb
-
-V{ T{ ##branch } } 3 test-bb
-
-V{
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-! Spilling an interval immediately after its activated;
-! and the interval does not have a use at the activation point
-V{
- T{ ##peek f 1 D 1 }
- T{ ##peek f 2 D 2 }
- T{ ##replace f 1 D 1 }
- T{ ##replace f 2 D 2 }
- T{ ##peek f 0 D 0 }
- T{ ##branch }
-} 0 test-bb
-
-V{ T{ ##branch } } 1 test-bb
-
-V{
- T{ ##peek f 1 D 1 }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##replace f 1 D 1 }
- T{ ##peek f 2 D 2 }
- T{ ##replace f 2 D 2 }
- T{ ##branch }
-} 3 test-bb
-
-V{ T{ ##branch } } 4 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 5 test-bb
-
-0 1 edge
-1 { 2 4 } edges
-4 5 edge
-2 3 edge
-3 5 edge
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-! Reduction of push-all regression, x86-32
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##load-immediate { dst 61 } }
- T{ ##peek { dst 62 } { loc D 0 } }
- T{ ##peek { dst 64 } { loc D 1 } }
- T{ ##slot-imm
- { dst 69 }
- { obj 64 }
- { slot 1 }
- { tag 2 }
- }
- T{ ##copy { dst 79 } { src 69 } { rep int-rep } }
- T{ ##slot-imm
- { dst 85 }
- { obj 62 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##compare-branch
- { src1 69 }
- { src2 85 }
- { cc cc> }
- }
-} 1 test-bb
-
-V{
- T{ ##slot-imm
- { dst 97 }
- { obj 62 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##replace { src 79 } { loc D 3 } }
- T{ ##replace { src 62 } { loc D 4 } }
- T{ ##replace { src 79 } { loc D 1 } }
- T{ ##replace { src 62 } { loc D 2 } }
- T{ ##replace { src 61 } { loc D 5 } }
- T{ ##replace { src 62 } { loc R 0 } }
- T{ ##replace { src 69 } { loc R 1 } }
- T{ ##replace { src 97 } { loc D 0 } }
- T{ ##call { word resize-array } }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##peek { dst 98 } { loc R 0 } }
- T{ ##peek { dst 100 } { loc D 0 } }
- T{ ##set-slot-imm
- { src 100 }
- { obj 98 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##peek { dst 108 } { loc D 2 } }
- T{ ##peek { dst 110 } { loc D 3 } }
- T{ ##peek { dst 112 } { loc D 0 } }
- T{ ##peek { dst 114 } { loc D 1 } }
- T{ ##peek { dst 116 } { loc D 4 } }
- T{ ##peek { dst 119 } { loc R 0 } }
- T{ ##copy { dst 109 } { src 108 } { rep int-rep } }
- T{ ##copy { dst 111 } { src 110 } { rep int-rep } }
- T{ ##copy { dst 113 } { src 112 } { rep int-rep } }
- T{ ##copy { dst 115 } { src 114 } { rep int-rep } }
- T{ ##copy { dst 117 } { src 116 } { rep int-rep } }
- T{ ##copy { dst 120 } { src 119 } { rep int-rep } }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##copy { dst 109 } { src 62 } { rep int-rep } }
- T{ ##copy { dst 111 } { src 61 } { rep int-rep } }
- T{ ##copy { dst 113 } { src 62 } { rep int-rep } }
- T{ ##copy { dst 115 } { src 79 } { rep int-rep } }
- T{ ##copy { dst 117 } { src 64 } { rep int-rep } }
- T{ ##copy { dst 120 } { src 69 } { rep int-rep } }
- T{ ##branch }
-} 4 test-bb
-
-V{
- T{ ##replace { src 120 } { loc D 0 } }
- T{ ##replace { src 109 } { loc D 3 } }
- T{ ##replace { src 111 } { loc D 4 } }
- T{ ##replace { src 113 } { loc D 1 } }
- T{ ##replace { src 115 } { loc D 2 } }
- T{ ##replace { src 117 } { loc D 5 } }
- T{ ##epilogue }
- T{ ##return }
-} 5 test-bb
-
-0 1 edge
-1 { 2 4 } edges
-2 3 edge
-3 5 edge
-4 5 edge
-
-[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
-
-! Another reduction of push-all
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek { dst 85 } { loc D 0 } }
- T{ ##slot-imm
- { dst 89 }
- { obj 85 }
- { slot 3 }
- { tag 7 }
- }
- T{ ##peek { dst 91 } { loc D 1 } }
- T{ ##slot-imm
- { dst 96 }
- { obj 91 }
- { slot 1 }
- { tag 2 }
- }
- T{ ##add
- { dst 109 }
- { src1 89 }
- { src2 96 }
- }
- T{ ##slot-imm
- { dst 115 }
- { obj 85 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##slot-imm
- { dst 118 }
- { obj 115 }
- { slot 1 }
- { tag 2 }
- }
- T{ ##compare-branch
- { src1 109 }
- { src2 118 }
- { cc cc> }
- }
-} 1 test-bb
-
-V{
- T{ ##add-imm
- { dst 128 }
- { src1 109 }
- { src2 8 }
- }
- T{ ##load-immediate { dst 129 } { val 24 } }
- T{ ##inc-d { n 4 } }
- T{ ##inc-r { n 1 } }
- T{ ##replace { src 109 } { loc D 2 } }
- T{ ##replace { src 85 } { loc D 3 } }
- T{ ##replace { src 128 } { loc D 0 } }
- T{ ##replace { src 85 } { loc D 1 } }
- T{ ##replace { src 89 } { loc D 4 } }
- T{ ##replace { src 96 } { loc R 0 } }
- T{ ##replace { src 129 } { loc R 0 } }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##peek { dst 134 } { loc D 1 } }
- T{ ##slot-imm
- { dst 140 }
- { obj 134 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##inc-d { n 1 } }
- T{ ##inc-r { n 1 } }
- T{ ##replace { src 140 } { loc D 0 } }
- T{ ##replace { src 134 } { loc R 0 } }
- T{ ##call { word resize-array } }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##peek { dst 141 } { loc R 0 } }
- T{ ##peek { dst 143 } { loc D 0 } }
- T{ ##set-slot-imm
- { src 143 }
- { obj 141 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##write-barrier-imm
- { src 141 }
- { slot 2 }
- { temp1 145 }
- { temp2 146 }
- }
- T{ ##inc-d { n -1 } }
- T{ ##inc-r { n -1 } }
- T{ ##peek { dst 156 } { loc D 2 } }
- T{ ##peek { dst 158 } { loc D 3 } }
- T{ ##peek { dst 160 } { loc D 0 } }
- T{ ##peek { dst 162 } { loc D 1 } }
- T{ ##peek { dst 164 } { loc D 4 } }
- T{ ##peek { dst 167 } { loc R 0 } }
- T{ ##copy { dst 157 } { src 156 } { rep int-rep } }
- T{ ##copy { dst 159 } { src 158 } { rep int-rep } }
- T{ ##copy { dst 161 } { src 160 } { rep int-rep } }
- T{ ##copy { dst 163 } { src 162 } { rep int-rep } }
- T{ ##copy { dst 165 } { src 164 } { rep int-rep } }
- T{ ##copy { dst 168 } { src 167 } { rep int-rep } }
- T{ ##branch }
-} 4 test-bb
-
-V{
- T{ ##inc-d { n 3 } }
- T{ ##inc-r { n 1 } }
- T{ ##copy { dst 157 } { src 85 } }
- T{ ##copy { dst 159 } { src 89 } }
- T{ ##copy { dst 161 } { src 85 } }
- T{ ##copy { dst 163 } { src 109 } }
- T{ ##copy { dst 165 } { src 91 } }
- T{ ##copy { dst 168 } { src 96 } }
- T{ ##branch }
-} 5 test-bb
-
-V{
- T{ ##set-slot-imm
- { src 163 }
- { obj 161 }
- { slot 3 }
- { tag 7 }
- }
- T{ ##inc-d { n 1 } }
- T{ ##inc-r { n -1 } }
- T{ ##replace { src 168 } { loc D 0 } }
- T{ ##replace { src 157 } { loc D 3 } }
- T{ ##replace { src 159 } { loc D 4 } }
- T{ ##replace { src 161 } { loc D 1 } }
- T{ ##replace { src 163 } { loc D 2 } }
- T{ ##replace { src 165 } { loc D 5 } }
- T{ ##epilogue }
- T{ ##return }
-} 6 test-bb
-
-0 1 edge
-1 { 2 5 } edges
-2 3 edge
-3 4 edge
-4 6 edge
-5 6 edge
-
-[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
-
-! Fencepost error in assignment pass
-V{ T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##compare-imm-branch f 0 5 cc= }
-} 1 test-bb
-
-V{ T{ ##branch } } 2 test-bb
-
-V{
- T{ ##peek f 1 D 0 }
- T{ ##peek f 2 D 0 }
- T{ ##replace f 1 D 0 }
- T{ ##replace f 2 D 0 }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
-
-[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
-
-[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test
-
-[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
-
-! Another test case for fencepost error in assignment pass
-V{ T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##compare-imm-branch f 0 5 cc= }
-} 1 test-bb
-
-V{
- T{ ##peek f 1 D 0 }
- T{ ##peek f 2 D 0 }
- T{ ##replace f 1 D 0 }
- T{ ##replace f 2 D 0 }
- T{ ##replace f 0 D 0 }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
-
-[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
-
-[ 1 ] [ 2 get instructions>> [ _reload? ] count ] unit-test
-
-[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
-
-[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##replace f 1 D 1 }
- T{ ##branch }
-} 0 test-bb
-
-V{
- T{ ##gc f 2 3 }
- T{ ##branch }
-} 1 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 2 test-bb
-
-0 1 edge
-1 2 edge
-
-[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-
-[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##compare-imm-branch f 1 5 cc= }
-} 0 test-bb
-
-V{
- T{ ##gc f 2 3 }
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 1 test-bb
-
-V{
- T{ ##return }
-} 2 test-bb
-
-0 { 1 2 } edges
-
-[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-
-[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make locals
cpu.architecture
compiler.cfg
compiler.cfg.rpo
-compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
+! SSA liveness must have been computed already
+
:: (linear-scan) ( cfg machine-registers -- )
- cfg compute-live-sets
cfg number-instructions
cfg compute-live-intervals machine-registers allocate-registers
cfg assign-registers
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs accessors sequences math math.order fry
-combinators binary-search compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.linearization.order
-compiler.cfg ;
+USING: namespaces kernel assocs accessors locals sequences math
+math.order fry combinators binary-search
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.def-use
+compiler.cfg.liveness
+compiler.cfg.linearization
+compiler.cfg.ssa.destruction
+compiler.cfg
+cpu.architecture ;
IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-range from to ;
C: <live-range> live-range
+SYMBOLS: +def+ +use+ +memory+ ;
+
+TUPLE: vreg-use rep n type ;
+
+C: <vreg-use> vreg-use
+
TUPLE: live-interval
vreg
reg spill-to reload-from
-start end ranges uses ;
+start end ranges uses
+reg-class ;
+
+: first-use ( live-interval -- use ) uses>> first ; inline
+
+: last-use ( live-interval -- use ) uses>> last ; inline
GENERIC: covers? ( insn# obj -- ? )
[ drop ] [ [ from>> <=> ] with search nip ] 2bi
covers?
] if ;
-
+
: add-new-range ( from to live-interval -- )
[ <live-range> ] dip ranges>> push ;
2dup extend-range?
[ extend-range ] [ add-new-range ] if ;
-GENERIC: operands-in-registers? ( insn -- ? )
-
-M: vreg-insn operands-in-registers? drop t ;
-
-M: partial-sync-insn operands-in-registers? drop f ;
-
-: add-def ( insn live-interval -- )
- [ insn#>> ] [ uses>> ] bi* push ;
-
-: add-use ( insn live-interval -- )
- ! Every use is a potential def, no SSA here baby!
- over operands-in-registers? [ add-def ] [ 2drop ] if ;
+:: add-use ( rep n type live-interval -- )
+ type +memory+ eq? [
+ rep n type <vreg-use>
+ live-interval uses>> push
+ ] unless ;
-: <live-interval> ( vreg -- live-interval )
+: <live-interval> ( vreg reg-class -- live-interval )
\ live-interval new
V{ } clone >>uses
V{ } clone >>ranges
+ swap >>reg-class
swap >>vreg ;
: block-from ( bb -- n ) instructions>> first insn#>> 1 - ;
: block-to ( bb -- n ) instructions>> last insn#>> ;
-M: live-interval hashcode*
- nip [ start>> ] [ end>> 1000 * ] bi + ;
+SYMBOLS: from to ;
! Mapping from vreg to live-interval
SYMBOL: live-intervals
: live-interval ( vreg -- live-interval )
- live-intervals get [ <live-interval> ] cache ;
+ leader live-intervals get
+ [ dup rep-of reg-class-of <live-interval> ] cache ;
GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* drop ;
-: handle-output ( insn vreg -- )
- live-interval
- [ [ insn#>> ] dip shorten-range ] [ add-def ] 2bi ;
+:: record-def ( vreg n type -- )
+ vreg rep-of :> rep
+ vreg live-interval :> live-interval
-: handle-input ( insn vreg -- )
- live-interval
- [ [ [ basic-block get block-from ] dip insn#>> ] dip add-range ] [ add-use ] 2bi ;
+ n live-interval shorten-range
+ rep n type live-interval add-use ;
-: handle-temp ( insn vreg -- )
- live-interval
- [ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ;
+:: record-use ( vreg n type -- )
+ vreg rep-of :> rep
+ vreg live-interval :> live-interval
-M: vreg-insn compute-live-intervals*
- [ dup defs-vreg [ handle-output ] with when* ]
- [ dup uses-vregs [ handle-input ] with each ]
- [ dup temp-vregs [ handle-temp ] with each ]
- tri ;
+ from get n live-interval add-range
+ rep n type live-interval add-use ;
+
+:: record-temp ( vreg n -- )
+ vreg rep-of :> rep
+ vreg live-interval :> live-interval
+
+ n n live-interval add-range
+ rep n +def+ live-interval add-use ;
+
+M:: vreg-insn compute-live-intervals* ( insn -- )
+ insn insn#>> :> n
+
+ insn defs-vreg [ n +def+ record-def ] when*
+ insn uses-vregs [ n +use+ record-use ] each
+ insn temp-vregs [ n record-temp ] each ;
+
+M:: clobber-insn compute-live-intervals* ( insn -- )
+ insn insn#>> :> n
+
+ insn defs-vreg [ n +use+ record-def ] when*
+ insn uses-vregs [ n +memory+ record-use ] each
+ insn temp-vregs [ n record-temp ] each ;
: handle-live-out ( bb -- )
- [ block-from ] [ block-to ] [ live-out keys ] tri
- [ live-interval add-range ] with with each ;
+ live-out dup assoc-empty? [ drop ] [
+ [ from get to get ] dip keys
+ [ live-interval add-range ] with with each
+ ] if ;
! A location where all registers have to be spilled
TUPLE: sync-point n ;
GENERIC: compute-sync-points* ( insn -- )
-M: partial-sync-insn compute-sync-points*
+M: clobber-insn compute-sync-points*
insn#>> <sync-point> sync-points get push ;
M: insn compute-sync-points* drop ;
: compute-live-intervals-step ( bb -- )
- [ basic-block set ]
- [ handle-live-out ]
- [
- instructions>> <reversed> [
- [ compute-live-intervals* ]
- [ compute-sync-points* ]
- bi
- ] each
- ] tri ;
+ {
+ [ block-from from set ]
+ [ block-to to set ]
+ [ handle-live-out ]
+ [
+ instructions>> <reversed> [
+ [ compute-live-intervals* ]
+ [ compute-sync-points* ]
+ bi
+ ] each
+ ]
+ } cleave ;
: init-live-intervals ( -- )
H{ } clone live-intervals set
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math sequences grouping namespaces
-compiler.cfg.linearization.order ;
+compiler.cfg.linearization ;
IN: compiler.cfg.linear-scan.numbering
ERROR: already-numbered insn ;
[
{
- { { T{ spill-slot f 0 } int-rep } { 1 int-rep } }
+ {
+ T{ location f T{ spill-slot f 0 } int-rep int-regs }
+ T{ location f 1 int-rep int-regs }
+ }
}
] [
[
[
{
- T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
+ T{ ##reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
}
] [
[
- { T{ spill-slot f 0 } int-rep } { 1 int-rep } >insn
+ T{ location f T{ spill-slot f 0 } int-rep int-regs }
+ T{ location f 1 int-rep int-regs }
+ >insn
] { } make
] unit-test
[
{
- T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
+ T{ ##spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
}
] [
[
- { 1 int-rep } { T{ spill-slot f 0 } int-rep } >insn
+ T{ location f 1 int-rep int-regs }
+ T{ location f T{ spill-slot f 0 } int-rep int-regs }
+ >insn
] { } make
] unit-test
}
] [
[
- { 1 int-rep } { 2 int-rep } >insn
+ T{ location f 1 int-rep int-regs }
+ T{ location f 2 int-rep int-regs }
+ >insn
] { } make
] unit-test
-cfg new 8 >>spill-area-size cfg set
-H{ } clone spill-temps set
+[
+ {
+ T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
+ T{ ##branch }
+ }
+] [
+ { { T{ location f 1 int-rep int-regs } T{ location f 2 int-rep int-regs } } }
+ mapping-instructions
+] unit-test
[
- t
+ {
+ T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 0 } } }
+ T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 1 } } }
+ T{ ##branch }
+ }
] [
- { { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
+ {
+ { T{ location f T{ spill-slot f 1 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+ { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 0 } int-rep int-regs } }
+ }
+ mapping-instructions
+] unit-test
+
+[
+ {
+ T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
+ T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+ T{ ##branch }
+ }
+] [
+ {
+ { T{ location f T{ spill-slot f 0 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+ { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 1 } int-rep int-regs } }
+ }
+ mapping-instructions
+] unit-test
+
+[
+ {
+ T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
+ T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+ T{ ##branch }
+ }
+] [
+ {
+ { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 1 } int-rep int-regs } }
+ { T{ location f T{ spill-slot f 0 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+ }
+ mapping-instructions
+] unit-test
+
+cfg new 8 >>spill-area-size cfg set
+H{ } clone spill-temps set
+
+[ t ] [
+ {
+ { T{ location f 0 int-rep int-regs } T{ location f 1 int-rep int-regs } }
+ { T{ location f 1 int-rep int-regs } T{ location f 0 int-rep int-regs } }
+ }
mapping-instructions {
{
- T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
+ T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
- T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
+ T{ ##reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
+ T{ ##branch }
}
{
- T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
+ T{ ##spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
- T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
+ T{ ##reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
+ T{ ##branch }
}
} member?
] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit fry kernel locals namespaces
make math sequences hashtables
+cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.instructions
compiler.cfg.predecessors
compiler.cfg.parallel-copy
+compiler.cfg.ssa.destruction
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.resolve
+TUPLE: location
+{ reg read-only }
+{ rep read-only }
+{ reg-class read-only } ;
+
+: <location> ( reg rep -- location )
+ dup reg-class-of location boa ;
+
+M: location equal?
+ over location? [
+ { [ [ reg>> ] bi@ = ] [ [ reg-class>> ] bi@ = ] } 2&&
+ ] [ 2drop f ] if ;
+
+M: location hashcode*
+ reg>> hashcode* ;
+
SYMBOL: spill-temps
: spill-temp ( rep -- n )
- spill-temps get [ next-spill-slot ] cache ;
+ rep-size spill-temps get [ next-spill-slot ] cache ;
: add-mapping ( from to rep -- )
- '[ _ 2array ] bi@ 2array , ;
+ '[ _ <location> ] bi@ 2array , ;
-:: resolve-value-data-flow ( bb to vreg -- )
- vreg bb vreg-at-end
- vreg to vreg-at-start
+:: resolve-value-data-flow ( vreg live-out live-in edge-live-in -- )
+ vreg live-out ?at [ bad-vreg ] unless
+ vreg live-in ?at [ edge-live-in ?at [ bad-vreg ] unless ] unless
2dup = [ 2drop ] [ vreg rep-of add-mapping ] if ;
-: compute-mappings ( bb to -- mappings )
- dup live-in dup assoc-empty? [ 3drop f ] [
- [ keys [ resolve-value-data-flow ] with with each ] { } make
+:: compute-mappings ( bb to -- mappings )
+ bb machine-live-out :> live-out
+ to machine-live-in :> live-in
+ bb to machine-edge-live-in :> edge-live-in
+ live-out assoc-empty? [ f ] [
+ [
+ live-in keys edge-live-in keys append [
+ live-out live-in edge-live-in
+ resolve-value-data-flow
+ ] each
+ ] { } make
] if ;
: memory->register ( from to -- )
- swap [ first2 ] [ first ] bi* _reload ;
+ swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* ##reload ;
: register->memory ( from to -- )
- [ first2 ] [ first ] bi* _spill ;
+ [ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* ##spill ;
: temp->register ( from to -- )
- nip [ first ] [ second ] [ second spill-temp ] tri _reload ;
+ nip [ reg>> ] [ rep>> ] [ rep>> spill-temp ] tri ##reload ;
: register->temp ( from to -- )
- drop [ first2 ] [ second spill-temp ] bi _spill ;
+ drop [ [ reg>> ] [ rep>> ] bi ] [ rep>> spill-temp ] bi ##spill ;
: register->register ( from to -- )
- swap [ first ] [ first2 ] bi* ##copy ;
+ swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy ;
SYMBOL: temp
{
{ [ over temp eq? ] [ temp->register ] }
{ [ dup temp eq? ] [ register->temp ] }
- { [ over first spill-slot? ] [ memory->register ] }
- { [ dup first spill-slot? ] [ register->memory ] }
+ { [ over reg>> spill-slot? ] [ memory->register ] }
+ { [ dup reg>> spill-slot? ] [ register->memory ] }
[ register->register ]
} cond ;
: mapping-instructions ( alist -- insns )
[ swap ] H{ } assoc-map-as
- [ temp [ swap >insn ] parallel-mapping ] { } make ;
+ [ temp [ swap >insn ] parallel-mapping ##branch ] { } make ;
: perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [
- mapping-instructions insert-simple-basic-block
+ mapping-instructions insert-basic-block
cfg get cfg-changed drop
] if ;
--- /dev/null
+USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
+kernel accessors sequences sets tools.test namespaces ;
+IN: compiler.cfg.linearization.tests
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+0 { 1 1 } edges
+1 2 edge
+
+[ t ] [ cfg new 0 get >>entry linearization-order [ id>> ] map all-unique? ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces make
-combinators assocs arrays locals layouts hashtables
-cpu.architecture generalizations
-compiler.cfg
-compiler.cfg.comparisons
-compiler.cfg.stack-frame
-compiler.cfg.instructions
-compiler.cfg.utilities
-compiler.cfg.linearization.order ;
+USING: accessors arrays assocs deques dlists hashtables kernel
+make sorting namespaces sequences combinators
+combinators.short-circuit fry math compiler.cfg.rpo
+compiler.cfg.utilities compiler.cfg.loop-detection
+compiler.cfg.predecessors sets hash-sets ;
+FROM: namespaces => set ;
IN: compiler.cfg.linearization
-<PRIVATE
-
-SYMBOL: numbers
-
-: block-number ( bb -- n ) numbers get at ;
-
-: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
-
-! Convert CFG IR to machine IR.
-GENERIC: linearize-insn ( basic-block insn -- )
-
-: linearize-basic-block ( bb -- )
- [ block-number _label ]
- [ dup instructions>> [ linearize-insn ] with each ]
- bi ;
-
-M: insn linearize-insn , drop ;
-
-: useless-branch? ( basic-block successor -- ? )
- ! If our successor immediately follows us in linearization
- ! order then we don't need to branch.
- [ block-number ] bi@ 1 - = ; inline
-
-: emit-branch ( bb successor -- )
- 2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
-
-M: ##branch linearize-insn
- drop dup successors>> first emit-branch ;
-
-: successors ( bb -- first second ) successors>> first2 ; inline
-
-:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label etc... )
- bb insn
- conditional-quot
- [ drop dup successors>> second useless-branch? ] 2bi
- [ [ swap block-number ] n ndip ]
- [ [ block-number ] n ndip negate-cc-quot call ] if ; inline
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
-: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
- [ dup successors ]
- [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
-
-: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
- 3 [ (binary-conditional) ] [ negate-cc ] conditional ;
-
-: (test-vector-conditional) ( bb insn -- bb successor1 successor2 src1 temp rep vcc )
- [ dup successors ]
- [ { [ src1>> ] [ temp>> ] [ rep>> ] [ vcc>> ] } cleave ] bi* ; inline
-
-: test-vector-conditional ( bb insn -- bb successor label src1 temp rep vcc )
- 4 [ (test-vector-conditional) ] [ negate-vcc ] conditional ;
-
-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-ordered-branch linearize-insn
- binary-conditional _compare-float-ordered-branch emit-branch ;
-
-M: ##compare-float-unordered-branch linearize-insn
- binary-conditional _compare-float-unordered-branch emit-branch ;
-
-M: ##test-vector-branch linearize-insn
- test-vector-conditional _test-vector-branch emit-branch ;
+<PRIVATE
-: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
- [ dup successors block-number ]
- [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
+SYMBOLS: work-list loop-heads visited ;
+
+: visited? ( bb -- ? ) visited get in? ;
+
+: add-to-work-list ( bb -- )
+ dup visited? [ drop ] [
+ work-list get push-back
+ ] if ;
+
+: init-linearization-order ( cfg -- )
+ <dlist> work-list set
+ HS{ } clone visited set
+ entry>> add-to-work-list ;
+
+: (find-alternate-loop-head) ( bb -- bb' )
+ dup {
+ [ predecessor visited? not ]
+ [ predecessors>> length 1 = ]
+ [ predecessor successors>> length 1 = ]
+ [ [ number>> ] [ predecessor number>> ] bi > ]
+ } 1&& [ predecessor (find-alternate-loop-head) ] when ;
+
+: find-back-edge ( bb -- pred )
+ [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
+
+: find-alternate-loop-head ( bb -- bb' )
+ dup find-back-edge dup visited? [ drop ] [
+ nip (find-alternate-loop-head)
+ ] if ;
+
+: predecessors-ready? ( bb -- ? )
+ [ predecessors>> ] keep '[
+ _ 2dup back-edge?
+ [ 2drop t ] [ drop visited? ] if
+ ] all? ;
+
+: process-successor ( bb -- )
+ dup predecessors-ready? [
+ dup loop-entry? [ find-alternate-loop-head ] when
+ add-to-work-list
+ ] [ drop ] if ;
+
+: sorted-successors ( bb -- seq )
+ successors>> <reversed> [ loop-nesting-at ] sort-with ;
+
+: process-block ( bb -- )
+ dup visited? [ drop ] [
+ [ , ]
+ [ visited get adjoin ]
+ [ sorted-successors [ process-successor ] each ]
+ tri
+ ] if ;
+
+: (linearization-order) ( cfg -- bbs )
+ init-linearization-order
+
+ [ work-list get [ process-block ] slurp-deque ] { } make
+ ! [ unlikely?>> not ] partition append
+ ;
-M: ##fixnum-add linearize-insn
- overflow-conditional _fixnum-add emit-branch ;
+PRIVATE>
-M: ##fixnum-sub linearize-insn
- overflow-conditional _fixnum-sub emit-branch ;
+: linearization-order ( cfg -- bbs )
+ needs-post-order needs-loops needs-predecessors
-M: ##fixnum-mul linearize-insn
- overflow-conditional _fixnum-mul emit-branch ;
+ dup linear-order>> [ ] [
+ dup (linearization-order)
+ >>linear-order linear-order>>
+ ] ?if ;
-M: ##dispatch linearize-insn
- swap
- [ [ src>> ] [ temp>> ] bi _dispatch ]
- [ successors>> [ block-number _dispatch-label ] each ]
- bi* ;
+SYMBOL: numbers
-: linearize-basic-blocks ( cfg -- insns )
- [
- [
- linearization-order
- [ number-blocks ]
- [ [ linearize-basic-block ] each ] bi
- ] [ spill-area-size>> _spill-area-size ] bi
- ] { } make ;
+: block-number ( bb -- n ) numbers get at ;
-PRIVATE>
-
-: flatten-cfg ( cfg -- mr )
- [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
- <mr> ;
+: number-blocks ( bbs -- )
+ [ 2array ] map-index >hashtable numbers set ;
+++ /dev/null
-USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization.order
-kernel accessors sequences sets tools.test namespaces ;
-IN: compiler.cfg.linearization.order.tests
-
-V{ } 0 test-bb
-
-V{ } 1 test-bb
-
-V{ } 2 test-bb
-
-0 { 1 1 } edges
-1 2 edge
-
-[ t ] [ cfg new 0 get >>entry linearization-order [ id>> ] map all-unique? ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel make sorting
-namespaces sequences combinators combinators.short-circuit
-fry math compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg.loop-detection compiler.cfg.predecessors
-sets hash-sets ;
-FROM: namespaces => set ;
-IN: compiler.cfg.linearization.order
-
-! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
-
-<PRIVATE
-
-SYMBOLS: work-list loop-heads visited ;
-
-: visited? ( bb -- ? ) visited get in? ;
-
-: add-to-work-list ( bb -- )
- dup visited? [ drop ] [
- work-list get push-back
- ] if ;
-
-: init-linearization-order ( cfg -- )
- <dlist> work-list set
- HS{ } clone visited set
- entry>> add-to-work-list ;
-
-: (find-alternate-loop-head) ( bb -- bb' )
- dup {
- [ predecessor visited? not ]
- [ predecessors>> length 1 = ]
- [ predecessor successors>> length 1 = ]
- [ [ number>> ] [ predecessor number>> ] bi > ]
- } 1&& [ predecessor (find-alternate-loop-head) ] when ;
-
-: find-back-edge ( bb -- pred )
- [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
-
-: find-alternate-loop-head ( bb -- bb' )
- dup find-back-edge dup visited? [ drop ] [
- nip (find-alternate-loop-head)
- ] if ;
-
-: predecessors-ready? ( bb -- ? )
- [ predecessors>> ] keep '[
- _ 2dup back-edge?
- [ 2drop t ] [ drop visited? ] if
- ] all? ;
-
-: process-successor ( bb -- )
- dup predecessors-ready? [
- dup loop-entry? [ find-alternate-loop-head ] when
- add-to-work-list
- ] [ drop ] if ;
-
-: sorted-successors ( bb -- seq )
- successors>> <reversed> [ loop-nesting-at ] sort-with ;
-
-: process-block ( bb -- )
- dup visited? [ drop ] [
- [ , ]
- [ visited get adjoin ]
- [ sorted-successors [ process-successor ] each ]
- tri
- ] if ;
-
-: (linearization-order) ( cfg -- bbs )
- init-linearization-order
-
- [ work-list get [ process-block ] slurp-deque ] { } make ;
-
-PRIVATE>
-
-: linearization-order ( cfg -- bbs )
- needs-post-order needs-loops needs-predecessors
-
- dup linear-order>> [ ] [
- dup (linearization-order)
- >>linear-order linear-order>>
- ] ?if ;
+++ /dev/null
-Flattening CFG into MR (machine representation)
--- /dev/null
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.liveness.ssa
+compiler.cfg.liveness arrays sequences assocs
+compiler.cfg.registers kernel namespaces tools.test ;
+IN: compiler.cfg.liveness.ssa.tests
+
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##load-integer f 0 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##load-integer f 1 1 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##branch }
+} 5 test-bb
+
+V{
+ T{ ##replace f 2 D 0 }
+ T{ ##branch }
+} 6 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 7 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 { 5 6 } edges
+5 6 edge
+6 7 edge
+
+[ ] [ cfg new 0 get >>entry dup cfg set compute-ssa-live-sets ] unit-test
+
+[ t ] [ 0 get live-in assoc-empty? ] unit-test
+
+[ H{ { 2 2 } } ] [ 4 get live-out ] unit-test
+
+[ H{ { 0 0 } } ] [ 2 get 4 get edge-live-in ] unit-test
+
+[ H{ { 1 1 } } ] [ 3 get 4 get edge-live-in ] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces deques accessors sets sequences assocs fry
hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
! is in correspondence with a predecessor
-SYMBOL: phi-live-ins
+SYMBOL: edge-live-ins
-: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
+: edge-live-in ( predecessor basic-block -- set ) edge-live-ins get at at ;
SYMBOL: work-list
: compute-live-in ( basic-block -- live-in )
[ live-out ] keep instructions>> transfer-liveness ;
-: compute-phi-live-in ( basic-block -- phi-live-in )
+: compute-edge-live-in ( basic-block -- edge-live-in )
H{ } clone [
'[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi
] keep ;
: update-live-in ( basic-block -- changed? )
[ [ compute-live-in ] keep live-ins get maybe-set-at ]
- [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
+ [ [ compute-edge-live-in ] keep edge-live-ins get maybe-set-at ]
bi or ;
: compute-live-out ( basic-block -- live-out )
[ successors>> [ live-in ] map ]
- [ dup successors>> [ phi-live-in ] with map ] bi
+ [ dup successors>> [ edge-live-in ] with map ] bi
append assoc-combine ;
: update-live-out ( basic-block -- changed? )
[ predecessors>> add-to-work-list ] [ drop ] if
] [ drop ] if ;
-: compute-ssa-live-sets ( cfg -- cfg' )
+: compute-ssa-live-sets ( cfg -- )
needs-predecessors
<hashed-dlist> work-list set
H{ } clone live-ins set
- H{ } clone phi-live-ins set
+ H{ } clone edge-live-ins set
H{ } clone live-outs set
- dup post-order add-to-work-list
+ post-order add-to-work-list
work-list get [ liveness-step ] slurp-deque ;
: live-in? ( vreg bb -- ? ) live-in key? ;
: loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ;
+: current-loop-nesting ( -- n ) basic-block get loop-nesting-at ;
+
: needs-loops ( cfg -- cfg' )
needs-predecessors
dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces accessors compiler.cfg
-compiler.cfg.linearization compiler.cfg.gc-checks
-compiler.cfg.save-contexts compiler.cfg.linear-scan
-compiler.cfg.build-stack-frame ;
-IN: compiler.cfg.mr
-
-: build-mr ( cfg -- mr )
- insert-gc-checks
- insert-save-contexts
- linear-scan
- flatten-cfg
- build-stack-frame ;
\ No newline at end of file
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors combinators namespaces
-compiler.cfg.tco
+USING: compiler.cfg.tco
compiler.cfg.useless-conditionals
compiler.cfg.branch-splitting
compiler.cfg.block-joining
compiler.cfg.copy-prop
compiler.cfg.dce
compiler.cfg.write-barrier
-compiler.cfg.scheduling
compiler.cfg.representations
+compiler.cfg.gc-checks
+compiler.cfg.save-contexts
compiler.cfg.ssa.destruction
compiler.cfg.empty-blocks
compiler.cfg.checker ;
IN: compiler.cfg.optimizer
-SYMBOL: check-optimizer?
-
-: ?check ( cfg -- cfg' )
- check-optimizer? get [
- dup check-cfg
- ] when ;
-
: optimize-cfg ( cfg -- cfg' )
optimize-tail-calls
delete-useless-conditionals
value-numbering
copy-propagation
eliminate-dead-code
- eliminate-write-barriers
- select-representations
- schedule-instructions
- destruct-ssa
- delete-empty-blocks
- ?check ;
+ eliminate-write-barriers ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: arrays sequences kernel namespaces accessors compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.debugger
+compiler.cfg.representations.coalescing
+tools.test ;
+IN: compiler.cfg.representations.coalescing.tests
+
+: test-scc ( -- )
+ cfg new 0 get >>entry compute-components ;
+
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 2 D 0 }
+ T{ ##load-integer f 0 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##load-integer f 1 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##phi f 3 H{ { 1 0 } { 2 1 } } }
+} 3 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+
+[ ] [ test-scc ] unit-test
+
+[ t ] [ 0 vreg>scc 1 vreg>scc = ] unit-test
+[ t ] [ 0 vreg>scc 3 vreg>scc = ] unit-test
+[ f ] [ 2 vreg>scc 3 vreg>scc = ] unit-test
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs compiler.cfg.def-use
+compiler.cfg.instructions compiler.cfg.rpo disjoint-sets fry
+kernel namespaces sequences ;
+IN: compiler.cfg.representations.coalescing
+
+! Find all strongly connected components in the graph where the
+! edges are ##phi or ##copy vreg uses
+SYMBOL: components
+
+: init-components ( cfg components -- )
+ '[
+ instructions>> [
+ defs-vreg [ _ add-atom ] when*
+ ] each
+ ] each-basic-block ;
+
+GENERIC# visit-insn 1 ( insn disjoint-set -- )
+
+M: ##copy visit-insn
+ [ [ dst>> ] [ src>> ] bi ] dip equate ;
+
+M: ##phi visit-insn
+ [ [ inputs>> values ] [ dst>> ] bi ] dip equate-all-with ;
+
+M: insn visit-insn 2drop ;
+
+: merge-components ( cfg components -- )
+ '[
+ instructions>> [
+ _ visit-insn
+ ] each
+ ] each-basic-block ;
+
+: compute-components ( cfg -- )
+ <disjoint-set>
+ [ init-components ]
+ [ merge-components ]
+ [ components set drop ] 2tri ;
+
+: vreg>scc ( vreg -- scc )
+ components get representative ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays combinators compiler.cfg.instructions
+compiler.cfg.registers compiler.constants cpu.architecture
+kernel layouts locals math namespaces ;
+IN: compiler.cfg.representations.conversion
+
+ERROR: bad-conversion dst src dst-rep src-rep ;
+
+GENERIC: rep>tagged ( dst src rep -- )
+GENERIC: tagged>rep ( dst src rep -- )
+
+M: int-rep rep>tagged ( dst src rep -- )
+ drop tag-bits get ##shl-imm ;
+
+M: int-rep tagged>rep ( dst src rep -- )
+ drop tag-bits get ##sar-imm ;
+
+M:: float-rep rep>tagged ( dst src rep -- )
+ double-rep next-vreg-rep :> temp
+ temp src ##single>double-float
+ dst temp double-rep rep>tagged ;
+
+M:: float-rep tagged>rep ( dst src rep -- )
+ double-rep next-vreg-rep :> temp
+ temp src double-rep tagged>rep
+ dst temp ##double>single-float ;
+
+M:: double-rep rep>tagged ( dst src rep -- )
+ dst 16 float int-rep next-vreg-rep ##allot
+ src dst float-offset double-rep f ##store-memory-imm ;
+
+M: double-rep tagged>rep
+ drop float-offset double-rep f ##load-memory-imm ;
+
+M:: vector-rep rep>tagged ( dst src rep -- )
+ tagged-rep next-vreg-rep :> temp
+ dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
+ temp 16 tag-fixnum ##load-tagged
+ temp dst 1 byte-array type-number ##set-slot-imm
+ src dst byte-array-offset rep f ##store-memory-imm ;
+
+M: vector-rep tagged>rep
+ [ byte-array-offset ] dip f ##load-memory-imm ;
+
+M:: scalar-rep rep>tagged ( dst src rep -- )
+ tagged-rep next-vreg-rep :> temp
+ temp src rep ##scalar>integer
+ dst temp int-rep rep>tagged ;
+
+M:: scalar-rep tagged>rep ( dst src rep -- )
+ tagged-rep next-vreg-rep :> temp
+ temp src int-rep tagged>rep
+ dst temp rep ##integer>scalar ;
+
+GENERIC: rep>int ( dst src rep -- )
+GENERIC: int>rep ( dst src rep -- )
+
+M: scalar-rep rep>int ( dst src rep -- )
+ ##scalar>integer ;
+
+M: scalar-rep int>rep ( dst src rep -- )
+ ##integer>scalar ;
+
+: emit-conversion ( dst src dst-rep src-rep -- )
+ {
+ { [ 2dup eq? ] [ drop ##copy ] }
+ { [ dup tagged-rep? ] [ drop tagged>rep ] }
+ { [ over tagged-rep? ] [ nip rep>tagged ] }
+ { [ dup int-rep? ] [ drop int>rep ] }
+ { [ over int-rep? ] [ nip rep>int ] }
+ [
+ 2dup 2array {
+ { { double-rep float-rep } [ 2drop ##single>double-float ] }
+ { { float-rep double-rep } [ 2drop ##double>single-float ] }
+ ! Punning SIMD vector types? Naughty naughty! But
+ ! it is allowed... otherwise bail out.
+ [
+ drop 2dup [ reg-class-of ] bi@ eq?
+ [ drop ##copy ] [ bad-conversion ] if
+ ]
+ } case
+ ]
+ } cond ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays combinators
+combinators.short-circuit kernel layouts locals make math
+namespaces sequences cpu.architecture compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.representations.rewrite
+compiler.cfg.representations.selection ;
+IN: compiler.cfg.representations.peephole
+
+! Representation selection performs some peephole optimizations
+! when inserting conversions to optimize for a few common cases
+
+GENERIC: optimize-insn ( insn -- )
+
+SYMBOL: insn-index
+
+: here ( -- )
+ building get length 1 - insn-index set ;
+
+: finish ( insn -- ) , here ;
+
+: unchanged ( insn -- )
+ [ no-use-conversion ] [ finish ] [ no-def-conversion ] tri ;
+
+: last-insn ( -- insn ) insn-index get building get nth ;
+
+M: vreg-insn conversions-for-insn
+ init-renaming-set
+ optimize-insn
+ last-insn perform-renaming ;
+
+M: vreg-insn optimize-insn
+ [ emit-use-conversion ] [ finish ] [ emit-def-conversion ] tri ;
+
+M: ##load-integer optimize-insn
+ {
+ {
+ [ dup dst>> rep-of tagged-rep? ]
+ [ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged here ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! When a float is unboxed, we replace the ##load-reference with a ##load-double
+! if the architecture supports it
+: convert-to-load-double? ( insn -- ? )
+ {
+ [ drop fused-unboxing? ]
+ [ dst>> rep-of double-rep? ]
+ [ obj>> float? ]
+ } 1&& ;
+
+: convert-to-load-vector? ( insn -- ? )
+ {
+ [ drop fused-unboxing? ]
+ [ dst>> rep-of vector-rep? ]
+ [ obj>> byte-array? ]
+ } 1&& ;
+
+! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
+! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
+: convert-to-zero-vector? ( insn -- ? )
+ {
+ [ dst>> rep-of vector-rep? ]
+ [ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ]
+ } 1&& ;
+
+: convert-to-fill-vector? ( insn -- ? )
+ {
+ [ dst>> rep-of vector-rep? ]
+ [ obj>> B{ 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 } = ]
+ } 1&& ;
+
+M: ##load-reference optimize-insn
+ {
+ {
+ [ dup convert-to-load-double? ]
+ [ [ dst>> ] [ obj>> ] bi ##load-double here ]
+ }
+ {
+ [ dup convert-to-zero-vector? ]
+ [ dst>> dup rep-of ##zero-vector here ]
+ }
+ {
+ [ dup convert-to-fill-vector? ]
+ [ dst>> dup rep-of ##fill-vector here ]
+ }
+ {
+ [ dup convert-to-load-vector? ]
+ [ [ dst>> ] [ obj>> ] [ dst>> rep-of ] tri ##load-vector here ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! Optimize this:
+! ##sar-imm temp src tag-bits
+! ##shl-imm dst temp X
+! Into either
+! ##shl-imm by X - tag-bits, or
+! ##sar-imm by tag-bits - X.
+: combine-shl-imm-input ( insn -- )
+ [ dst>> ] [ src1>> ] [ src2>> ] tri tag-bits get {
+ { [ 2dup < ] [ swap - ##sar-imm here ] }
+ { [ 2dup > ] [ - ##shl-imm here ] }
+ [ 2drop int-rep ##copy here ]
+ } cond ;
+
+: dst-tagged? ( insn -- ? ) dst>> rep-of tagged-rep? ;
+: src1-tagged? ( insn -- ? ) src1>> rep-of tagged-rep? ;
+: src2-tagged? ( insn -- ? ) src2>> rep-of tagged-rep? ;
+
+: src2-tagged-arithmetic? ( insn -- ? ) src2>> tag-fixnum immediate-arithmetic? ;
+: src2-tagged-bitwise? ( insn -- ? ) src2>> tag-fixnum immediate-bitwise? ;
+: src2-tagged-shift-count? ( insn -- ? ) src2>> tag-bits get + immediate-shift-count? ;
+
+: >tagged-shift ( insn -- ) [ tag-bits get + ] change-src2 finish ; inline
+
+M: ##shl-imm optimize-insn
+ {
+ {
+ [ dup { [ dst-tagged? ] [ src1-tagged? ] } 1&& ]
+ [ unchanged ]
+ }
+ {
+ [ dup { [ dst-tagged? ] [ src2-tagged-shift-count? ] } 1&& ]
+ [ [ emit-use-conversion ] [ >tagged-shift ] [ no-def-conversion ] tri ]
+ }
+ {
+ [ dup src1-tagged? ]
+ [ [ no-use-conversion ] [ combine-shl-imm-input ] [ emit-def-conversion ] tri ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! Optimize this:
+! ##sar-imm temp src tag-bits
+! ##sar-imm dst temp X
+! Into
+! ##sar-imm by X + tag-bits
+! assuming X + tag-bits is a valid shift count.
+M: ##sar-imm optimize-insn
+ {
+ {
+ [ dup { [ src1-tagged? ] [ src2-tagged-shift-count? ] } 1&& ]
+ [ [ no-use-conversion ] [ >tagged-shift ] [ emit-def-conversion ] tri ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! Peephole optimization: for X = add, sub, and, or, xor, min, max
+! we have
+! tag(untag(a) X untag(b)) = a X b
+!
+! so if all inputs and outputs of ##X or ##X-imm are tagged,
+! don't have to insert any conversions
+M: inert-tag-untag-insn optimize-insn
+ {
+ {
+ [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged? ] } 1&& ]
+ [ unchanged ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! -imm variant of above
+: >tagged-imm ( insn -- )
+ [ tag-fixnum ] change-src2 unchanged ; inline
+
+M: inert-arithmetic-tag-untag-insn optimize-insn
+ {
+ {
+ [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ]
+ [ >tagged-imm ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+M: inert-bitwise-tag-untag-insn optimize-insn
+ {
+ {
+ [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged-bitwise? ] } 1&& ]
+ [ >tagged-imm ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+M: ##mul-imm optimize-insn
+ {
+ { [ dup { [ dst-tagged? ] [ src1-tagged? ] } 1&& ] [ unchanged ] }
+ { [ dup { [ dst-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
+ [ call-next-method ]
+ } cond ;
+
+! Similar optimization for comparison operators
+M: ##compare-integer-imm optimize-insn
+ {
+ { [ dup { [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
+ [ call-next-method ]
+ } cond ;
+
+M: ##compare-integer-imm-branch optimize-insn
+ {
+ { [ dup { [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
+ [ call-next-method ]
+ } cond ;
+
+M: ##compare-integer optimize-insn
+ {
+ { [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
+ [ call-next-method ]
+ } cond ;
+
+M: ##compare-integer-branch optimize-insn
+ {
+ { [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
+ [ call-next-method ]
+ } cond ;
+
+! Identities:
+! tag(neg(untag(x))) = x
+! tag(neg(x)) = x * -2^tag-bits
+: inert-tag/untag-unary? ( insn -- ? )
+ [ dst>> ] [ src>> ] bi [ rep-of tagged-rep? ] both? ;
+
+: combine-neg-tag ( insn -- )
+ [ dst>> ] [ src>> ] bi tag-bits get 2^ neg ##mul-imm here ;
+
+M: ##neg optimize-insn
+ {
+ { [ dup inert-tag/untag-unary? ] [ unchanged ] }
+ {
+ [ dup dst>> rep-of tagged-rep? ]
+ [ [ emit-use-conversion ] [ combine-neg-tag ] [ no-def-conversion ] tri ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! Identity:
+! tag(not(untag(x))) = not(x) xor tag-mask
+:: emit-tagged-not ( insn -- )
+ tagged-rep next-vreg-rep :> temp
+ temp insn src>> ##not
+ insn dst>> temp tag-mask get ##xor-imm here ;
+
+M: ##not optimize-insn
+ {
+ {
+ [ dup inert-tag/untag-unary? ]
+ [ [ no-use-conversion ] [ emit-tagged-not ] [ no-def-conversion ] tri ]
+ }
+ [ call-next-method ]
+ } cond ;
tri
] with-compilation-unit
-: each-def-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
-: each-use-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
-: each-temp-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
-: with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
+: each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+ [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline
+
+: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
'[
[ basic-block set ] [
[
- _
- [ each-def-rep ]
- [ each-use-rep ]
- [ each-temp-rep ] 2tri
+ _ each-rep
] each-non-phi
] bi
] each-basic-block ; inline
-USING: tools.test cpu.architecture
-compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.representations.preferred ;
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.representations.preferred cpu.architecture kernel
+namespaces tools.test sequences arrays system literals layouts
+math compiler.constants compiler.cfg.representations.conversion
+compiler.cfg.representations.rewrite
+compiler.cfg.comparisons
+make ;
IN: compiler.cfg.representations
[ { double-rep double-rep } ] [
] unit-test
[ double-rep ] [
- T{ ##alien-double
+ T{ ##load-memory-imm
{ dst 5 }
- { src 3 }
+ { base 3 }
+ { offset 0 }
+ { rep double-rep }
} defs-vreg-rep
+] unit-test
+
+H{ } clone representations set
+
+3 \ vreg-counter set-global
+
+[
+ {
+ T{ ##allot f 2 16 float 4 }
+ T{ ##store-memory-imm f 1 2 $[ float-offset ] double-rep f }
+ }
+] [
+ [
+ 2 1 tagged-rep double-rep emit-conversion
+ ] { } make
+] unit-test
+
+[
+ {
+ T{ ##load-memory-imm f 2 1 $[ float-offset ] double-rep f }
+ }
+] [
+ [
+ 2 1 double-rep tagged-rep emit-conversion
+ ] { } make
+] unit-test
+
+: test-representations ( -- )
+ cfg new 0 get >>entry dup cfg set select-representations drop ;
+
+! Make sure cost calculation isn't completely wrong
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 1 }
+ T{ ##add-float f 3 1 2 }
+ T{ ##replace f 3 D 0 }
+ T{ ##replace f 3 D 1 }
+ T{ ##replace f 3 D 2 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+[ ] [ test-representations ] unit-test
+
+[ 1 ] [ 1 get instructions>> [ ##allot? ] count ] unit-test
+
+! Don't dereference the result of a peek
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 1 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##add-float f 2 1 1 }
+ T{ ##replace f 2 D 0 }
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+V{
+ T{ ##add-float f 3 1 1 }
+ T{ ##replace f 3 D 0 }
+ T{ ##epilogue }
+ T{ ##return }
+} 3 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+
+[ ] [ test-representations ] unit-test
+
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##branch }
+ }
+] [ 1 get instructions>> ] unit-test
+
+! We cannot untag-fixnum the result of a peek if there are usages
+! of it as a tagged-rep
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 1 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##replace f 1 R 0 }
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+V{
+ T{ ##mul f 2 1 1 }
+ T{ ##replace f 2 D 0 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+3 { 3 4 } edges
+2 4 edge
+
+[ ] [ test-representations ] unit-test
+
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##branch }
+ }
+] [ 1 get instructions>> ] unit-test
+
+! But its ok to untag-fixnum the result of a peek if all usages use
+! it as int-rep
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 1 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+V{
+ T{ ##add f 2 1 1 }
+ T{ ##mul f 3 1 1 }
+ T{ ##replace f 2 D 0 }
+ T{ ##replace f 3 D 1 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+3 { 3 4 } edges
+2 4 edge
+
+3 \ vreg-counter set-global
+
+[ ] [ test-representations ] unit-test
+
+[
+ V{
+ T{ ##peek f 4 D 0 }
+ T{ ##sar-imm f 1 4 $[ tag-bits get ] }
+ T{ ##branch }
+ }
+] [ 1 get instructions>> ] unit-test
+
+! scalar-rep => int-rep conversion
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
+ T{ ##vector>scalar f 3 2 int-4-rep }
+ T{ ##replace f 3 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+[ ] [ test-representations ] unit-test
+
+[ t ] [ 1 get instructions>> 4 swap nth ##scalar>integer? ] unit-test
+
+! Test phi node behavior
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##load-integer f 1 1 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##load-integer f 2 2 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
+ T{ ##replace f 3 D 0 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-representations ] unit-test
+
+[ T{ ##load-tagged f 1 $[ 1 tag-fixnum ] } ]
+[ 1 get instructions>> first ]
+unit-test
+
+[ T{ ##load-tagged f 2 $[ 2 tag-fixnum ] } ]
+[ 2 get instructions>> first ]
+unit-test
+
+! ##load-reference corner case
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add f 2 0 1 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##load-reference f 3 f }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##phi f 4 H{ { 1 2 } { 2 3 } } }
+ T{ ##replace f 4 D 0 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-representations ] unit-test
+
+! Don't untag the f!
+[ 2 ] [ 2 get instructions>> length ] unit-test
+
+cpu x86.32? [
+
+ ! Make sure load-constant is converted into load-double
+ V{
+ T{ ##prologue }
+ T{ ##branch }
+ } 0 test-bb
+
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##load-reference f 2 0.5 }
+ T{ ##add-float f 3 1 2 }
+ T{ ##replace f 3 D 0 }
+ T{ ##branch }
+ } 1 test-bb
+
+ V{
+ T{ ##epilogue }
+ T{ ##return }
+ } 2 test-bb
+
+ 0 1 edge
+ 1 2 edge
+
+ [ ] [ test-representations ] unit-test
+
+ [ t ] [ 1 get instructions>> second ##load-double? ] unit-test
+
+ ! Make sure phi nodes are handled in a sane way
+ V{
+ T{ ##prologue }
+ T{ ##branch }
+ } 0 test-bb
+
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##compare-imm-branch f 1 2 cc= }
+ } 1 test-bb
+
+ V{
+ T{ ##load-reference f 2 1.5 }
+ T{ ##branch }
+ } 2 test-bb
+
+ V{
+ T{ ##load-reference f 3 2.5 }
+ T{ ##branch }
+ } 3 test-bb
+
+ V{
+ T{ ##phi f 4 H{ { 2 2 } { 3 3 } } }
+ T{ ##peek f 5 D 0 }
+ T{ ##add-float f 6 4 5 }
+ T{ ##replace f 6 D 0 }
+ } 4 test-bb
+
+ V{
+ T{ ##epilogue }
+ T{ ##return }
+ } 5 test-bb
+
+ test-diamond
+ 4 5 edge
+
+ [ ] [ test-representations ] unit-test
+
+ [ t ] [ 2 get instructions>> first ##load-double? ] unit-test
+
+ [ t ] [ 3 get instructions>> first ##load-double? ] unit-test
+
+ [ t ] [ 4 get instructions>> first ##phi? ] unit-test
+] when
+
+: test-peephole ( insns -- insns )
+ 0 test-bb
+ test-representations
+ 0 get instructions>> ;
+
+! Don't convert the def site into anything but tagged-rep since
+! we might lose precision
+5 \ vreg-counter set-global
+
+[ f ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 1 }
+ T{ ##add-float f 3 0 0 }
+ T{ ##store-memory-imm f 3 2 0 float-rep f }
+ T{ ##store-memory-imm f 3 2 4 float-rep f }
+ T{ ##mul-float f 4 0 0 }
+ T{ ##replace f 4 D 0 }
+ } test-peephole
+ [ ##single>double-float? ] any?
+] unit-test
+
+! Converting a ##load-integer into a ##load-tagged
+[
+ V{
+ T{ ##load-tagged f 1 $[ 100 tag-fixnum ] }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ V{
+ T{ ##load-integer f 1 100 }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
+] unit-test
+
+! Peephole optimization if input to ##shl-imm is tagged
+3 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##sar-imm f 2 1 1 }
+ T{ ##add f 4 2 2 }
+ T{ ##shl-imm f 3 4 $[ tag-bits get ] }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##shl-imm f 2 1 3 }
+ T{ ##add f 3 2 2 }
+ T{ ##replace f 3 D 0 }
+ } test-peephole
+] unit-test
+
+3 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##shl-imm f 2 1 $[ 10 tag-bits get - ] }
+ T{ ##add f 4 2 2 }
+ T{ ##shl-imm f 3 4 $[ tag-bits get ] }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##shl-imm f 2 1 10 }
+ T{ ##add f 3 2 2 }
+ T{ ##replace f 3 D 0 }
+ } test-peephole
+] unit-test
+
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##copy f 2 1 int-rep }
+ T{ ##add f 5 2 2 }
+ T{ ##shl-imm f 3 5 $[ tag-bits get ] }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##shl-imm f 2 1 $[ tag-bits get ] }
+ T{ ##add f 3 2 2 }
+ T{ ##replace f 3 D 0 }
+ } test-peephole
+] unit-test
+
+! Peephole optimization if output of ##shl-imm needs to be tagged
+[
+ V{
+ T{ ##load-integer f 1 100 }
+ T{ ##shl-imm f 2 1 $[ 3 tag-bits get + ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ V{
+ T{ ##load-integer f 1 100 }
+ T{ ##shl-imm f 2 1 3 }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+] unit-test
+
+! Peephole optimization if both input and output of ##shl-imm
+! needs to be tagged
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 3 }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 3 }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
+] unit-test
+
+6 \ vreg-counter set-global
+
+! Peephole optimization if input to ##sar-imm is tagged
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##sar-imm f 7 1 $[ 3 tag-bits get + ] }
+ T{ ##shl-imm f 2 7 $[ tag-bits get ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##sar-imm f 2 1 3 }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+] unit-test
+
+! Tag/untag elimination
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##add-imm f 2 1 $[ 100 tag-fixnum ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##add-imm f 2 1 100 }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add f 2 0 1 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add f 2 0 1 }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+] unit-test
+
+! Make sure we don't exceed immediate bounds
+cpu x86.64? [
+ 4 \ vreg-counter set-global
+
+ [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##sar-imm f 5 0 $[ tag-bits get ] }
+ T{ ##add-imm f 6 5 $[ 30 2^ ] }
+ T{ ##shl-imm f 2 6 $[ tag-bits get ] }
+ T{ ##replace f 2 D 0 }
+ }
+ ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 2 0 $[ 30 2^ ] }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+ ] unit-test
+
+ [
+ V{
+ T{ ##load-integer f 0 100 }
+ T{ ##mul-imm f 7 0 $[ 30 2^ ] }
+ T{ ##shl-imm f 1 7 $[ tag-bits get ] }
+ T{ ##replace f 1 D 0 }
+ }
+ ] [
+ V{
+ T{ ##load-integer f 0 100 }
+ T{ ##mul-imm f 1 0 $[ 30 2^ ] }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
+ ] unit-test
+] when
+
+! Tag/untag elimination for ##mul-imm
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##mul-imm f 1 0 100 }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##mul-imm f 1 0 100 }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
+] unit-test
+
+4 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##sar-imm f 5 1 $[ tag-bits get ] }
+ T{ ##add-imm f 2 5 30 }
+ T{ ##mul-imm f 3 2 $[ 100 tag-fixnum ] }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add-imm f 2 1 30 }
+ T{ ##mul-imm f 3 2 100 }
+ T{ ##replace f 3 D 0 }
+ } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##compare-integer
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer f 2 0 1 cc= }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer f 2 0 1 cc= }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-branch f 0 1 cc= }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-branch f 0 1 cc= }
+ } test-peephole
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-imm-branch f 0 $[ 10 tag-fixnum ] cc= }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-imm-branch f 0 10 cc= }
+ } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##neg
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##neg f 1 0 }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##neg f 1 0 }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
+] unit-test
+
+4 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##peek f 5 D 0 }
+ T{ ##sar-imm f 0 5 $[ tag-bits get ] }
+ T{ ##peek f 6 D 1 }
+ T{ ##sar-imm f 1 6 $[ tag-bits get ] }
+ T{ ##mul f 2 0 1 }
+ T{ ##mul-imm f 3 2 -16 }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##mul f 2 0 1 }
+ T{ ##neg f 3 2 }
+ T{ ##replace f 3 D 0 }
+ } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##not
+2 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##not f 3 0 }
+ T{ ##xor-imm f 1 3 $[ tag-mask get ] }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##not f 1 0 }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
] unit-test
\ No newline at end of file
-! Copyright (C) 2009 Slava Pestov
+! Copyright (C) 2009, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel fry accessors sequences assocs sets namespaces
-arrays combinators combinators.short-circuit math make locals
-deques dlists layouts byte-arrays cpu.architecture
-compiler.utilities
-compiler.constants
+USING: combinators
compiler.cfg
-compiler.cfg.rpo
-compiler.cfg.hats
compiler.cfg.registers
-compiler.cfg.instructions
-compiler.cfg.def-use
-compiler.cfg.utilities
+compiler.cfg.predecessors
compiler.cfg.loop-detection
-compiler.cfg.renaming.functor
-compiler.cfg.representations.preferred ;
-FROM: namespaces => set ;
+compiler.cfg.representations.rewrite
+compiler.cfg.representations.peephole
+compiler.cfg.representations.selection
+compiler.cfg.representations.coalescing ;
IN: compiler.cfg.representations
-! Virtual register representation selection.
-
-ERROR: bad-conversion dst src dst-rep src-rep ;
-
-GENERIC: emit-box ( dst src rep -- )
-GENERIC: emit-unbox ( dst src rep -- )
-
-M:: float-rep emit-box ( dst src rep -- )
- double-rep next-vreg-rep :> temp
- temp src ##single>double-float
- dst temp double-rep emit-box ;
-
-M:: float-rep emit-unbox ( dst src rep -- )
- double-rep next-vreg-rep :> temp
- temp src double-rep emit-unbox
- dst temp ##double>single-float ;
-
-M: double-rep emit-box
- drop
- [ drop 16 float int-rep next-vreg-rep ##allot ]
- [ float-offset swap ##set-alien-double ]
- 2bi ;
-
-M: double-rep emit-unbox
- drop float-offset ##alien-double ;
-
-M:: vector-rep emit-box ( dst src rep -- )
- int-rep next-vreg-rep :> temp
- dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
- temp 16 tag-fixnum ##load-immediate
- temp dst 1 byte-array type-number ##set-slot-imm
- dst byte-array-offset src rep ##set-alien-vector ;
-
-M: vector-rep emit-unbox
- [ byte-array-offset ] dip ##alien-vector ;
-
-M:: scalar-rep emit-box ( dst src rep -- )
- int-rep next-vreg-rep :> temp
- temp src rep ##scalar>integer
- dst temp tag-bits get ##shl-imm ;
-
-M:: scalar-rep emit-unbox ( dst src rep -- )
- int-rep next-vreg-rep :> temp
- temp src tag-bits get ##sar-imm
- dst temp rep ##integer>scalar ;
-
-: emit-conversion ( dst src dst-rep src-rep -- )
- {
- { [ 2dup eq? ] [ drop ##copy ] }
- { [ dup int-rep eq? ] [ drop emit-unbox ] }
- { [ over int-rep eq? ] [ nip emit-box ] }
- [
- 2dup 2array {
- { { double-rep float-rep } [ 2drop ##single>double-float ] }
- { { float-rep double-rep } [ 2drop ##double>single-float ] }
- ! Punning SIMD vector types? Naughty naughty! But
- ! it is allowed... otherwise bail out.
- [
- drop 2dup [ reg-class-of ] bi@ eq?
- [ drop ##copy ] [ bad-conversion ] if
- ]
- } case
- ]
- } cond ;
-
-<PRIVATE
-
-! For every vreg, compute possible representations.
-SYMBOL: possibilities
-
-: possible ( vreg -- reps ) possibilities get at ;
-
-: compute-possibilities ( cfg -- )
- H{ } clone [ '[ swap _ conjoin-at ] with-vreg-reps ] keep
- [ keys ] assoc-map possibilities set ;
-
-! Compute vregs which must remain tagged for their lifetime.
-SYMBOL: always-boxed
-
-:: (compute-always-boxed) ( vreg rep assoc -- )
- rep int-rep eq? [
- int-rep vreg assoc set-at
- ] when ;
-
-: compute-always-boxed ( cfg -- assoc )
- H{ } clone [
- '[
- [
- dup [ ##load-reference? ] [ ##load-constant? ] bi or
- [ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
- ] each-non-phi
- ] each-basic-block
- ] keep ;
-
-! For every vreg, compute the cost of keeping it in every possible
-! representation.
-
-! Cost map maps vreg to representation to cost.
-SYMBOL: costs
-
-: init-costs ( -- )
- possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
-
-: increase-cost ( rep vreg -- )
- ! Increase cost of keeping vreg in rep, making a choice of rep less
- ! likely.
- [ basic-block get loop-nesting-at ] 2dip costs get at at+ ;
-
-: maybe-increase-cost ( possible vreg preferred -- )
- pick eq? [ 2drop ] [ increase-cost ] if ;
-
-: representation-cost ( vreg preferred -- )
- ! 'preferred' is a representation that the instruction can accept with no cost.
- ! So, for each representation that's not preferred, increase the cost of keeping
- ! the vreg in that representation.
- [ drop possible ]
- [ '[ _ _ maybe-increase-cost ] ]
- 2bi each ;
-
-: compute-costs ( cfg -- costs )
- init-costs [ representation-cost ] with-vreg-reps costs get ;
-
-! For every vreg, compute preferred representation, that minimizes costs.
-: minimize-costs ( costs -- representations )
- [ >alist alist-min first ] assoc-map ;
-
-: compute-representations ( cfg -- )
- [ compute-costs minimize-costs ]
- [ compute-always-boxed ]
- bi assoc-union
- representations set ;
-
-! Insert conversions. This introduces new temporaries, so we need
-! to rename opearands too.
-
-! Mapping from vreg,rep pairs to vregs
-SYMBOL: alternatives
-
-:: emit-def-conversion ( dst preferred required -- new-dst' )
- ! If an instruction defines a register with representation 'required',
- ! but the register has preferred representation 'preferred', then
- ! we rename the instruction's definition to a new register, which
- ! becomes the input of a conversion instruction.
- dst required next-vreg-rep [ preferred required emit-conversion ] keep ;
-
-:: emit-use-conversion ( src preferred required -- new-src' )
- ! If an instruction uses a register with representation 'required',
- ! but the register has preferred representation 'preferred', then
- ! we rename the instruction's input to a new register, which
- ! becomes the output of a conversion instruction.
- preferred required eq? [ src ] [
- src required alternatives get [
- required next-vreg-rep :> new-src
- [ new-src ] 2dip preferred emit-conversion
- new-src
- ] 2cache
- ] if ;
-
-SYMBOLS: renaming-set needs-renaming? ;
-
-: init-renaming-set ( -- )
- needs-renaming? off
- V{ } clone renaming-set set ;
-
-: no-renaming ( vreg -- )
- dup 2array renaming-set get push ;
-
-: record-renaming ( from to -- )
- 2array renaming-set get push needs-renaming? on ;
-
-:: (compute-renaming-set) ( ..a vreg required quot: ( ..a vreg preferred required -- ..b ) -- ..b )
- vreg rep-of :> preferred
- preferred required eq?
- [ vreg no-renaming ]
- [ vreg vreg preferred required quot call record-renaming ] if ; inline
-
-: compute-renaming-set ( insn -- )
- ! temp vregs don't need conversions since they're always in their
- ! preferred representation
- init-renaming-set
- [ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ]
- [ , ]
- [ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ]
- tri ;
-
-: converted-value ( vreg -- vreg' )
- renaming-set get pop first2 [ assert= ] dip ;
-
-RENAMING: convert [ converted-value ] [ converted-value ] [ ]
-
-: perform-renaming ( insn -- )
- needs-renaming? get [
- renaming-set get reverse! drop
- [ convert-insn-uses ] [ convert-insn-defs ] bi
- renaming-set get length 0 assert=
- ] [ drop ] if ;
-
-GENERIC: conversions-for-insn ( insn -- )
-
-SYMBOL: phi-mappings
-
-! compiler.cfg.cssa inserts conversions which convert phi inputs into
-! the representation of the output. However, we still have to do some
-! processing here, because if the only node that uses the output of
-! the phi instruction is another phi instruction then this phi node's
-! output won't have a representation assigned.
-M: ##phi conversions-for-insn
- [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
-
-! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
-! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
-: convert-to-zero-vector? ( insn -- ? )
- {
- [ dst>> rep-of vector-rep? ]
- [ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ]
- } 1&& ;
-: convert-to-fill-vector? ( insn -- ? )
- {
- [ dst>> rep-of vector-rep? ]
- [ obj>> B{ 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 } = ]
- } 1&& ;
-
-: (convert-to-zero/fill-vector) ( insn -- dst rep )
- dst>> dup rep-of ; inline
-
-: conversions-for-load-insn ( insn -- ?insn )
- {
- {
- [ dup convert-to-zero-vector? ]
- [ (convert-to-zero/fill-vector) ##zero-vector f ]
- }
- {
- [ dup convert-to-fill-vector? ]
- [ (convert-to-zero/fill-vector) ##fill-vector f ]
- }
- [ ]
- } cond ;
-
-M: ##load-reference conversions-for-insn
- conversions-for-load-insn [ call-next-method ] when* ;
-
-M: ##load-constant conversions-for-insn
- conversions-for-load-insn [ call-next-method ] when* ;
-
-M: vreg-insn conversions-for-insn
- [ compute-renaming-set ] [ perform-renaming ] bi ;
-
-M: insn conversions-for-insn , ;
-
-: conversions-for-block ( bb -- )
- dup kill-block? [ drop ] [
- [
- [
- H{ } clone alternatives set
- [ conversions-for-insn ] each
- ] V{ } make
- ] change-instructions drop
- ] if ;
-
-! If the output of a phi instruction is only used as the input to another
-! phi instruction, then we want to use the same representation for both
-! if possible.
-SYMBOL: work-list
-
-: add-to-work-list ( vregs -- )
- work-list get push-all-front ;
-
-: rep-assigned ( vregs -- vregs' )
- representations get '[ _ key? ] filter ;
-
-: rep-not-assigned ( vregs -- vregs' )
- representations get '[ _ key? not ] filter ;
-
-: add-ready-phis ( -- )
- phi-mappings get keys rep-assigned add-to-work-list ;
-
-: process-phi-mapping ( dst -- )
- ! If dst = phi(src1,src2,...) and dst's representation has been
- ! determined, assign that representation to each one of src1,...
- ! that does not have a representation yet, and process those, too.
- dup phi-mappings get at* [
- [ rep-of ] [ rep-not-assigned ] bi*
- [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
- ] [ 2drop ] if ;
-
-: remaining-phi-mappings ( -- )
- phi-mappings get keys rep-not-assigned
- [ [ int-rep ] dip set-rep-of ] each ;
-
-: process-phi-mappings ( -- )
- <hashed-dlist> work-list set
- add-ready-phis
- work-list get [ process-phi-mapping ] slurp-deque
- remaining-phi-mappings ;
-
-: insert-conversions ( cfg -- )
- H{ } clone phi-mappings set
- [ conversions-for-block ] each-basic-block
- process-phi-mappings ;
-
-PRIVATE>
+! Virtual register representation selection. This is where
+! decisions about integer tagging and float and vector boxing
+! are made. The appropriate conversion operations inserted
+! after a cost analysis.
: select-representations ( cfg -- cfg' )
needs-loops
+ needs-predecessors
{
+ [ compute-components ]
[ compute-possibilities ]
[ compute-representations ]
[ insert-conversions ]
[ ]
- } cleave
- representations get cfg get (>>reps) ;
+ } cleave ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators
+combinators.short-circuit layouts kernel locals make math
+namespaces sequences
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.renaming.functor
+compiler.cfg.representations.conversion
+compiler.cfg.representations.preferred
+compiler.cfg.rpo
+compiler.cfg.utilities
+cpu.architecture ;
+IN: compiler.cfg.representations.rewrite
+
+! Insert conversions. This introduces new temporaries, so we need
+! to rename opearands too.
+
+! Mapping from vreg,rep pairs to vregs
+SYMBOL: alternatives
+
+:: (emit-def-conversion) ( dst preferred required -- new-dst' )
+ ! If an instruction defines a register with representation 'required',
+ ! but the register has preferred representation 'preferred', then
+ ! we rename the instruction's definition to a new register, which
+ ! becomes the input of a conversion instruction.
+ dst required next-vreg-rep [ preferred required emit-conversion ] keep ;
+
+:: (emit-use-conversion) ( src preferred required -- new-src' )
+ ! If an instruction uses a register with representation 'required',
+ ! but the register has preferred representation 'preferred', then
+ ! we rename the instruction's input to a new register, which
+ ! becomes the output of a conversion instruction.
+ preferred required eq? [ src ] [
+ src required alternatives get [
+ required next-vreg-rep :> new-src
+ [ new-src ] 2dip preferred emit-conversion
+ new-src
+ ] 2cache
+ ] if ;
+
+SYMBOLS: renaming-set needs-renaming? ;
+
+: init-renaming-set ( -- )
+ needs-renaming? off
+ renaming-set get delete-all ;
+
+: no-renaming ( vreg -- )
+ dup 2array renaming-set get push ;
+
+: record-renaming ( from to -- )
+ 2array renaming-set get push needs-renaming? on ;
+
+:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- new-vreg ) -- )
+ vreg rep-of :> preferred
+ preferred required eq?
+ [ vreg no-renaming ]
+ [ vreg vreg preferred required quot call record-renaming ] if ; inline
+
+: emit-use-conversion ( insn -- )
+ [ [ (emit-use-conversion) ] (compute-renaming-set) ] each-use-rep ;
+
+: no-use-conversion ( insn -- )
+ [ drop no-renaming ] each-use-rep ;
+
+: emit-def-conversion ( insn -- )
+ [ [ (emit-def-conversion) ] (compute-renaming-set) ] each-def-rep ;
+
+: no-def-conversion ( insn -- )
+ [ drop no-renaming ] each-def-rep ;
+
+: converted-value ( vreg -- vreg' )
+ renaming-set get pop first2 [ assert= ] dip ;
+
+RENAMING: convert [ converted-value ] [ converted-value ] [ ]
+
+: perform-renaming ( insn -- )
+ needs-renaming? get [
+ renaming-set get reverse! drop
+ [ convert-insn-uses ] [ convert-insn-defs ] bi
+ renaming-set get length 0 assert=
+ ] [ drop ] if ;
+
+GENERIC: conversions-for-insn ( insn -- )
+
+M: ##phi conversions-for-insn , ;
+
+M: ##copy conversions-for-insn , ;
+
+M: insn conversions-for-insn , ;
+
+: conversions-for-block ( bb -- )
+ dup kill-block? [ drop ] [
+ [
+ [
+ H{ } clone alternatives set
+ [ conversions-for-insn ] each
+ ] V{ } make
+ ] change-instructions drop
+ ] if ;
+
+: insert-conversions ( cfg -- )
+ V{ } clone renaming-set set
+ [ conversions-for-block ] each-basic-block ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs byte-arrays combinators
+disjoint-sets fry kernel locals math namespaces sequences sets
+compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.loop-detection
+compiler.cfg.registers
+compiler.cfg.representations.preferred
+compiler.cfg.representations.coalescing
+compiler.cfg.rpo
+compiler.cfg.utilities
+compiler.utilities
+cpu.architecture ;
+FROM: namespaces => set ;
+IN: compiler.cfg.representations.selection
+
+! vregs which must be tagged at the definition site because
+! there is at least one usage that is not int-rep. If all usages
+! are int-rep it is safe to untag at the definition site.
+SYMBOL: tagged-vregs
+
+SYMBOL: vreg-reps
+
+: handle-def ( vreg rep -- )
+ swap vreg>scc vreg-reps get
+ [ [ intersect ] when* ] change-at ;
+
+: handle-use ( vreg rep -- )
+ int-rep eq? [ drop ] [ vreg>scc tagged-vregs get adjoin ] if ;
+
+GENERIC: (collect-vreg-reps) ( insn -- )
+
+M: ##load-reference (collect-vreg-reps)
+ [ dst>> ] [ obj>> ] bi {
+ { [ dup float? ] [ drop { float-rep double-rep } ] }
+ { [ dup byte-array? ] [ drop vector-reps ] }
+ [ drop { } ]
+ } cond handle-def ;
+
+M: vreg-insn (collect-vreg-reps)
+ [ [ handle-use ] each-use-rep ]
+ [ [ 1array handle-def ] each-def-rep ]
+ [ [ 1array handle-def ] each-temp-rep ]
+ tri ;
+
+M: insn (collect-vreg-reps) drop ;
+
+: collect-vreg-reps ( cfg -- )
+ H{ } clone vreg-reps set
+ HS{ } clone tagged-vregs set
+ [ [ (collect-vreg-reps) ] each-non-phi ] each-basic-block ;
+
+SYMBOL: possibilities
+
+: possible-reps ( vreg reps -- vreg reps )
+ { tagged-rep } union
+ 2dup [ tagged-vregs get in? not ] [ { tagged-rep } = ] bi* and
+ [ drop { tagged-rep int-rep } ] [ ] if ;
+
+: compute-possibilities ( cfg -- )
+ collect-vreg-reps
+ vreg-reps get [ possible-reps ] assoc-map possibilities set ;
+
+! For every vreg, compute the cost of keeping it in every possible
+! representation.
+
+! Cost map maps vreg to representation to cost.
+SYMBOL: costs
+
+: init-costs ( -- )
+ ! Initialize cost as 0 for each possibility.
+ possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
+
+: 10^ ( n -- x ) 10 <repetition> product ;
+
+: increase-cost ( rep scc factor -- )
+ ! Increase cost of keeping vreg in rep, making a choice of rep less
+ ! likely. If the rep is not in the cost alist, it means this
+ ! representation is prohibited.
+ [ costs get at 2dup key? ] dip
+ '[ [ current-loop-nesting 10^ _ * + ] change-at ] [ 2drop ] if ;
+
+:: increase-costs ( vreg preferred factor -- )
+ vreg vreg>scc :> scc
+ scc possibilities get at [
+ dup preferred eq? [ drop ] [ scc factor increase-cost ] if
+ ] each ; inline
+
+UNION: inert-tag-untag-insn
+##add
+##sub
+##and
+##or
+##xor
+##min
+##max ;
+
+UNION: inert-arithmetic-tag-untag-insn
+##add-imm
+##sub-imm ;
+
+UNION: inert-bitwise-tag-untag-insn
+##and-imm
+##or-imm
+##xor-imm ;
+
+GENERIC: has-peephole-opts? ( insn -- ? )
+
+M: insn has-peephole-opts? drop f ;
+M: ##load-integer has-peephole-opts? drop t ;
+M: ##load-reference has-peephole-opts? drop t ;
+M: ##neg has-peephole-opts? drop t ;
+M: ##not has-peephole-opts? drop t ;
+M: inert-tag-untag-insn has-peephole-opts? drop t ;
+M: inert-arithmetic-tag-untag-insn has-peephole-opts? drop t ;
+M: inert-bitwise-tag-untag-insn has-peephole-opts? drop t ;
+M: ##mul-imm has-peephole-opts? drop t ;
+M: ##shl-imm has-peephole-opts? drop t ;
+M: ##shr-imm has-peephole-opts? drop t ;
+M: ##sar-imm has-peephole-opts? drop t ;
+M: ##compare-integer-imm has-peephole-opts? drop t ;
+M: ##compare-integer has-peephole-opts? drop t ;
+M: ##compare-integer-imm-branch has-peephole-opts? drop t ;
+M: ##compare-integer-branch has-peephole-opts? drop t ;
+
+GENERIC: compute-insn-costs ( insn -- )
+
+M: insn compute-insn-costs drop ;
+
+M: vreg-insn compute-insn-costs
+ dup has-peephole-opts? 2 5 ? '[ _ increase-costs ] each-rep ;
+
+: compute-costs ( cfg -- )
+ init-costs
+ [
+ [ basic-block set ]
+ [ [ compute-insn-costs ] each-non-phi ] bi
+ ] each-basic-block ;
+
+! For every vreg, compute preferred representation, that minimizes costs.
+: minimize-costs ( costs -- representations )
+ [ nip assoc-empty? not ] assoc-filter
+ [ >alist alist-min first ] assoc-map ;
+
+: compute-representations ( cfg -- )
+ compute-costs costs get minimize-costs
+ [ components get [ disjoint-set-members ] keep ] dip
+ '[ dup _ representative _ at ] H{ } map>assoc
+ representations set ;
[ drop basic-block set ]
[ change-instructions drop ] 2bi ; inline
-: local-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... cfg' )
- dupd '[ _ optimize-basic-block ] each-basic-block ; inline
+: simple-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... )
+ '[ _ optimize-basic-block ] each-basic-block ; inline
: needs-post-order ( cfg -- cfg' )
dup post-order drop ;
: needs-save-context? ( insns -- ? )
[
{
+ [ ##call-gc? ]
[ ##unary-float-function? ]
[ ##binary-float-function? ]
[ ##alien-invoke? ]
: insert-save-context ( bb -- )
dup instructions>> dup needs-save-context? [
- int-rep next-vreg-rep
- int-rep next-vreg-rep
+ tagged-rep next-vreg-rep
+ tagged-rep next-vreg-rep
\ ##save-context new-insn prefix
>>instructions drop
] [ 2drop ] if ;
reset-counters
V{
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add-imm f 2 1 50 }
T{ ##add-imm f 2 2 10 }
T{ ##branch }
} 0 test-bb
V{
- T{ ##load-immediate f 3 3 }
+ T{ ##load-integer f 3 3 }
T{ ##branch }
} 1 test-bb
V{
- T{ ##load-immediate f 3 4 }
+ T{ ##load-integer f 3 4 }
T{ ##branch }
} 2 test-bb
[
V{
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add-imm f 2 1 50 }
T{ ##add-imm f 3 2 10 }
T{ ##branch }
[
V{
- T{ ##load-immediate f 4 3 }
+ T{ ##load-integer f 4 3 }
T{ ##branch }
}
] [ 1 get instructions>> ] unit-test
[
V{
- T{ ##load-immediate f 5 4 }
+ T{ ##load-integer f 5 4 }
T{ ##branch }
}
] [ 2 get instructions>> ] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel locals fry sequences
cpu.architecture
compiler.cfg.def-use
compiler.cfg.utilities
compiler.cfg.registers
-compiler.cfg.instructions
-compiler.cfg.representations ;
+compiler.cfg.instructions ;
IN: compiler.cfg.ssa.cssa
! Convert SSA to conventional SSA. This pass runs after representation
:: insert-copy ( bb src rep -- bb dst )
bb src insert-copy? [
rep next-vreg-rep :> dst
- bb [ dst src rep src rep-of emit-conversion ] add-instructions
+ bb [ dst src rep ##copy ] add-instructions
bb dst
] [ bb src ] if ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry kernel namespaces
sequences sequences.deep
sets vectors
+cpu.architecture
compiler.cfg.rpo
compiler.cfg.def-use
-compiler.cfg.renaming
compiler.cfg.registers
compiler.cfg.dominance
compiler.cfg.instructions
FROM: namespaces => set ;
IN: compiler.cfg.ssa.destruction
-! Maps vregs to leaders.
+! Because of the design of the register allocator, this pass
+! has three peculiar properties.
+!
+! 1) Instead of renaming vreg usages in the CFG, a map from
+! vregs to canonical representatives is computed. This allows
+! the register allocator to use the original SSA names to get
+! reaching definitions.
+! 2) Useless ##copy instructions, and all ##phi instructions,
+! are eliminated, so the register allocator does not have to
+! remove any redundant operations.
+! 3) A side effect of running this pass is that SSA liveness
+! information is computed, so the register allocator does not
+! need to compute it again.
+
SYMBOL: leader-map
: leader ( vreg -- vreg' ) leader-map get compress-path ;
: class-elements ( vreg -- elts ) class-element-map get at ;
+<PRIVATE
+
! Sequence of vreg pairs
SYMBOL: copies
: init-coalescing ( -- )
- H{ } clone leader-map set
- H{ } clone class-element-map set
+ defs get keys
+ [ [ dup ] H{ } map>assoc leader-map set ]
+ [ [ dup 1vector ] H{ } map>assoc class-element-map set ] bi
V{ } clone copies set ;
: classes-interfere? ( vreg1 vreg2 -- ? )
2bi
] if ;
-: introduce-vreg ( vreg -- )
- [ leader-map get conjoin ]
- [ [ 1vector ] keep class-element-map get set-at ] bi ;
-
GENERIC: prepare-insn ( insn -- )
: try-to-coalesce ( dst src -- ) 2array copies get push ;
M: insn prepare-insn
- [ defs-vreg ] [ uses-vregs ] bi
- 2dup empty? not and [
- first
- 2dup [ rep-of ] bi@ eq?
- [ try-to-coalesce ] [ 2drop ] if
- ] [ 2drop ] if ;
+ [ temp-vregs [ leader-map get conjoin ] each ]
+ [
+ [ defs-vreg ] [ uses-vregs ] bi
+ 2dup empty? not and [
+ first
+ 2dup [ rep-of reg-class-of ] bi@ eq?
+ [ try-to-coalesce ] [ 2drop ] if
+ ] [ 2drop ] if
+ ] bi ;
M: ##copy prepare-insn
[ dst>> ] [ src>> ] bi try-to-coalesce ;
+M: ##tagged>integer prepare-insn
+ [ dst>> ] [ src>> ] bi eliminate-copy ;
+
M: ##phi prepare-insn
[ dst>> ] [ inputs>> values ] bi
[ eliminate-copy ] with each ;
: prepare-coalescing ( cfg -- )
init-coalescing
- defs get keys [ introduce-vreg ] each
[ prepare-block ] each-basic-block ;
: process-copies ( -- )
[ 2drop ] [ eliminate-copy ] if
] assoc-each ;
-: useless-copy? ( ##copy -- ? )
- dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
+GENERIC: useful-insn? ( insn -- ? )
-: perform-renaming ( cfg -- )
- leader-map get keys [ dup leader ] H{ } map>assoc renamings set
- [
- instructions>> [
- [ rename-insn-defs ]
- [ rename-insn-uses ]
- [ [ useless-copy? ] [ ##phi? ] bi or not ] tri
- ] filter! drop
- ] each-basic-block ;
+: useful-copy? ( insn -- ? )
+ [ dst>> leader ] [ src>> leader ] bi eq? not ; inline
+
+M: ##copy useful-insn? useful-copy? ;
+
+M: ##tagged>integer useful-insn? useful-copy? ;
+
+M: ##phi useful-insn? drop f ;
+
+M: insn useful-insn? drop t ;
+
+: cleanup-cfg ( cfg -- )
+ [ [ useful-insn? ] filter! ] simple-optimization ;
+
+PRIVATE>
: destruct-ssa ( cfg -- cfg' )
needs-dominance
dup construct-cssa
dup compute-defs
- compute-ssa-live-sets
+ dup compute-ssa-live-sets
dup compute-live-ranges
dup prepare-coalescing
process-copies
- dup perform-renaming ;
+ dup cleanup-cfg ;
: test-interference ( -- )
cfg new 0 get >>entry
- compute-ssa-live-sets
+ dup compute-ssa-live-sets
dup compute-defs
compute-live-ranges ;
+++ /dev/null
-! Copyright (C) 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test namespaces sequences vectors accessors sets
-arrays math.ranges assocs
-cpu.architecture
-compiler.cfg
-compiler.cfg.ssa.liveness.private
-compiler.cfg.ssa.liveness
-compiler.cfg.debugger
-compiler.cfg.instructions
-compiler.cfg.predecessors
-compiler.cfg.registers
-compiler.cfg.dominance
-compiler.cfg.def-use ;
-IN: compiler.cfg.ssa.liveness
-
-[ t ] [ { 1 } 1 only? ] unit-test
-[ t ] [ { } 1 only? ] unit-test
-[ f ] [ { 2 1 } 1 only? ] unit-test
-[ f ] [ { 2 } 1 only? ] unit-test
-
-: test-liveness ( -- )
- cfg new 0 get >>entry
- dup compute-defs
- dup compute-uses
- needs-dominance
- precompute-liveness ;
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##replace f 0 D 0 }
- T{ ##replace f 1 D 1 }
-} 0 test-bb
-
-V{
- T{ ##replace f 2 D 0 }
-} 1 test-bb
-
-V{
- T{ ##replace f 3 D 0 }
-} 2 test-bb
-
-0 { 1 2 } edges
-
-[ ] [ test-liveness ] unit-test
-
-[ H{ } ] [ back-edge-targets get ] unit-test
-[ t ] [ 0 get R_q { 0 1 2 } [ get ] map unique = ] unit-test
-[ t ] [ 1 get R_q { 1 } [ get ] map unique = ] unit-test
-[ t ] [ 2 get R_q { 2 } [ get ] map unique = ] unit-test
-
-: self-T_q ( n -- ? )
- get [ T_q ] [ 1array unique ] bi = ;
-
-[ t ] [ 0 self-T_q ] unit-test
-[ t ] [ 1 self-T_q ] unit-test
-[ t ] [ 2 self-T_q ] unit-test
-
-[ f ] [ 0 0 get live-in? ] unit-test
-[ t ] [ 1 0 get live-in? ] unit-test
-[ t ] [ 2 0 get live-in? ] unit-test
-[ t ] [ 3 0 get live-in? ] unit-test
-
-[ f ] [ 0 0 get live-out? ] unit-test
-[ f ] [ 1 0 get live-out? ] unit-test
-[ t ] [ 2 0 get live-out? ] unit-test
-[ t ] [ 3 0 get live-out? ] unit-test
-
-[ f ] [ 0 1 get live-in? ] unit-test
-[ f ] [ 1 1 get live-in? ] unit-test
-[ t ] [ 2 1 get live-in? ] unit-test
-[ f ] [ 3 1 get live-in? ] unit-test
-
-[ f ] [ 0 1 get live-out? ] unit-test
-[ f ] [ 1 1 get live-out? ] unit-test
-[ f ] [ 2 1 get live-out? ] unit-test
-[ f ] [ 3 1 get live-out? ] unit-test
-
-[ f ] [ 0 2 get live-in? ] unit-test
-[ f ] [ 1 2 get live-in? ] unit-test
-[ f ] [ 2 2 get live-in? ] unit-test
-[ t ] [ 3 2 get live-in? ] unit-test
-
-[ f ] [ 0 2 get live-out? ] unit-test
-[ f ] [ 1 2 get live-out? ] unit-test
-[ f ] [ 2 2 get live-out? ] unit-test
-[ f ] [ 3 2 get live-out? ] unit-test
-
-V{ } 0 test-bb
-V{ } 1 test-bb
-V{ } 2 test-bb
-V{ } 3 test-bb
-V{
- T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
-} 4 test-bb
-test-diamond
-
-[ ] [ test-liveness ] unit-test
-
-[ t ] [ 0 1 get live-in? ] unit-test
-[ t ] [ 1 1 get live-in? ] unit-test
-[ f ] [ 2 1 get live-in? ] unit-test
-
-[ t ] [ 0 1 get live-out? ] unit-test
-[ t ] [ 1 1 get live-out? ] unit-test
-[ f ] [ 2 1 get live-out? ] unit-test
-
-[ t ] [ 0 2 get live-in? ] unit-test
-[ f ] [ 1 2 get live-in? ] unit-test
-[ f ] [ 2 2 get live-in? ] unit-test
-
-[ f ] [ 0 2 get live-out? ] unit-test
-[ f ] [ 1 2 get live-out? ] unit-test
-[ f ] [ 2 2 get live-out? ] unit-test
-
-[ f ] [ 0 3 get live-in? ] unit-test
-[ t ] [ 1 3 get live-in? ] unit-test
-[ f ] [ 2 3 get live-in? ] unit-test
-
-[ f ] [ 0 3 get live-out? ] unit-test
-[ f ] [ 1 3 get live-out? ] unit-test
-[ f ] [ 2 3 get live-out? ] unit-test
-
-[ f ] [ 0 4 get live-in? ] unit-test
-[ f ] [ 1 4 get live-in? ] unit-test
-[ f ] [ 2 4 get live-in? ] unit-test
-
-[ f ] [ 0 4 get live-out? ] unit-test
-[ f ] [ 1 4 get live-out? ] unit-test
-[ f ] [ 2 4 get live-out? ] unit-test
-
-! This is the CFG in Figure 3 from the paper
-V{ } 0 test-bb
-V{ } 1 test-bb
-0 1 edge
-V{ } 2 test-bb
-1 2 edge
-V{
- T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 0 }
- T{ ##peek f 2 D 0 }
-} 3 test-bb
-V{ } 11 test-bb
-2 { 3 11 } edges
-V{
- T{ ##replace f 0 D 0 }
-} 4 test-bb
-V{ } 8 test-bb
-3 { 8 4 } edges
-V{
- T{ ##replace f 1 D 0 }
-} 9 test-bb
-8 9 edge
-V{
- T{ ##replace f 2 D 0 }
-} 5 test-bb
-4 5 edge
-V{ } 10 test-bb
-V{ } 6 test-bb
-5 6 edge
-9 { 6 10 } edges
-V{ } 7 test-bb
-6 { 5 7 } edges
-10 8 edge
-7 2 edge
-
-[ ] [ test-liveness ] unit-test
-
-[ t ] [ 1 get R_q 1 11 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 2 get R_q 2 11 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 3 get R_q 3 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 4 get R_q 4 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 5 get R_q 5 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 6 get R_q 6 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 7 get R_q 7 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 8 get R_q 6 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 9 get R_q 8 6 10 [a,b] remove [ get ] map unique = ] unit-test
-[ t ] [ 10 get R_q 10 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 11 get R_q 11 11 [a,b] [ get ] map unique = ] unit-test
-
-[ t ] [ 1 get T_q 1 get 1array unique = ] unit-test
-[ t ] [ 2 get T_q 2 get 1array unique = ] unit-test
-[ t ] [ 3 get T_q 3 get 2 get 2array unique = ] unit-test
-[ t ] [ 4 get T_q 4 get 2 get 2array unique = ] unit-test
-[ t ] [ 5 get T_q 5 get 2 get 2array unique = ] unit-test
-[ t ] [ 6 get T_q { 6 2 5 } [ get ] map unique = ] unit-test
-[ t ] [ 7 get T_q { 7 2 } [ get ] map unique = ] unit-test
-[ t ] [ 8 get T_q { 8 2 5 } [ get ] map unique = ] unit-test
-[ t ] [ 9 get T_q { 2 5 8 9 } [ get ] map unique = ] unit-test
-[ t ] [ 10 get T_q { 2 5 8 10 } [ get ] map unique = ] unit-test
-[ t ] [ 11 get T_q 11 get 1array unique = ] unit-test
-
-[ f ] [ 1 get back-edge-target? ] unit-test
-[ t ] [ 2 get back-edge-target? ] unit-test
-[ f ] [ 3 get back-edge-target? ] unit-test
-[ f ] [ 4 get back-edge-target? ] unit-test
-[ t ] [ 5 get back-edge-target? ] unit-test
-[ f ] [ 6 get back-edge-target? ] unit-test
-[ f ] [ 7 get back-edge-target? ] unit-test
-[ t ] [ 8 get back-edge-target? ] unit-test
-[ f ] [ 9 get back-edge-target? ] unit-test
-[ f ] [ 10 get back-edge-target? ] unit-test
-[ f ] [ 11 get back-edge-target? ] unit-test
-
-[ f ] [ 0 1 get live-in? ] unit-test
-[ f ] [ 1 1 get live-in? ] unit-test
-[ f ] [ 2 1 get live-in? ] unit-test
-
-[ f ] [ 0 1 get live-out? ] unit-test
-[ f ] [ 1 1 get live-out? ] unit-test
-[ f ] [ 2 1 get live-out? ] unit-test
-
-[ f ] [ 0 2 get live-in? ] unit-test
-[ f ] [ 1 2 get live-in? ] unit-test
-[ f ] [ 2 2 get live-in? ] unit-test
-
-[ f ] [ 0 2 get live-out? ] unit-test
-[ f ] [ 1 2 get live-out? ] unit-test
-[ f ] [ 2 2 get live-out? ] unit-test
-
-[ f ] [ 0 3 get live-in? ] unit-test
-[ f ] [ 1 3 get live-in? ] unit-test
-[ f ] [ 2 3 get live-in? ] unit-test
-
-[ t ] [ 0 3 get live-out? ] unit-test
-[ t ] [ 1 3 get live-out? ] unit-test
-[ t ] [ 2 3 get live-out? ] unit-test
-
-[ t ] [ 0 4 get live-in? ] unit-test
-[ f ] [ 1 4 get live-in? ] unit-test
-[ t ] [ 2 4 get live-in? ] unit-test
-
-[ f ] [ 0 4 get live-out? ] unit-test
-[ f ] [ 1 4 get live-out? ] unit-test
-[ t ] [ 2 4 get live-out? ] unit-test
-
-[ f ] [ 0 5 get live-in? ] unit-test
-[ f ] [ 1 5 get live-in? ] unit-test
-[ t ] [ 2 5 get live-in? ] unit-test
-
-[ f ] [ 0 5 get live-out? ] unit-test
-[ f ] [ 1 5 get live-out? ] unit-test
-[ t ] [ 2 5 get live-out? ] unit-test
-
-[ f ] [ 0 6 get live-in? ] unit-test
-[ f ] [ 1 6 get live-in? ] unit-test
-[ t ] [ 2 6 get live-in? ] unit-test
-
-[ f ] [ 0 6 get live-out? ] unit-test
-[ f ] [ 1 6 get live-out? ] unit-test
-[ t ] [ 2 6 get live-out? ] unit-test
-
-[ f ] [ 0 7 get live-in? ] unit-test
-[ f ] [ 1 7 get live-in? ] unit-test
-[ f ] [ 2 7 get live-in? ] unit-test
-
-[ f ] [ 0 7 get live-out? ] unit-test
-[ f ] [ 1 7 get live-out? ] unit-test
-[ f ] [ 2 7 get live-out? ] unit-test
-
-[ f ] [ 0 8 get live-in? ] unit-test
-[ t ] [ 1 8 get live-in? ] unit-test
-[ t ] [ 2 8 get live-in? ] unit-test
-
-[ f ] [ 0 8 get live-out? ] unit-test
-[ t ] [ 1 8 get live-out? ] unit-test
-[ t ] [ 2 8 get live-out? ] unit-test
-
-[ f ] [ 0 9 get live-in? ] unit-test
-[ t ] [ 1 9 get live-in? ] unit-test
-[ t ] [ 2 9 get live-in? ] unit-test
-
-[ f ] [ 0 9 get live-out? ] unit-test
-[ t ] [ 1 9 get live-out? ] unit-test
-[ t ] [ 2 9 get live-out? ] unit-test
-
-[ f ] [ 0 10 get live-in? ] unit-test
-[ t ] [ 1 10 get live-in? ] unit-test
-[ t ] [ 2 10 get live-in? ] unit-test
-
-[ f ] [ 0 10 get live-out? ] unit-test
-[ t ] [ 1 10 get live-out? ] unit-test
-[ t ] [ 2 10 get live-out? ] unit-test
-
-[ f ] [ 0 11 get live-in? ] unit-test
-[ f ] [ 1 11 get live-in? ] unit-test
-[ f ] [ 2 11 get live-in? ] unit-test
-
-[ f ] [ 0 11 get live-out? ] unit-test
-[ f ] [ 1 11 get live-out? ] unit-test
-[ f ] [ 2 11 get live-out? ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences assocs accessors
-namespaces fry math sets combinators locals
-compiler.cfg.rpo
-compiler.cfg.dominance
-compiler.cfg.def-use
-compiler.cfg.instructions ;
-FROM: namespaces => set ;
-IN: compiler.cfg.ssa.liveness
-
-! Liveness checking on SSA IR, as described in
-! "Fast Liveness Checking for SSA-Form Programs", Sebastian Hack et al.
-! http://hal.archives-ouvertes.fr/docs/00/19/22/19/PDF/fast_liveness.pdf
-
-<PRIVATE
-
-! The sets T_q and R_q are described there
-SYMBOL: T_q-sets
-SYMBOL: R_q-sets
-
-! Targets of back edges
-SYMBOL: back-edge-targets
-
-: T_q ( q -- T_q )
- T_q-sets get at ;
-
-: R_q ( q -- R_q )
- R_q-sets get at ;
-
-: back-edge-target? ( block -- ? )
- back-edge-targets get key? ;
-
-: next-R_q ( q -- R_q )
- [ ] [ successors>> ] [ number>> ] tri
- '[ number>> _ >= ] filter
- [ R_q ] map assoc-combine
- [ conjoin ] keep ;
-
-: set-R_q ( q -- )
- [ next-R_q ] keep R_q-sets get set-at ;
-
-: set-back-edges ( q -- )
- [ successors>> ] [ number>> ] bi '[
- dup number>> _ <
- [ back-edge-targets get conjoin ] [ drop ] if
- ] each ;
-
-: init-R_q ( -- )
- H{ } clone R_q-sets set
- H{ } clone back-edge-targets set ;
-
-: compute-R_q ( cfg -- )
- init-R_q
- post-order [
- [ set-R_q ] [ set-back-edges ] bi
- ] each ;
-
-! This algorithm for computing T_q uses equation (1)
-! but not the faster algorithm described in the paper
-
-: back-edges-from ( q -- edges )
- R_q keys [
- [ successors>> ] [ number>> ] bi
- '[ number>> _ < ] filter
- ] gather ;
-
-: T^_q ( q -- T^_q )
- [ back-edges-from ] [ R_q ] bi
- '[ _ key? not ] filter ;
-
-: next-T_q ( q -- T_q )
- dup dup T^_q [ next-T_q keys ] map
- concat unique [ conjoin ] keep
- [ swap T_q-sets get set-at ] keep ;
-
-: compute-T_q ( cfg -- )
- H{ } T_q-sets set
- [ next-T_q drop ] each-basic-block ;
-
-PRIVATE>
-
-: precompute-liveness ( cfg -- )
- [ compute-R_q ] [ compute-T_q ] bi ;
-
-<PRIVATE
-
-! This doesn't take advantage of ordering T_q,a so you
-! only have to check one if the CFG is reducible.
-! It should be changed to be more efficient.
-
-: only? ( seq obj -- ? )
- '[ _ eq? ] all? ;
-
-: strictly-dominates? ( bb1 bb2 -- ? )
- [ dominates? ] [ eq? not ] 2bi and ;
-
-: T_q,a ( a q -- T_q,a )
- ! This could take advantage of the structure of dominance,
- ! but probably I'll replace it with the algorithm that works
- ! on reducible CFGs anyway
- T_q keys swap def-of
- [ '[ _ swap strictly-dominates? ] filter ] when* ;
-
-: live? ( vreg node quot -- ? )
- [ [ T_q,a ] [ drop uses-of ] 2bi ] dip
- '[ [ R_q keys _ ] keep @ intersects? ] any? ; inline
-
-PRIVATE>
-
-: live-in? ( vreg node -- ? )
- [ drop ] live? ;
-
-<PRIVATE
-
-: (live-out?) ( vreg node -- ? )
- dup dup dup '[
- _ = _ back-edge-target? not and
- [ _ swap remove ] when
- ] live? ;
-
-PRIVATE>
-
-:: live-out? ( vreg node -- ? )
- vreg def-of :> def
- {
- { [ node def eq? ] [ vreg uses-of def only? not ] }
- { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
- [ f ]
- } cond ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math math.order namespaces accessors kernel layouts combinators
-combinators.smart assocs sequences cpu.architecture ;
+USING: math math.order namespaces accessors kernel layouts
+combinators combinators.smart assocs sequences cpu.architecture
+words compiler.cfg.instructions ;
IN: compiler.cfg.stack-frame
TUPLE: stack-frame
{ params integer }
{ return integer }
-{ total-size integer }
-{ gc-root-size integer }
{ spill-area-size integer }
+{ total-size integer }
{ calls-vm? boolean } ;
! Stack frame utilities
: spill-offset ( n -- offset )
param-base + ;
-: gc-root-base ( -- n )
- stack-frame get spill-area-size>> param-base + ;
-
-: gc-root-offset ( n -- n' ) gc-root-base + ;
-
: (stack-frame-size) ( stack-frame -- n )
[
- {
- [ params>> ]
- [ return>> ]
- [ gc-root-size>> ]
- [ spill-area-size>> ]
- } cleave
+ [ params>> ] [ return>> ] [ spill-area-size>> ] tri
] sum-outputs ;
: max-stack-frame ( frame1 frame2 -- frame3 )
{
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
- [ [ gc-root-size>> ] bi@ max >>gc-root-size ]
+ [ [ spill-area-size>> ] bi@ max >>spill-area-size ]
[ [ calls-vm?>> ] bi@ or >>calls-vm? ]
- } 2cleave ;
\ No newline at end of file
+ } 2cleave ;
+
+! PowerPC backend sets frame-required? for ##integer>float too
+\ ##spill t "frame-required?" set-word-prop
+\ ##unary-float-function t "frame-required?" set-word-prop
+\ ##binary-float-function t "frame-required?" set-word-prop
\ No newline at end of file
! If both blocks are subroutine calls, don't bother
! computing anything.
2dup [ kill-block? ] both? [ 2drop ] [
- 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
- [ 2drop ] [ insert-simple-basic-block ] if-empty
+ 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make
+ [ 2drop ] [ insert-basic-block ] if-empty
] if ;
: visit-block ( bb -- )
: 3inputs ( -- vreg1 vreg2 vreg3 )
(3inputs) -3 inc-d ;
+: binary-op ( quot -- )
+ [ 2inputs ] dip call ds-push ; inline
+
+: unary-op ( quot -- )
+ [ ds-pop ] dip call ds-push ; inline
+
! adjust-d/adjust-r: these are called when other instructions which
! internally adjust the stack height are emitted, such as ##call and
! ##alien-invoke
: adjust-d ( n -- ) current-height get [ + ] change-d drop ;
: adjust-r ( n -- ) current-height get [ + ] change-r drop ;
-
ERROR: uninitialized-peek insn ;
-M: ##peek visit-insn
+: visit-peek ( ##peek -- )
dup loc>> [ n>> ] [ class get ] bi ?nth 0 =
- [ uninitialized-peek ] [ drop ] if ;
+ [ uninitialized-peek ] [ drop ] if ; inline
-M: ##replace visit-insn
+M: ##peek visit-insn visit-peek ;
+
+: visit-replace ( ##replace -- )
loc>> [ n>> ] [ class get ] bi
2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ;
+M: ##replace visit-insn visit-replace ;
+M: ##replace-imm visit-insn visit-replace ;
+
M: insn visit-insn drop ;
: prepare ( pair -- )
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences math combinators combinators.short-circuit
-classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+USING: kernel accessors sequences math combinators
+combinators.short-circuit vectors compiler.cfg
+compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.utilities ;
IN: compiler.cfg.useless-conditionals
: delete-conditional? ( bb -- ? )
{
[
- instructions>> last class {
- ##compare-branch
- ##compare-imm-branch
- ##compare-float-ordered-branch
- ##compare-float-unordered-branch
- } member-eq?
+ instructions>> last {
+ [ ##compare-branch? ]
+ [ ##compare-imm-branch? ]
+ [ ##compare-integer-branch? ]
+ [ ##compare-integer-imm-branch? ]
+ [ ##compare-float-ordered-branch? ]
+ [ ##compare-float-unordered-branch? ]
+ } 1||
]
[ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
} 1&& ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.short-circuit
cpu.architecture kernel layouts locals make math namespaces sequences
: skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
-:: insert-basic-block ( froms to bb -- )
- bb froms V{ } like >>predecessors drop
- bb to 1vector >>successors drop
- to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop
- froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ;
+:: update-predecessors ( from to bb -- )
+ ! Update 'to' predecessors for insertion of 'bb' between
+ ! 'from' and 'to'.
+ to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
+
+:: update-successors ( from to bb -- )
+ ! Update 'from' successors for insertion of 'bb' between
+ ! 'from' and 'to'.
+ from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
+
+:: insert-basic-block ( from to insns -- )
+ ! Insert basic block on the edge between 'from' and 'to'.
+ <basic-block> :> bb
+ insns V{ } like bb (>>instructions)
+ V{ from } bb (>>predecessors)
+ V{ to } bb (>>successors)
+ from to bb update-predecessors
+ from to bb update-successors ;
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
,
] with-variable ; inline
-: <simple-block> ( insns -- bb )
- <basic-block>
- swap >vector
- \ ##branch new-insn over push
- >>instructions ;
-
-: insert-simple-basic-block ( from to insns -- )
- [ 1vector ] 2dip <simple-block> insert-basic-block ;
-
: has-phis? ( bb -- ? )
instructions>> first ##phi? ;
: predecessor ( bb -- pred )
predecessors>> first ; inline
+: <copy> ( dst src -- insn )
+ any-rep \ ##copy new-insn ;
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.short-circuit fry
+kernel make math sequences
+cpu.architecture
+compiler.cfg.hats
+compiler.cfg.utilities
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.value-numbering.math
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.alien
+
+M: ##box-displaced-alien rewrite
+ dup displacement>> vreg>insn zero-insn?
+ [ [ dst>> ] [ base>> ] bi <copy> ] [ drop f ] if ;
+
+! ##box-displaced-alien f 1 2 3 <class>
+! ##unbox-c-ptr 4 1 <class>
+! =>
+! ##box-displaced-alien f 1 2 3 <class>
+! ##unbox-c-ptr 5 3 <class>
+! ##add 4 5 2
+
+: rewrite-unbox-alien ( insn box-insn -- insn )
+ [ dst>> ] [ src>> ] bi* <copy> ;
+
+: rewrite-unbox-displaced-alien ( insn box-insn -- insns )
+ [
+ [ dst>> ]
+ [ [ base>> ] [ base-class>> ] [ displacement>> ] tri ] bi*
+ [ ^^unbox-c-ptr ] dip
+ ##add
+ ] { } make ;
+
+: rewrite-unbox-any-c-ptr ( insn -- insn/f )
+ dup src>> vreg>insn
+ {
+ { [ dup ##box-alien? ] [ rewrite-unbox-alien ] }
+ { [ dup ##box-displaced-alien? ] [ rewrite-unbox-displaced-alien ] }
+ [ 2drop f ]
+ } cond ;
+
+M: ##unbox-any-c-ptr rewrite rewrite-unbox-any-c-ptr ;
+
+M: ##unbox-alien rewrite rewrite-unbox-any-c-ptr ;
+
+! Fuse ##add-imm into ##load-memory(-imm) and ##store-memory(-imm)
+! just update the offset in the instruction
+: fuse-base-offset? ( insn -- ? )
+ base>> vreg>insn ##add-imm? ;
+
+: fuse-base-offset ( insn -- insn' )
+ dup base>> vreg>insn
+ [ src1>> ] [ src2>> ] bi
+ [ >>base ] [ '[ _ + ] change-offset ] bi* ;
+
+! Fuse ##add-imm into ##load-memory and ##store-memory
+! just update the offset in the instruction
+: fuse-displacement-offset? ( insn -- ? )
+ { [ scale>> 0 = ] [ displacement>> vreg>insn ##add-imm? ] } 1&& ;
+
+: fuse-displacement-offset ( insn -- insn' )
+ dup displacement>> vreg>insn
+ [ src1>> ] [ src2>> ] bi
+ [ >>displacement ] [ '[ _ + ] change-offset ] bi* ;
+
+! Fuse ##add into ##load-memory-imm and ##store-memory-imm
+! construct a new ##load-memory or ##store-memory with the
+! ##add's operand as the displacement
+: fuse-displacement? ( insn -- ? )
+ base>> vreg>insn ##add? ;
+
+GENERIC: alien-insn-value ( insn -- value )
+
+M: ##load-memory-imm alien-insn-value dst>> ;
+M: ##store-memory-imm alien-insn-value src>> ;
+
+GENERIC: new-alien-insn ( value base displacement scale offset rep c-type insn -- insn )
+
+M: ##load-memory-imm new-alien-insn drop \ ##load-memory new-insn ;
+M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ;
+
+: fuse-displacement ( insn -- insn' )
+ {
+ [ alien-insn-value ]
+ [ base>> vreg>insn [ src1>> ] [ src2>> ] bi ]
+ [ drop 0 ]
+ [ offset>> ]
+ [ rep>> ]
+ [ c-type>> ]
+ [ ]
+ } cleave new-alien-insn ;
+
+! Fuse ##shl-imm into ##load-memory or ##store-memory
+: scale-insn? ( insn -- ? )
+ { [ ##shl-imm? ] [ src2>> { 1 2 3 } member? ] } 1&& ;
+
+: fuse-scale? ( insn -- ? )
+ { [ scale>> 0 = ] [ displacement>> vreg>insn scale-insn? ] } 1&& ;
+
+: fuse-scale ( insn -- insn' )
+ dup displacement>> vreg>insn
+ [ src1>> ] [ src2>> ] bi
+ [ >>displacement ] [ >>scale ] bi* ;
+
+: rewrite-memory-op ( insn -- insn/f )
+ {
+ { [ dup fuse-base-offset? ] [ fuse-base-offset ] }
+ { [ dup fuse-displacement-offset? ] [ fuse-displacement-offset ] }
+ { [ dup fuse-scale? ] [ fuse-scale ] }
+ [ drop f ]
+ } cond ;
+
+: rewrite-memory-imm-op ( insn -- insn/f )
+ {
+ { [ dup fuse-base-offset? ] [ fuse-base-offset ] }
+ { [ dup fuse-displacement? ] [ fuse-displacement ] }
+ [ drop f ]
+ } cond ;
+
+M: ##load-memory rewrite rewrite-memory-op ;
+M: ##load-memory-imm rewrite rewrite-memory-imm-op ;
+M: ##store-memory rewrite rewrite-memory-op ;
+M: ##store-memory-imm rewrite rewrite-memory-imm-op ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel math math.order namespaces
+sequences vectors combinators.short-circuit compiler.cfg
+compiler.cfg.comparisons compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.value-numbering.math
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.comparisons
+
+! Optimizations performed here:
+!
+! 1) Eliminating intermediate boolean values when the result of
+! a comparison is used by a compare-branch
+! 2) Folding comparisons where both inputs are literal
+! 3) Folding comparisons where both inputs are congruent
+! 4) Converting compare instructions into compare-imm instructions
+
+: fold-compare-imm? ( insn -- ? )
+ src1>> vreg>insn literal-insn? ;
+
+: evaluate-compare-imm ( insn -- ? )
+ [ src1>> vreg>literal ] [ src2>> ] [ cc>> ] tri
+ {
+ { cc= [ eq? ] }
+ { cc/= [ eq? not ] }
+ } case ;
+
+: fold-compare-integer-imm? ( insn -- ? )
+ src1>> vreg>insn ##load-integer? ;
+
+: evaluate-compare-integer-imm ( insn -- ? )
+ [ src1>> vreg>integer ] [ src2>> ] [ cc>> ] tri
+ [ <=> ] dip evaluate-cc ;
+
+: >compare< ( insn -- in1 in2 cc )
+ [ src1>> ] [ src2>> ] [ cc>> ] tri ; inline
+
+: >test-vector< ( insn -- src1 temp rep vcc )
+ {
+ [ src1>> ]
+ [ drop next-vreg ]
+ [ rep>> ]
+ [ vcc>> ]
+ } cleave ; inline
+
+UNION: scalar-compare-insn
+ ##compare
+ ##compare-imm
+ ##compare-integer
+ ##compare-integer-imm
+ ##compare-float-unordered
+ ##compare-float-ordered ;
+
+UNION: general-compare-insn scalar-compare-insn ##test-vector ;
+
+: rewrite-boolean-comparison? ( insn -- ? )
+ {
+ [ src1>> vreg>insn general-compare-insn? ]
+ [ src2>> not ]
+ [ cc>> cc/= eq? ]
+ } 1&& ; inline
+
+: rewrite-boolean-comparison ( insn -- insn )
+ src1>> vreg>insn {
+ { [ dup ##compare? ] [ >compare< \ ##compare-branch new-insn ] }
+ { [ dup ##compare-imm? ] [ >compare< \ ##compare-imm-branch new-insn ] }
+ { [ dup ##compare-integer? ] [ >compare< \ ##compare-integer-branch new-insn ] }
+ { [ dup ##compare-integer-imm? ] [ >compare< \ ##compare-integer-imm-branch new-insn ] }
+ { [ dup ##compare-float-unordered? ] [ >compare< \ ##compare-float-unordered-branch new-insn ] }
+ { [ dup ##compare-float-ordered? ] [ >compare< \ ##compare-float-ordered-branch new-insn ] }
+ { [ dup ##test-vector? ] [ >test-vector< \ ##test-vector-branch new-insn ] }
+ } cond ;
+
+: fold-branch ( ? -- insn )
+ 0 1 ?
+ basic-block get [ nth 1vector ] change-successors drop
+ \ ##branch new-insn ;
+
+: fold-compare-imm-branch ( insn -- insn/f )
+ evaluate-compare-imm fold-branch ;
+
+M: ##compare-imm-branch rewrite
+ {
+ { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
+ { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
+ [ drop f ]
+ } cond ;
+
+: fold-compare-integer-imm-branch ( insn -- insn/f )
+ evaluate-compare-integer-imm fold-branch ;
+
+M: ##compare-integer-imm-branch rewrite
+ {
+ { [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm-branch ] }
+ [ drop f ]
+ } cond ;
+
+: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
+ [ [ swap ] dip swap-cc ] when ; inline
+
+: (>compare-imm-branch) ( insn swap? -- src1 src2 cc )
+ [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] dip swap-compare ; inline
+
+: >compare-imm-branch ( insn swap? -- insn' )
+ (>compare-imm-branch)
+ [ vreg>literal ] dip
+ \ ##compare-imm-branch new-insn ; inline
+
+: >compare-integer-imm-branch ( insn swap? -- insn' )
+ (>compare-imm-branch)
+ [ vreg>integer ] dip
+ \ ##compare-integer-imm-branch new-insn ; inline
+
+: evaluate-self-compare ( insn -- ? )
+ cc>> { cc= cc<= cc>= } member-eq? ;
+
+: rewrite-self-compare-branch ( insn -- insn' )
+ evaluate-self-compare fold-branch ;
+
+M: ##compare-branch rewrite
+ {
+ { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm-branch ] }
+ { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm-branch ] }
+ { [ dup diagonal? ] [ rewrite-self-compare-branch ] }
+ [ drop f ]
+ } cond ;
+
+M: ##compare-integer-branch rewrite
+ {
+ { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm-branch ] }
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm-branch ] }
+ { [ dup diagonal? ] [ rewrite-self-compare-branch ] }
+ [ drop f ]
+ } cond ;
+
+: (>compare-imm) ( insn swap? -- dst src1 src2 cc )
+ [ { [ dst>> ] [ src1>> ] [ src2>> ] [ cc>> ] } cleave ] dip
+ swap-compare ; inline
+
+: >compare-imm ( insn swap? -- insn' )
+ (>compare-imm)
+ [ vreg>literal ] dip
+ next-vreg \ ##compare-imm new-insn ; inline
+
+: >compare-integer-imm ( insn swap? -- insn' )
+ (>compare-imm)
+ [ vreg>integer ] dip
+ next-vreg \ ##compare-integer-imm new-insn ; inline
+
+: >boolean-insn ( insn ? -- insn' )
+ [ dst>> ] dip \ ##load-reference new-insn ;
+
+: rewrite-self-compare ( insn -- insn' )
+ dup evaluate-self-compare >boolean-insn ;
+
+M: ##compare rewrite
+ {
+ { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm ] }
+ { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm ] }
+ { [ dup diagonal? ] [ rewrite-self-compare ] }
+ [ drop f ]
+ } cond ;
+
+M: ##compare-integer rewrite
+ {
+ { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm ] }
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm ] }
+ { [ dup diagonal? ] [ rewrite-self-compare ] }
+ [ drop f ]
+ } cond ;
+
+: rewrite-redundant-comparison? ( insn -- ? )
+ {
+ [ src1>> vreg>insn scalar-compare-insn? ]
+ [ src2>> not ]
+ [ cc>> { cc= cc/= } member? ]
+ } 1&& ; inline
+
+: rewrite-redundant-comparison ( insn -- insn' )
+ [ cc>> ] [ dst>> ] [ src1>> vreg>insn ] tri {
+ { [ dup ##compare? ] [ >compare< next-vreg \ ##compare new-insn ] }
+ { [ dup ##compare-imm? ] [ >compare< next-vreg \ ##compare-imm new-insn ] }
+ { [ dup ##compare-integer? ] [ >compare< next-vreg \ ##compare-integer new-insn ] }
+ { [ dup ##compare-integer-imm? ] [ >compare< next-vreg \ ##compare-integer-imm new-insn ] }
+ { [ dup ##compare-float-unordered? ] [ >compare< next-vreg \ ##compare-float-unordered new-insn ] }
+ { [ dup ##compare-float-ordered? ] [ >compare< next-vreg \ ##compare-float-ordered new-insn ] }
+ } cond
+ swap cc= eq? [ [ negate-cc ] change-cc ] when ;
+
+: fold-compare-imm ( insn -- insn' )
+ dup evaluate-compare-imm >boolean-insn ;
+
+M: ##compare-imm rewrite
+ {
+ { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
+ { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
+ [ drop f ]
+ } cond ;
+
+: fold-compare-integer-imm ( insn -- insn' )
+ dup evaluate-compare-integer-imm >boolean-insn ;
+
+M: ##compare-integer-imm rewrite
+ {
+ { [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm ] }
+ [ drop f ]
+ } cond ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes classes.algebra classes.parser
-classes.tuple combinators combinators.short-circuit fry
+USING: accessors arrays classes classes.algebra combinators fry
generic.parser kernel math namespaces quotations sequences slots
-splitting words compiler.cfg.instructions
+words make
+compiler.cfg.instructions
compiler.cfg.instructions.syntax
compiler.cfg.value-numbering.graph ;
+FROM: sequences.private => set-array-nth ;
IN: compiler.cfg.value-numbering.expressions
-TUPLE: constant-expr < expr value ;
-
-C: <constant> constant-expr
-
-M: constant-expr equal?
- over constant-expr? [
- [ value>> ] bi@
- 2dup [ float? ] both? [ fp-bitwise= ] [
- { [ [ class ] bi@ = ] [ = ] } 2&&
- ] if
- ] [ 2drop f ] if ;
-
-TUPLE: reference-expr < expr value ;
-
-C: <reference> reference-expr
-
-M: reference-expr equal?
- over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
-
-M: reference-expr hashcode*
- nip value>> identity-hashcode ;
-
-: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
+<<
GENERIC: >expr ( insn -- expr )
-M: insn >expr drop next-input-expr ;
-
-M: ##load-immediate >expr val>> <constant> ;
+: input-values ( slot-specs -- slot-specs' )
+ [ type>> { use literal } member-eq? ] filter ;
+
+: slot->expr-quot ( slot-spec -- quot )
+ [ name>> reader-word 1quotation ]
+ [
+ type>> {
+ { use [ [ vreg>vn ] ] }
+ { literal [ [ ] ] }
+ } case
+ ] bi append ;
+
+: narray-quot ( length -- quot )
+ [
+ [ , [ f <array> ] % ]
+ [
+ dup iota [
+ - 1 - , [ swap [ set-array-nth ] keep ] %
+ ] with each
+ ] bi
+ ] [ ] make ;
+
+: >expr-quot ( insn slot-specs -- quot )
+ [
+ [ literalize , \ swap , ]
+ [
+ [ [ slot->expr-quot ] map cleave>quot % ]
+ [ length 1 + narray-quot % ]
+ bi
+ ] bi*
+ ] [ ] make ;
+
+: define->expr-method ( insn slot-specs -- )
+ [ drop \ >expr create-method-in ] [ >expr-quot ] 2bi define ;
+
+insn-classes get
+[ pure-insn class<= ] filter
+[
+ dup "insn-slots" word-prop input-values
+ define->expr-method
+] each
-M: ##load-reference >expr obj>> <reference> ;
+>>
-M: ##load-constant >expr obj>> <constant> ;
+TUPLE: integer-expr value ;
-<<
+C: <integer-expr> integer-expr
-: input-values ( slot-specs -- slot-specs' )
- [ type>> { use literal constant } member-eq? ] filter ;
+TUPLE: reference-expr value ;
-: expr-class ( insn -- expr )
- name>> "##" ?head drop "-expr" append create-class-in ;
+C: <reference-expr> reference-expr
-: define-expr-class ( insn expr slot-specs -- )
- [ nip expr ] dip [ name>> ] map define-tuple-class ;
+M: reference-expr equal?
+ over reference-expr? [
+ [ value>> ] bi@
+ 2dup [ float? ] both?
+ [ fp-bitwise= ] [ eq? ] if
+ ] [ 2drop f ] if ;
-: >expr-quot ( expr slot-specs -- quot )
- [
- [ name>> reader-word 1quotation ]
- [
- type>> {
- { use [ [ vreg>vn ] ] }
- { literal [ [ ] ] }
- { constant [ [ constant>vn ] ] }
- } case
- ] bi append
- ] map cleave>quot swap suffix \ boa suffix ;
+M: reference-expr hashcode*
+ nip value>> dup float? [ double>bits ] [ identity-hashcode ] if ;
-: define->expr-method ( insn expr slot-specs -- )
- [ 2drop \ >expr create-method-in ] [ >expr-quot nip ] 3bi define ;
+M: insn >expr drop input-expr-counter counter neg ;
-: handle-pure-insn ( insn -- )
- [ ] [ expr-class ] [ "insn-slots" word-prop input-values ] tri
- [ define-expr-class ] [ define->expr-method ] 3bi ;
+M: ##copy >expr "Fail" throw ;
-insn-classes get [ pure-insn class<= ] filter [ handle-pure-insn ] each
+M: ##load-integer >expr val>> <integer-expr> ;
->>
+M: ##load-reference >expr obj>> <reference-expr> ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel layouts math math.bitwise
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.folding
+
+: binary-constant-fold? ( insn -- ? )
+ src1>> vreg>insn ##load-integer? ; inline
+
+GENERIC: binary-constant-fold* ( x y insn -- z )
+
+M: ##add-imm binary-constant-fold* drop + ;
+M: ##sub-imm binary-constant-fold* drop - ;
+M: ##mul-imm binary-constant-fold* drop * ;
+M: ##and-imm binary-constant-fold* drop bitand ;
+M: ##or-imm binary-constant-fold* drop bitor ;
+M: ##xor-imm binary-constant-fold* drop bitxor ;
+M: ##shr-imm binary-constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
+M: ##sar-imm binary-constant-fold* drop neg shift ;
+M: ##shl-imm binary-constant-fold* drop shift ;
+
+: binary-constant-fold ( insn -- insn' )
+ [ dst>> ]
+ [ [ src1>> vreg>integer ] [ src2>> ] [ ] tri binary-constant-fold* ] bi
+ \ ##load-integer new-insn ; inline
+
+: unary-constant-fold? ( insn -- ? )
+ src>> vreg>insn ##load-integer? ; inline
+
+GENERIC: unary-constant-fold* ( x insn -- y )
+
+M: ##not unary-constant-fold* drop bitnot ;
+M: ##neg unary-constant-fold* drop neg ;
+
+: unary-constant-fold ( insn -- insn' )
+ [ dst>> ] [ [ src>> vreg>integer ] [ ] bi unary-constant-fold* ] bi
+ \ ##load-integer new-insn ; inline
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math namespaces assocs biassocs ;
+USING: accessors kernel math namespaces assocs ;
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
-
-TUPLE: expr ;
-
-: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
-
-: vn>expr ( vn -- expr ) exprs>vns get value-at ;
-
-! Expressions whose values are inputs to the basic block.
-TUPLE: input-expr < expr n ;
-
SYMBOL: input-expr-counter
-: next-input-expr ( -- expr )
- input-expr-counter counter input-expr boa ;
-
+! assoc mapping vregs to value numbers
+! this is the identity on canonical representatives
SYMBOL: vregs>vns
-: vreg>vn ( vreg -- vn )
- vregs>vns get [ drop next-input-expr expr>vn ] cache ;
+! assoc mapping expressions to value numbers
+SYMBOL: exprs>vns
-: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
+! assoc mapping value numbers to instructions
+SYMBOL: vns>insns
-: set-vn ( vn vreg -- ) vregs>vns get set-at ;
+: vn>insn ( vn -- insn ) vns>insns get at ;
-: vreg>expr ( vreg -- expr ) vreg>vn vn>expr ; inline
+: vreg>vn ( vreg -- vn ) vregs>vns get [ ] cache ;
-: vn>constant ( vn -- constant ) vn>expr value>> ; inline
+: set-vn ( vn vreg -- ) vregs>vns get set-at ;
-: vreg>constant ( vreg -- constant ) vreg>vn vn>constant ; inline
+: vreg>insn ( vreg -- insn ) vreg>vn vn>insn ;
: init-value-graph ( -- )
- 0 vn-counter set
0 input-expr-counter set
- <bihash> exprs>vns set
- <bihash> vregs>vns set ;
+ H{ } clone vregs>vns set
+ H{ } clone exprs>vns set
+ H{ } clone vns>insns set ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.short-circuit
+cpu.architecture fry kernel layouts locals make math sequences
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.utilities
+compiler.cfg.value-numbering.folding
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.math
+
+: f-insn? ( insn -- ? )
+ { [ ##load-reference? ] [ obj>> not ] } 1&& ; inline
+
+: zero-insn? ( insn -- ? )
+ { [ ##load-integer? ] [ val>> 0 = ] } 1&& ; inline
+
+M: ##tagged>integer rewrite
+ [ dst>> ] [ src>> vreg>insn ] bi {
+ { [ dup ##load-integer? ] [ val>> tag-fixnum \ ##load-integer new-insn ] }
+ { [ dup f-insn? ] [ drop \ f type-number \ ##load-integer new-insn ] }
+ [ 2drop f ]
+ } cond ;
+
+: self-inverse ( insn -- insn' )
+ [ dst>> ] [ src>> vreg>insn src>> ] bi <copy> ;
+
+: identity ( insn -- insn' )
+ [ dst>> ] [ src1>> ] bi <copy> ;
+
+M: ##neg rewrite
+ {
+ { [ dup src>> vreg>insn ##neg? ] [ self-inverse ] }
+ { [ dup unary-constant-fold? ] [ unary-constant-fold ] }
+ [ drop f ]
+ } cond ;
+
+M: ##not rewrite
+ {
+ { [ dup src>> vreg>insn ##not? ] [ self-inverse ] }
+ { [ dup unary-constant-fold? ] [ unary-constant-fold ] }
+ [ drop f ]
+ } cond ;
+
+! Reassociation converts
+! ## *-imm 2 1 X
+! ## *-imm 3 2 Y
+! into
+! ## *-imm 3 1 (X $ Y)
+! If * is associative, then $ is the same operation as *.
+! In the case of shifts, $ is addition.
+: (reassociate) ( insn -- dst src1 src2' src2'' )
+ {
+ [ dst>> ]
+ [ src1>> vreg>insn [ src1>> ] [ src2>> ] bi ]
+ [ src2>> ]
+ } cleave ; inline
+
+: reassociate ( insn -- dst src1 src2 )
+ [ (reassociate) ] keep binary-constant-fold* ;
+
+: ?new-insn ( dst src1 src2 ? class -- insn/f )
+ '[ _ new-insn ] [ 3drop f ] if ; inline
+
+: reassociate-arithmetic ( insn new-insn -- insn/f )
+ [ reassociate dup immediate-arithmetic? ] dip ?new-insn ; inline
+
+: reassociate-bitwise ( insn new-insn -- insn/f )
+ [ reassociate dup immediate-bitwise? ] dip ?new-insn ; inline
+
+: reassociate-shift ( insn new-insn -- insn/f )
+ [ (reassociate) + dup immediate-shift-count? ] dip ?new-insn ; inline
+
+M: ##add-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##add-imm? ] [ \ ##add-imm reassociate-arithmetic ] }
+ [ drop f ]
+ } cond ;
+
+: sub-imm>add-imm ( insn -- insn' )
+ [ dst>> ] [ src1>> ] [ src2>> neg ] tri
+ dup immediate-arithmetic?
+ \ ##add-imm ?new-insn ;
+
+M: ##sub-imm rewrite sub-imm>add-imm ;
+
+! Convert ##mul-imm -1 => ##neg
+: mul-to-neg? ( insn -- ? )
+ src2>> -1 = ;
+
+: mul-to-neg ( insn -- insn' )
+ [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
+
+! Convert ##mul-imm 2^X => ##shl-imm X
+: mul-to-shl? ( insn -- ? )
+ src2>> power-of-2? ;
+
+: mul-to-shl ( insn -- insn' )
+ [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+
+! Distribution converts
+! ##+-imm 2 1 X
+! ##*-imm 3 2 Y
+! Into
+! ##*-imm 4 1 Y
+! ##+-imm 3 4 X*Y
+! Where * is mul or shl, + is add or sub
+! Have to make sure that X*Y fits in an immediate
+:: (distribute) ( outer inner imm temp add-op mul-op -- new-outers/f )
+ imm immediate-arithmetic? [
+ [
+ temp inner src1>> outer src2>> mul-op execute
+ outer dst>> temp imm add-op execute
+ ] { } make
+ ] [ f ] if ; inline
+
+: distribute-over-add? ( insn -- ? )
+ src1>> vreg>insn ##add-imm? ;
+
+: distribute-over-sub? ( insn -- ? )
+ src1>> vreg>insn ##sub-imm? ;
+
+: distribute ( insn add-op mul-op -- new-insns/f )
+ [
+ dup src1>> vreg>insn
+ 2dup src2>> swap [ src2>> ] keep binary-constant-fold*
+ next-vreg
+ ] 2dip (distribute) ; inline
+
+M: ##mul-imm rewrite
+ {
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup mul-to-neg? ] [ mul-to-neg ] }
+ { [ dup mul-to-shl? ] [ mul-to-shl ] }
+ { [ dup src1>> vreg>insn ##mul-imm? ] [ \ ##mul-imm reassociate-arithmetic ] }
+ { [ dup distribute-over-add? ] [ \ ##add-imm \ ##mul-imm distribute ] }
+ { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##mul-imm distribute ] }
+ [ drop f ]
+ } cond ;
+
+M: ##and-imm rewrite
+ {
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##and-imm? ] [ \ ##and-imm reassociate-bitwise ] }
+ { [ dup src2>> 0 = ] [ dst>> 0 \ ##load-integer new-insn ] }
+ { [ dup src2>> -1 = ] [ identity ] }
+ [ drop f ]
+ } cond ;
+
+M: ##or-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup src2>> -1 = ] [ dst>> -1 \ ##load-integer new-insn ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##or-imm? ] [ \ ##or-imm reassociate-bitwise ] }
+ [ drop f ]
+ } cond ;
+
+M: ##xor-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup src2>> -1 = ] [ [ dst>> ] [ src1>> ] bi \ ##not new-insn ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##xor-imm? ] [ \ ##xor-imm reassociate-bitwise ] }
+ [ drop f ]
+ } cond ;
+
+M: ##shl-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##shl-imm? ] [ \ ##shl-imm reassociate-shift ] }
+ { [ dup distribute-over-add? ] [ \ ##add-imm \ ##shl-imm distribute ] }
+ { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##shl-imm distribute ] }
+ [ drop f ]
+ } cond ;
+
+M: ##shr-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##shr-imm? ] [ \ ##shr-imm reassociate-shift ] }
+ [ drop f ]
+ } cond ;
+
+M: ##sar-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##sar-imm? ] [ \ ##sar-imm reassociate-shift ] }
+ [ drop f ]
+ } cond ;
+
+! Convert
+! ##load-integer 2 X
+! ##* 3 1 2
+! Where * is an operation with an -imm equivalent into
+! ##*-imm 3 1 X
+: insn>imm-insn ( insn op swap? -- new-insn )
+ swap [
+ [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
+ [ swap ] when vreg>integer
+ ] dip new-insn ; inline
+
+M: ##add rewrite
+ {
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##add-imm f insn>imm-insn ] }
+ { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##add-imm t insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+: diagonal? ( insn -- ? )
+ [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi = ; inline
+
+! ##sub 2 1 1 => ##load-integer 2 0
+: rewrite-subtraction-identity ( insn -- insn' )
+ dst>> 0 \ ##load-integer new-insn ;
+
+! ##load-integer 1 0
+! ##sub 3 1 2
+! =>
+! ##neg 3 2
+: sub-to-neg? ( ##sub -- ? )
+ src1>> vreg>insn zero-insn? ;
+
+: sub-to-neg ( ##sub -- insn )
+ [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
+
+M: ##sub rewrite
+ {
+ { [ dup sub-to-neg? ] [ sub-to-neg ] }
+ { [ dup diagonal? ] [ rewrite-subtraction-identity ] }
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##sub-imm f insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##mul rewrite
+ {
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##mul-imm f insn>imm-insn ] }
+ { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##mul-imm t insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##and rewrite
+ {
+ { [ dup diagonal? ] [ identity ] }
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##and-imm f insn>imm-insn ] }
+ { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##and-imm t insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##or rewrite
+ {
+ { [ dup diagonal? ] [ identity ] }
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##or-imm f insn>imm-insn ] }
+ { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##or-imm t insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##xor rewrite
+ {
+ { [ dup diagonal? ] [ dst>> 0 \ ##load-integer new-insn ] }
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##xor-imm f insn>imm-insn ] }
+ { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##xor-imm t insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##shl rewrite
+ {
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shl-imm f insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##shr rewrite
+ {
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shr-imm f insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##sar rewrite
+ {
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##sar-imm f insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors cpu.architecture kernel
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.misc
+
+M: ##replace rewrite
+ [ loc>> ] [ src>> vreg>insn ] bi
+ dup literal-insn? [
+ insn>literal dup immediate-store?
+ [ swap \ ##replace-imm new-insn ] [ 2drop f ] if
+ ] [ 2drop f ] if ;
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman, Daniel Ehrenberg.
+! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators combinators.short-circuit arrays
-fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise math.order classes
-vectors locals make alien.c-types io.binary grouping
-compiler.cfg
-compiler.cfg.registers
-compiler.cfg.comparisons
+USING: accessors combinators combinators.short-circuit kernel
+layouts math cpu.architecture
compiler.cfg.instructions
-compiler.cfg.value-numbering.expressions
-compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.simplify ;
+compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.rewrite
-: vreg-immediate-arithmetic? ( vreg -- ? )
- vreg>expr {
- [ constant-expr? ]
- [ value>> fixnum? ]
- [ value>> immediate-arithmetic? ]
- } 1&& ;
-
-: vreg-immediate-bitwise? ( vreg -- ? )
- vreg>expr {
- [ constant-expr? ]
- [ value>> fixnum? ]
- [ value>> immediate-bitwise? ]
- } 1&& ;
-
! Outputs f to mean no change
-
GENERIC: rewrite ( insn -- insn/f )
M: insn rewrite drop f ;
-: ##branch-t? ( insn -- ? )
- dup ##compare-imm-branch? [
- {
- [ cc>> cc/= eq? ]
- [ src2>> \ f type-number eq? ]
- } 1&&
- ] [ drop f ] if ; inline
-
-: general-compare-expr? ( insn -- ? )
- {
- [ compare-expr? ]
- [ compare-imm-expr? ]
- [ compare-float-unordered-expr? ]
- [ compare-float-ordered-expr? ]
- } 1|| ;
-
-: general-or-vector-compare-expr? ( insn -- ? )
- {
- [ compare-expr? ]
- [ compare-imm-expr? ]
- [ compare-float-unordered-expr? ]
- [ compare-float-ordered-expr? ]
- [ test-vector-expr? ]
- } 1|| ;
-
-: rewrite-boolean-comparison? ( insn -- ? )
- dup ##branch-t? [
- src1>> vreg>expr general-or-vector-compare-expr?
- ] [ drop f ] if ; inline
-
-: >compare-expr< ( expr -- in1 in2 cc )
- [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
-
-: >compare-imm-expr< ( expr -- in1 in2 cc )
- [ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline
-
-: >test-vector-expr< ( expr -- src1 temp rep vcc )
- {
- [ src1>> vn>vreg ]
- [ drop next-vreg ]
- [ rep>> ]
- [ vcc>> ]
- } cleave ; inline
-
-: rewrite-boolean-comparison ( expr -- insn )
- src1>> vreg>expr {
- { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
- { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
- { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
- { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] }
- { [ dup test-vector-expr? ] [ >test-vector-expr< \ ##test-vector-branch new-insn ] }
- } cond ;
-
-: tag-fixnum-expr? ( expr -- ? )
- dup shl-imm-expr?
- [ src2>> 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 = ]
- } 1&& ; inline
-
-: tagged>constant ( n -- n' )
- tag-bits get neg shift ; inline
-
-: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
- [ src1>> vreg>expr src1>> vn>vreg ]
- [ src2>> tagged>constant ]
- [ cc>> ]
- tri ; inline
-
-GENERIC: rewrite-tagged-comparison ( insn -- insn/f )
-
-M: ##compare-imm-branch rewrite-tagged-comparison
- (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
-
-M: ##compare-imm rewrite-tagged-comparison
- [ dst>> ] [ (rewrite-tagged-comparison) ] bi
- next-vreg \ ##compare-imm new-insn ;
-
-: rewrite-redundant-comparison? ( insn -- ? )
- {
- [ src1>> vreg>expr general-compare-expr? ]
- [ src2>> \ f type-number = ]
- [ cc>> { cc= cc/= } member-eq? ]
- } 1&& ; inline
-
-: rewrite-redundant-comparison ( insn -- insn' )
- [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
- { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
- { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
- { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
- { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
- } cond
- swap cc= eq? [ [ negate-cc ] change-cc ] when ;
-
-ERROR: bad-comparison ;
-
-: (fold-compare-imm) ( insn -- ? )
- [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi
- pick integer?
- [ [ <=> ] dip evaluate-cc ]
- [
- 2nip {
- { cc= [ f ] }
- { cc/= [ t ] }
- [ bad-comparison ]
- } case
- ] if ;
-
-: fold-compare-imm? ( insn -- ? )
- src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
-
-: fold-branch ( ? -- insn )
- 0 1 ?
- basic-block get [ nth 1vector ] change-successors drop
- \ ##branch new-insn ;
-
-: fold-compare-imm-branch ( insn -- insn/f )
- (fold-compare-imm) fold-branch ;
-
-M: ##compare-imm-branch rewrite
- {
- { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
- { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
- { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
- [ drop f ]
- } cond ;
-
-: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
- [ [ swap ] dip swap-cc ] when ; inline
-
-: >compare-imm-branch ( insn swap? -- insn' )
- [
- [ src1>> ]
- [ src2>> ]
- [ cc>> ]
- tri
- ] dip
- swap-compare
- [ vreg>constant ] dip
- \ ##compare-imm-branch new-insn ; inline
-
-: self-compare? ( insn -- ? )
- [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
-
-: (rewrite-self-compare) ( insn -- ? )
- cc>> { cc= cc<= cc>= } member-eq? ;
-
-: rewrite-self-compare-branch ( insn -- insn' )
- (rewrite-self-compare) fold-branch ;
-
-M: ##compare-branch rewrite
- {
- { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm-branch ] }
- { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm-branch ] }
- { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
- [ drop f ]
- } cond ;
-
-: >compare-imm ( insn swap? -- insn' )
- [
- {
- [ dst>> ]
- [ src1>> ]
- [ src2>> ]
- [ cc>> ]
- } cleave
- ] dip
- swap-compare
- [ vreg>constant ] dip
- next-vreg \ ##compare-imm new-insn ; inline
-
-: >boolean-insn ( insn ? -- insn' )
- [ dst>> ] dip
- {
- { t [ t \ ##load-constant new-insn ] }
- { f [ \ f type-number \ ##load-immediate new-insn ] }
- } case ;
-
-: rewrite-self-compare ( insn -- insn' )
- dup (rewrite-self-compare) >boolean-insn ;
-
-M: ##compare rewrite
- {
- { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm ] }
- { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm ] }
- { [ dup self-compare? ] [ rewrite-self-compare ] }
- [ drop f ]
- } cond ;
-
-: fold-compare-imm ( insn -- insn' )
- dup (fold-compare-imm) >boolean-insn ;
-
-M: ##compare-imm rewrite
- {
- { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
- { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
- { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
- [ drop f ]
- } cond ;
-
-: constant-fold? ( insn -- ? )
- src1>> vreg>expr constant-expr? ; inline
-
-GENERIC: constant-fold* ( x y insn -- z )
-
-M: ##add-imm constant-fold* drop + ;
-M: ##sub-imm constant-fold* drop - ;
-M: ##mul-imm constant-fold* drop * ;
-M: ##and-imm constant-fold* drop bitand ;
-M: ##or-imm constant-fold* drop bitor ;
-M: ##xor-imm constant-fold* drop bitxor ;
-M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
-M: ##sar-imm constant-fold* drop neg shift ;
-M: ##shl-imm constant-fold* drop shift ;
-
-: constant-fold ( insn -- insn' )
- [ dst>> ]
- [ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
- \ ##load-immediate new-insn ; inline
-
-: unary-constant-fold? ( insn -- ? )
- src>> vreg>expr constant-expr? ; inline
-
-GENERIC: unary-constant-fold* ( x insn -- y )
+! Utilities
+GENERIC: insn>integer ( insn -- n )
-M: ##not unary-constant-fold* drop bitnot ;
-M: ##neg unary-constant-fold* drop neg ;
+M: ##load-integer insn>integer val>> ;
-: unary-constant-fold ( insn -- insn' )
- [ dst>> ]
- [ [ src>> vreg>constant ] [ ] bi unary-constant-fold* ] bi
- \ ##load-immediate new-insn ; inline
+: vreg>integer ( vreg -- n ) vreg>insn insn>integer ; inline
-: maybe-unary-constant-fold ( insn -- insn' )
- dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ;
-
-M: ##neg rewrite
- maybe-unary-constant-fold ;
-
-M: ##not rewrite
- maybe-unary-constant-fold ;
-
-: arithmetic-op? ( op -- ? )
- {
- ##add
- ##add-imm
- ##sub
- ##sub-imm
- ##mul
- ##mul-imm
- } member-eq? ;
-
-: immediate? ( value op -- ? )
- arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ;
-
-: reassociate ( insn op -- insn )
- [
- {
- [ dst>> ]
- [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>constant ] bi ]
- [ src2>> ]
- [ ]
- } cleave constant-fold*
- ] dip
- 2dup immediate? [ new-insn ] [ 2drop 2drop f ] if ; inline
-
-M: ##add-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate ] }
- [ drop f ]
- } cond ;
-
-: sub-imm>add-imm ( insn -- insn' )
- [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup immediate-arithmetic?
- [ \ ##add-imm new-insn ] [ 3drop f ] if ;
-
-M: ##sub-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- [ sub-imm>add-imm ]
- } cond ;
-
-: mul-to-neg? ( insn -- ? )
- src2>> -1 = ;
-
-: mul-to-neg ( insn -- insn' )
- [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
-
-: mul-to-shl? ( insn -- ? )
- src2>> power-of-2? ;
+: vreg-immediate-arithmetic? ( vreg -- ? )
+ vreg>insn {
+ [ ##load-integer? ]
+ [ val>> immediate-arithmetic? ]
+ } 1&& ;
-: mul-to-shl ( insn -- insn' )
- [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+: vreg-immediate-bitwise? ( vreg -- ? )
+ vreg>insn {
+ [ ##load-integer? ]
+ [ val>> immediate-bitwise? ]
+ } 1&& ;
-M: ##mul-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- { [ dup mul-to-neg? ] [ mul-to-neg ] }
- { [ dup mul-to-shl? ] [ mul-to-shl ] }
- { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] }
- [ drop f ]
- } cond ;
+UNION: literal-insn ##load-integer ##load-reference ;
-M: ##and-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate ] }
- [ drop f ]
- } cond ;
+GENERIC: insn>literal ( insn -- n )
-M: ##or-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate ] }
- [ drop f ]
- } cond ;
+M: ##load-integer insn>literal val>> >fixnum ;
-M: ##xor-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate ] }
- [ drop f ]
- } cond ;
+M: ##load-reference insn>literal obj>> ;
-M: ##shl-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- [ drop f ]
- } cond ;
+: vreg>literal ( vreg -- n ) vreg>insn insn>literal ; inline
-M: ##shr-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
+: vreg-immediate-comparand? ( vreg -- ? )
+ vreg>insn {
+ { [ dup ##load-integer? ] [ val>> tag-fixnum immediate-comparand? ] }
+ { [ dup ##load-reference? ] [ obj>> immediate-comparand? ] }
[ drop f ]
} cond ;
-
-M: ##sar-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- [ drop f ]
- } cond ;
-
-: insn>imm-insn ( insn op swap? -- )
- swap [
- [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
- [ swap ] when vreg>constant
- ] dip new-insn ; inline
-
-: vreg-immediate? ( vreg op -- ? )
- arithmetic-op?
- [ vreg-immediate-arithmetic? ] [ vreg-immediate-bitwise? ] if ;
-
-: rewrite-arithmetic ( insn op -- ? )
- {
- { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
- [ 2drop f ]
- } cond ; inline
-
-: rewrite-arithmetic-commutative ( insn op -- ? )
- {
- { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
- { [ over src1>> over vreg-immediate? ] [ t insn>imm-insn ] }
- [ 2drop f ]
- } cond ; inline
-
-M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ;
-
-: subtraction-identity? ( insn -- ? )
- [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ;
-
-: rewrite-subtraction-identity ( insn -- insn' )
- dst>> 0 \ ##load-immediate new-insn ;
-
-: sub-to-neg? ( ##sub -- ? )
- src1>> vn>expr expr-zero? ;
-
-: sub-to-neg ( ##sub -- insn )
- [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
-
-M: ##sub rewrite
- {
- { [ dup sub-to-neg? ] [ sub-to-neg ] }
- { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
- [ \ ##sub-imm rewrite-arithmetic ]
- } cond ;
-
-M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ;
-
-M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ;
-
-M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ;
-
-M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ;
-
-M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ;
-
-M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
-
-M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
-
-! ##box-displaced-alien f 1 2 3 <class>
-! ##unbox-c-ptr 4 1 <class>
-! =>
-! ##box-displaced-alien f 1 2 3 <class>
-! ##unbox-c-ptr 5 3 <class>
-! ##add 4 5 2
-
-:: rewrite-unbox-displaced-alien ( insn expr -- insns )
- [
- next-vreg :> temp
- temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr
- insn dst>> temp expr displacement>> vn>vreg ##add
- ] { } make ;
-
-M: ##unbox-any-c-ptr rewrite
- dup src>> vreg>expr dup box-displaced-alien-expr?
- [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
-
-! More efficient addressing for alien intrinsics
-: rewrite-alien-addressing ( insn -- insn' )
- dup src>> vreg>expr dup add-imm-expr? [
- [ src1>> vn>vreg ] [ src2>> vn>constant ] bi
- [ >>src ] [ '[ _ + ] change-offset ] bi*
- ] [ 2drop f ] if ;
-
-M: ##alien-unsigned-1 rewrite rewrite-alien-addressing ;
-M: ##alien-unsigned-2 rewrite rewrite-alien-addressing ;
-M: ##alien-unsigned-4 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-1 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-2 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
-M: ##alien-float rewrite rewrite-alien-addressing ;
-M: ##alien-double rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
-M: ##set-alien-float rewrite rewrite-alien-addressing ;
-M: ##set-alien-double rewrite rewrite-alien-addressing ;
-
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
math.vectors.simd.intrinsics
compiler.cfg
compiler.cfg.registers
+compiler.cfg.utilities
compiler.cfg.comparisons
compiler.cfg.instructions
-compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.math
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.rewrite
-compiler.cfg.value-numbering.simplify ;
+compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering.simd
-M: ##alien-vector rewrite rewrite-alien-addressing ;
-M: ##set-alien-vector rewrite rewrite-alien-addressing ;
-
! Some lame constant folding for SIMD intrinsics. Eventually this
! should be redone completely.
-: rewrite-shuffle-vector-imm ( insn expr -- insn' )
+: useless-shuffle-vector-imm? ( insn -- ? )
+ [ shuffle>> ] [ rep>> rep-length iota ] bi sequence= ;
+
+: compose-shuffle-vector-imm ( outer inner -- insn' )
2dup [ rep>> ] bi@ eq? [
- [ [ dst>> ] [ src>> vn>vreg ] bi* ]
+ [ [ dst>> ] [ src>> ] bi* ]
[ [ shuffle>> ] bi@ nths ]
[ drop rep>> ]
2tri \ ##shuffle-vector-imm new-insn
: (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' )
2dup length swap length /i group nths concat ;
-: fold-shuffle-vector-imm ( insn expr -- insn' )
- [ [ dst>> ] [ shuffle>> ] bi ] dip value>>
- (fold-shuffle-vector-imm) \ ##load-constant new-insn ;
+: fold-shuffle-vector-imm ( outer inner -- insn' )
+ [ [ dst>> ] [ shuffle>> ] bi ] [ obj>> ] bi*
+ (fold-shuffle-vector-imm) \ ##load-reference new-insn ;
M: ##shuffle-vector-imm rewrite
- dup src>> vreg>expr {
- { [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] }
- { [ dup reference-expr? ] [ fold-shuffle-vector-imm ] }
- { [ dup constant-expr? ] [ fold-shuffle-vector-imm ] }
+ dup src>> vreg>insn {
+ { [ over useless-shuffle-vector-imm? ] [ drop [ dst>> ] [ src>> ] bi <copy> ] }
+ { [ dup ##shuffle-vector-imm? ] [ compose-shuffle-vector-imm ] }
+ { [ dup ##load-reference? ] [ fold-shuffle-vector-imm ] }
[ 2drop f ]
} cond ;
: (fold-scalar>vector) ( insn bytes -- insn' )
[ [ dst>> ] [ rep>> rep-length ] bi ] dip <repetition> concat
- \ ##load-constant new-insn ;
+ \ ##load-reference new-insn ;
-: fold-scalar>vector ( insn expr -- insn' )
- value>> over rep>> {
+: fold-scalar>vector ( outer inner -- insn' )
+ obj>> over rep>> {
{ float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
{ double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
[ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ]
} case ;
M: ##scalar>vector rewrite
- dup src>> vreg>expr dup constant-expr?
- [ fold-scalar>vector ] [ 2drop f ] if ;
+ dup src>> vreg>insn {
+ { [ dup ##load-reference? ] [ fold-scalar>vector ] }
+ { [ dup ##vector>scalar? ] [ [ dst>> ] [ src>> ] bi* <copy> ] }
+ [ 2drop f ]
+ } cond ;
M: ##xor-vector rewrite
- dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
+ dup diagonal?
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
-: vector-not? ( expr -- ? )
+: vector-not? ( insn -- ? )
{
- [ not-vector-expr? ]
+ [ ##not-vector? ]
[ {
- [ xor-vector-expr? ]
- [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
+ [ ##xor-vector? ]
+ [ [ src1>> ] [ src2>> ] bi [ vreg>insn ##fill-vector? ] either? ]
} 1&& ]
} 1|| ;
-GENERIC: vector-not-src ( expr -- vreg )
-M: not-vector-expr vector-not-src src>> vn>vreg ;
-M: xor-vector-expr vector-not-src
- dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
+GENERIC: vector-not-src ( insn -- vreg )
+
+M: ##not-vector vector-not-src
+ src>> ;
+
+M: ##xor-vector vector-not-src
+ dup src1>> vreg>insn ##fill-vector? [ src2>> ] [ src1>> ] if ;
M: ##and-vector rewrite
{
- { [ dup src1>> vreg>expr vector-not? ] [
+ { [ dup src1>> vreg>insn vector-not? ] [
{
[ dst>> ]
- [ src1>> vreg>expr vector-not-src ]
+ [ src1>> vreg>insn vector-not-src ]
[ src2>> ]
[ rep>> ]
} cleave \ ##andn-vector new-insn
] }
- { [ dup src2>> vreg>expr vector-not? ] [
+ { [ dup src2>> vreg>insn vector-not? ] [
{
[ dst>> ]
- [ src2>> vreg>expr vector-not-src ]
+ [ src2>> vreg>insn vector-not-src ]
[ src1>> ]
[ rep>> ]
} cleave \ ##andn-vector new-insn
} cond ;
M: ##andn-vector rewrite
- dup src1>> vreg>expr vector-not? [
+ dup src1>> vreg>insn vector-not? [
{
[ dst>> ]
- [ src1>> vreg>expr vector-not-src ]
+ [ src1>> vreg>insn vector-not-src ]
[ src2>> ]
[ rep>> ]
} cleave \ ##and-vector new-insn
] [ drop f ] if ;
-
-M: scalar>vector-expr simplify*
- src>> vn>expr {
- { [ dup vector>scalar-expr? ] [ src>> ] }
- [ drop f ]
- } cond ;
-
-M: shuffle-vector-imm-expr simplify*
- [ src>> ] [ shuffle>> ] [ rep>> rep-length iota ] tri
- sequence= [ drop f ] unless ;
-
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators classes math layouts
-sequences
-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 )
-
-M: copy-expr simplify* src>> ;
-
-: simplify-unbox-alien ( expr -- vn/expr/f )
- src>> vn>expr dup box-alien-expr? [ src>> ] [ drop f ] if ;
-
-M: unbox-alien-expr simplify* simplify-unbox-alien ;
-
-M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ;
-
-: expr-zero? ( expr -- ? ) T{ constant-expr f 0 } = ; inline
-
-: expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline
-
-: expr-neg-one? ( expr -- ? ) T{ constant-expr f -1 } = ; inline
-
-: >unary-expr< ( expr -- in ) src>> vn>expr ; inline
-
-M: neg-expr simplify*
- >unary-expr< {
- { [ dup neg-expr? ] [ src>> ] }
- [ drop f ]
- } cond ;
-
-M: not-expr simplify*
- >unary-expr< {
- { [ dup not-expr? ] [ src>> ] }
- [ drop f ]
- } cond ;
-
-: >binary-expr< ( expr -- in1 in2 )
- [ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline
-
-: simplify-add ( expr -- vn/expr/f )
- >binary-expr< {
- { [ over expr-zero? ] [ nip ] }
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: add-expr simplify* simplify-add ;
-M: add-imm-expr simplify* simplify-add ;
-
-: simplify-sub ( expr -- vn/expr/f )
- >binary-expr< {
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: sub-expr simplify* simplify-sub ;
-M: sub-imm-expr simplify* simplify-sub ;
-
-: simplify-mul ( expr -- vn/expr/f )
- >binary-expr< {
- { [ over expr-one? ] [ drop ] }
- { [ dup expr-one? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: mul-expr simplify* simplify-mul ;
-M: mul-imm-expr simplify* simplify-mul ;
-
-: simplify-and ( expr -- vn/expr/f )
- >binary-expr< {
- { [ 2dup eq? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: and-expr simplify* simplify-and ;
-M: and-imm-expr simplify* simplify-and ;
-
-: simplify-or ( expr -- vn/expr/f )
- >binary-expr< {
- { [ 2dup eq? ] [ drop ] }
- { [ over expr-zero? ] [ nip ] }
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: or-expr simplify* simplify-or ;
-M: or-imm-expr simplify* simplify-or ;
-
-: simplify-xor ( expr -- vn/expr/f )
- >binary-expr< {
- { [ over expr-zero? ] [ nip ] }
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: xor-expr simplify* simplify-xor ;
-M: xor-imm-expr simplify* simplify-xor ;
-
-: useless-shr? ( in1 in2 -- ? )
- over shl-imm-expr?
- [ [ src2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
-
-: simplify-shr ( expr -- vn/expr/f )
- >binary-expr< {
- { [ 2dup useless-shr? ] [ drop src1>> ] }
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: shr-expr simplify* simplify-shr ;
-M: shr-imm-expr simplify* simplify-shr ;
-
-: simplify-shl ( expr -- vn/expr/f )
- >binary-expr< {
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: shl-expr simplify* simplify-shl ;
-M: shl-imm-expr simplify* simplify-shl ;
-
-M: box-displaced-alien-expr simplify*
- [ base>> ] [ displacement>> ] bi {
- { [ dup vn>expr expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ;
-
-M: expr simplify* drop f ;
-
-: simplify ( expr -- vn )
- dup simplify* {
- { [ dup not ] [ drop expr>vn ] }
- { [ dup expr? ] [ expr>vn nip ] }
- { [ dup integer? ] [ nip ] }
- } cond ;
-
-: number-values ( insn -- )
- [ >expr simplify ] [ dst>> ] bi set-vn ;
+++ /dev/null
-Algebraic simplification of expressions
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit cpu.architecture fry
+kernel math
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.slots
+
+: simplify-slot-addressing? ( insn -- ? )
+ complex-addressing?
+ [ slot>> vreg>insn ##add-imm? ] [ drop f ] if ;
+
+: simplify-slot-addressing ( insn -- insn/f )
+ dup simplify-slot-addressing? [
+ dup slot>> vreg>insn
+ [ src1>> >>slot ]
+ [ src2>> over scale>> '[ _ _ shift - ] change-tag ]
+ bi
+ ] [ drop f ] if ;
+
+M: ##slot rewrite simplify-slot-addressing ;
+M: ##set-slot rewrite simplify-slot-addressing ;
+M: ##write-barrier rewrite simplify-slot-addressing ;
accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce
compiler.cfg.ssa.destruction compiler.cfg.loop-detection
compiler.cfg.representations compiler.cfg assocs vectors arrays
-layouts literals namespaces alien compiler.cfg.value-numbering.simd ;
+layouts literals namespaces alien compiler.cfg.value-numbering.simd
+system ;
+QUALIFIED-WITH: alien.c-types c
IN: compiler.cfg.value-numbering.tests
: trim-temps ( insns -- insns )
dup {
[ ##compare? ]
[ ##compare-imm? ]
+ [ ##compare-integer? ]
+ [ ##compare-integer-imm? ]
[ ##compare-float-unordered? ]
[ ##compare-float-ordered? ]
[ ##test-vector? ]
! Folding constants together
[
{
- T{ ##load-constant f 0 0.0 }
- T{ ##load-constant f 1 -0.0 }
- T{ ##replace f 0 D 0 }
- T{ ##replace f 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 -0.0 }
}
] [
{
- T{ ##load-constant f 0 0.0 }
- T{ ##load-constant f 1 -0.0 }
- T{ ##replace f 0 D 0 }
- T{ ##replace f 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 -0.0 }
} value-numbering-step
] unit-test
[
{
- T{ ##load-constant f 0 0.0 }
+ T{ ##load-reference f 0 0.0 }
T{ ##copy f 1 0 any-rep }
- T{ ##replace f 0 D 0 }
- T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-constant f 0 0.0 }
- T{ ##load-constant f 1 0.0 }
- T{ ##replace f 0 D 0 }
- T{ ##replace f 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 0.0 }
} value-numbering-step
] unit-test
[
{
- T{ ##load-constant f 0 t }
+ T{ ##load-reference f 0 t }
T{ ##copy f 1 0 any-rep }
- T{ ##replace f 0 D 0 }
- T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-constant f 0 t }
- T{ ##load-constant f 1 t }
- T{ ##replace f 0 D 0 }
- T{ ##replace f 1 D 1 }
+ T{ ##load-reference f 0 t }
+ T{ ##load-reference f 1 t }
} value-numbering-step
] unit-test
-! Compare propagation
+! ##load-reference/##replace fusion
+cpu x86? [
+ [
+ {
+ T{ ##load-integer f 0 10 }
+ T{ ##replace-imm f 10 D 0 }
+ }
+ ] [
+ {
+ T{ ##load-integer f 0 10 }
+ T{ ##replace f 0 D 0 }
+ } value-numbering-step
+ ] unit-test
+
+ [
+ {
+ T{ ##load-reference f 0 f }
+ T{ ##replace-imm f f D 0 }
+ }
+ ] [
+ {
+ T{ ##load-reference f 0 f }
+ T{ ##replace f 0 D 0 }
+ } value-numbering-step
+ ] unit-test
+] when
+
+cpu x86.32? [
+ [
+ {
+ T{ ##load-reference f 0 + }
+ T{ ##replace-imm f 10 D + }
+ }
+ ] [
+ {
+ T{ ##load-reference f 0 + }
+ T{ ##replace f 0 D 0 }
+ } value-numbering-step
+ ] unit-test
+] when
+
+cpu x86.64? [
+ [
+ {
+ T{ ##load-integer f 0 10,000,000,000 }
+ T{ ##replace f 0 D 0 }
+ }
+ ] [
+ {
+ T{ ##load-integer f 0 10,000,000,000 }
+ T{ ##replace f 0 D 0 }
+ } value-numbering-step
+ ] unit-test
+
+ ! Boundary case
+ [
+ {
+ T{ ##load-integer f 0 HEX: 7fffffff }
+ T{ ##replace f 0 D 0 }
+ }
+ ] [
+ {
+ T{ ##load-integer f 0 HEX: 7fffffff }
+ T{ ##replace f 0 D 0 }
+ } value-numbering-step
+ ] unit-test
+] when
+
+! Double compare elimination
+[
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare f 4 2 1 cc= }
+ T{ ##copy f 6 4 any-rep }
+ T{ ##replace f 6 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare f 4 2 1 cc= }
+ T{ ##compare-imm f 6 4 f cc/= }
+ T{ ##replace f 6 D 0 }
+ } value-numbering-step trim-temps
+] unit-test
+
+[
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-imm f 2 1 16 cc= }
+ T{ ##copy f 3 2 any-rep }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-imm f 2 1 16 cc= }
+ T{ ##compare-imm f 3 2 f cc/= }
+ T{ ##replace f 3 D 0 }
+ } value-numbering-step trim-temps
+] unit-test
+
[
{
- T{ ##load-reference f 1 + }
- T{ ##peek f 2 D 0 }
- T{ ##compare f 4 2 1 cc> }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare-integer f 4 2 1 cc> }
T{ ##copy f 6 4 any-rep }
T{ ##replace f 6 D 0 }
}
] [
{
- T{ ##load-reference f 1 + }
- T{ ##peek f 2 D 0 }
- T{ ##compare f 4 2 1 cc> }
- T{ ##compare-imm f 6 4 $[ \ f type-number ] cc/= }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare-integer f 4 2 1 cc> }
+ T{ ##compare-imm f 6 4 f cc/= }
T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##load-reference f 1 + }
- T{ ##peek f 2 D 0 }
- T{ ##compare f 4 2 1 cc<= }
- T{ ##compare f 6 2 1 cc/<= }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare-integer f 4 2 1 cc<= }
+ T{ ##compare-integer f 6 2 1 cc/<= }
T{ ##replace f 6 D 0 }
}
] [
{
- T{ ##load-reference f 1 + }
- T{ ##peek f 2 D 0 }
- T{ ##compare f 4 2 1 cc<= }
- T{ ##compare-imm f 6 4 $[ \ f type-number ] cc= }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare-integer f 4 2 1 cc<= }
+ T{ ##compare-imm f 6 4 f cc= }
T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
] unit-test
+[
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-imm f 2 1 100 cc<= }
+ T{ ##compare-integer-imm f 3 1 100 cc/<= }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-imm f 2 1 100 cc<= }
+ T{ ##compare-imm f 3 2 f cc= }
+ T{ ##replace f 3 D 0 }
+ } value-numbering-step trim-temps
+] unit-test
+
[
{
T{ ##peek f 8 D 0 }
T{ ##peek f 8 D 0 }
T{ ##peek f 9 D -1 }
T{ ##compare-float-unordered f 12 8 9 cc< }
- T{ ##compare-imm f 14 12 $[ \ f type-number ] cc= }
+ T{ ##compare-imm f 14 12 f cc= }
T{ ##replace f 14 D 0 }
} value-numbering-step trim-temps
] unit-test
{
T{ ##peek f 29 D -1 }
T{ ##peek f 30 D -2 }
- T{ ##compare f 33 29 30 cc<= }
- T{ ##compare-branch f 29 30 cc<= }
+ T{ ##compare f 33 29 30 cc= }
+ T{ ##compare-branch f 29 30 cc= }
+ }
+] [
+ {
+ T{ ##peek f 29 D -1 }
+ T{ ##peek f 30 D -2 }
+ T{ ##compare f 33 29 30 cc= }
+ T{ ##compare-imm-branch f 33 f cc/= }
+ } value-numbering-step trim-temps
+] unit-test
+
+[
+ {
+ T{ ##peek f 29 D -1 }
+ T{ ##peek f 30 D -2 }
+ T{ ##compare-integer f 33 29 30 cc<= }
+ T{ ##compare-integer-branch f 29 30 cc<= }
}
] [
{
T{ ##peek f 29 D -1 }
T{ ##peek f 30 D -2 }
- T{ ##compare f 33 29 30 cc<= }
- T{ ##compare-imm-branch f 33 $[ \ f type-number ] cc/= }
+ T{ ##compare-integer f 33 29 30 cc<= }
+ T{ ##compare-imm-branch f 33 f cc/= }
} value-numbering-step trim-temps
] unit-test
{
T{ ##peek f 1 D -1 }
T{ ##test-vector f 2 1 f float-4-rep vcc-any }
- T{ ##compare-imm-branch f 2 $[ \ f type-number ] cc/= }
+ T{ ##compare-imm-branch f 2 f cc/= }
} value-numbering-step trim-temps
] unit-test
-! Immediate operand conversion
+cpu x86.32? [
+ [
+ {
+ T{ ##peek f 1 D 0 }
+ T{ ##compare-imm f 2 1 + cc= }
+ T{ ##compare-imm-branch f 1 + cc= }
+ }
+ ] [
+ {
+ T{ ##peek f 1 D 0 }
+ T{ ##compare-imm f 2 1 + cc= }
+ T{ ##compare-imm-branch f 2 f cc/= }
+ } value-numbering-step trim-temps
+ ] unit-test
+] when
+
+! Immediate operand fusion
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add-imm f 2 0 -100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##sub f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 0 }
+ T{ ##load-integer f 1 0 }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##mul-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##mul f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##mul-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##mul f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
+ T{ ##load-integer f 1 -1 }
T{ ##neg f 2 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
+ T{ ##load-integer f 1 -1 }
T{ ##mul f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
+ T{ ##load-integer f 1 -1 }
T{ ##neg f 2 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
+ T{ ##load-integer f 1 -1 }
T{ ##mul f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 0 }
+ T{ ##load-integer f 1 0 }
T{ ##neg f 2 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 0 }
+ T{ ##load-integer f 1 0 }
T{ ##sub f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 0 }
+ T{ ##load-integer f 1 0 }
T{ ##neg f 2 0 }
T{ ##copy f 3 0 any-rep }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 0 }
+ T{ ##load-integer f 1 0 }
T{ ##sub f 2 1 0 }
T{ ##sub f 3 1 2 }
} value-numbering-step
] unit-test
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##neg f 1 0 }
+ T{ ##copy f 2 0 any-rep }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##neg f 1 0 }
+ T{ ##neg f 2 1 }
+ } value-numbering-step
+] unit-test
+
[
{
T{ ##peek f 0 D 0 }
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##and-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##and f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##and-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##and f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##or-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##or f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##or-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##or f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##xor-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##xor f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##xor-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##xor f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-imm f 2 0 100 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-imm f 2 0 100 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare f 2 0 1 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare f 2 0 1 cc= }
} value-numbering-step trim-temps
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 3.5 }
- T{ ##compare f 2 0 1 cc= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-imm f 2 0 100 cc<= }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 3.5 }
- T{ ##compare f 2 0 1 cc= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer f 2 0 1 cc<= }
} value-numbering-step trim-temps
] unit-test
+cpu x86.32? [
+ [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##compare-imm f 2 0 + cc= }
+ }
+ ] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##compare f 2 0 1 cc= }
+ } value-numbering-step trim-temps
+ ] unit-test
+
+ [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##compare-imm-branch f 0 + cc= }
+ }
+ ] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##compare-branch f 0 1 cc= }
+ } value-numbering-step trim-temps
+ ] unit-test
+] when
+
+cpu x86.32? [
+ [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 3.5 }
+ T{ ##compare f 2 0 1 cc= }
+ }
+ ] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 3.5 }
+ T{ ##compare f 2 0 1 cc= }
+ } value-numbering-step trim-temps
+ ] unit-test
+
+ [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 3.5 }
+ T{ ##compare-branch f 0 1 cc= }
+ }
+ ] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 3.5 }
+ T{ ##compare-branch f 0 1 cc= }
+ } value-numbering-step trim-temps
+ ] unit-test
+] unless
+
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-imm f 2 0 100 cc>= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-imm f 2 0 100 cc>= }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare f 2 1 0 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer f 2 1 0 cc<= }
} value-numbering-step trim-temps
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-imm-branch f 0 100 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-imm-branch f 0 100 cc<= }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-branch f 0 1 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-branch f 0 1 cc<= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 3.5 }
- T{ ##compare-branch f 0 1 cc= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-imm-branch f 0 100 cc>= }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 3.5 }
- T{ ##compare-branch f 0 1 cc= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-branch f 1 0 cc<= }
} value-numbering-step trim-temps
] unit-test
+! Compare folding
[
{
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-imm-branch f 0 100 cc>= }
+ T{ ##load-integer f 1 100 }
+ T{ ##load-integer f 2 200 }
+ T{ ##load-reference f 3 t }
}
] [
{
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-branch f 1 0 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##load-integer f 2 200 }
+ T{ ##compare-integer f 3 1 2 cc<= }
} value-numbering-step trim-temps
] unit-test
-! Reassociation
+[
+ {
+ T{ ##load-integer f 1 100 }
+ T{ ##load-integer f 2 200 }
+ T{ ##load-reference f 3 f }
+ }
+] [
+ {
+ T{ ##load-integer f 1 100 }
+ T{ ##load-integer f 2 200 }
+ T{ ##compare-integer f 3 1 2 cc= }
+ } value-numbering-step trim-temps
+] unit-test
+
+[
+ {
+ T{ ##load-integer f 1 100 }
+ T{ ##load-reference f 2 f }
+ }
+] [
+ {
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-imm f 2 1 123 cc= }
+ } value-numbering-step trim-temps
+] unit-test
+
+[
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##load-integer f 2 20 }
+ T{ ##load-reference f 3 f }
+ }
+] [
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##load-integer f 2 20 }
+ T{ ##compare-integer f 3 1 2 cc= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##load-reference f 3 t }
+ }
+] [
+ {
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##compare-integer f 3 1 2 cc/= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##load-reference f 3 t }
+ }
+] [
+ {
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##compare-integer f 3 1 2 cc< }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##load-integer f 2 20 }
+ T{ ##load-reference f 3 f }
+ }
+] [
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##load-integer f 2 20 }
+ T{ ##compare-integer f 3 2 1 cc< }
+ } value-numbering-step
+] unit-test
+
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##add-imm f 2 0 100 }
- T{ ##load-immediate f 3 50 }
- T{ ##add-imm f 4 0 150 }
+ T{ ##load-reference f 1 f }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##add f 2 0 1 }
- T{ ##load-immediate f 3 50 }
- T{ ##add f 4 2 3 }
+ T{ ##compare-integer f 1 0 0 cc< }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##add-imm f 2 0 100 }
- T{ ##load-immediate f 3 50 }
- T{ ##add-imm f 4 0 150 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##load-reference f 2 f }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##add f 2 1 0 }
- T{ ##load-immediate f 3 50 }
- T{ ##add f 4 3 2 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##compare-integer f 2 0 1 cc< }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##add-imm f 2 0 100 }
- T{ ##load-immediate f 3 50 }
- T{ ##add-imm f 4 0 50 }
+ T{ ##load-reference f 1 t }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##add f 2 0 1 }
- T{ ##load-immediate f 3 50 }
- T{ ##sub f 4 2 3 }
+ T{ ##compare-integer f 1 0 0 cc<= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##add-imm f 2 0 -100 }
- T{ ##load-immediate f 3 50 }
- T{ ##add-imm f 4 0 -150 }
+ T{ ##load-reference f 1 f }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##sub f 2 0 1 }
- T{ ##load-immediate f 3 50 }
- T{ ##sub f 4 2 3 }
+ T{ ##compare-integer f 1 0 0 cc> }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##mul-imm f 2 0 100 }
- T{ ##load-immediate f 3 50 }
- T{ ##mul-imm f 4 0 5000 }
+ T{ ##load-reference f 1 t }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##mul f 2 0 1 }
- T{ ##load-immediate f 3 50 }
- T{ ##mul f 4 2 3 }
+ T{ ##compare-integer f 1 0 0 cc>= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##mul-imm f 2 0 100 }
- T{ ##load-immediate f 3 50 }
- T{ ##mul-imm f 4 0 5000 }
+ T{ ##load-reference f 1 f }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##mul f 2 1 0 }
- T{ ##load-immediate f 3 50 }
- T{ ##mul f 4 3 2 }
+ T{ ##compare-integer f 1 0 0 cc/= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##and-imm f 2 0 100 }
- T{ ##load-immediate f 3 50 }
- T{ ##and-imm f 4 0 32 }
+ T{ ##load-reference f 1 t }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-integer f 1 0 0 cc= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##load-reference f 2 t }
+ }
+] [
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##compare-imm f 2 1 10 cc= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##load-reference f 2 f }
+ }
+] [
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##compare-imm f 2 1 20 cc= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##load-reference f 2 t }
+ }
+] [
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##compare-imm f 2 1 100 cc/= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##load-reference f 2 f }
+ }
+] [
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##compare-imm f 2 1 10 cc/= }
+ } value-numbering-step
+] unit-test
+
+cpu x86.32? [
+ [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##load-reference f 2 f }
+ }
+ ] [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##compare-imm f 2 1 + cc/= }
+ } value-numbering-step
+ ] unit-test
+
+ [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##load-reference f 2 t }
+ }
+ ] [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##compare-imm f 2 1 * cc/= }
+ } value-numbering-step
+ ] unit-test
+
+ [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##load-reference f 2 t }
+ }
+ ] [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##compare-imm f 2 1 + cc= }
+ } value-numbering-step
+ ] unit-test
+
+ [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##load-reference f 2 f }
+ }
+ ] [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##compare-imm f 2 1 * cc= }
+ } value-numbering-step
+ ] unit-test
+] when
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 t }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 f }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc/= }
+ } value-numbering-step
+] unit-test
+
+! Reassociation
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add-imm f 4 0 150 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add-imm f 4 0 150 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add f 2 1 0 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add f 4 3 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add-imm f 4 0 50 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##sub f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add-imm f 2 0 -100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add-imm f 4 0 -150 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##sub f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##sub f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##mul-imm f 4 0 5000 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##mul f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##mul f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##mul-imm f 4 0 5000 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##mul f 2 1 0 }
+ T{ ##load-integer f 3 50 }
+ T{ ##mul f 4 3 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##and-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##and-imm f 4 0 32 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##and f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##and f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##and-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##and-imm f 4 0 32 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##and f 2 1 0 }
+ T{ ##load-integer f 3 50 }
+ T{ ##and f 4 3 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##or-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##or-imm f 4 0 118 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##or f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##or f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##or-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##or-imm f 4 0 118 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##or f 2 1 0 }
+ T{ ##load-integer f 3 50 }
+ T{ ##or f 4 3 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##xor-imm f 4 0 86 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##xor f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##xor f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##xor-imm f 4 0 86 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##xor f 2 1 0 }
+ T{ ##load-integer f 3 50 }
+ T{ ##xor f 4 3 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 10 }
+ T{ ##shl-imm f 2 0 21 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 10 }
+ T{ ##shl-imm f 2 1 11 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 10 }
+ T{ ##shl-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 10 }
+ T{ ##shl-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sar-imm f 1 0 10 }
+ T{ ##sar-imm f 2 0 21 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sar-imm f 1 0 10 }
+ T{ ##sar-imm f 2 1 11 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sar-imm f 1 0 10 }
+ T{ ##sar-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sar-imm f 1 0 10 }
+ T{ ##sar-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##shr-imm f 2 0 21 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##shr-imm f 2 1 11 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##shr-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##shr-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##sar-imm f 2 1 11 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##sar-imm f 2 1 11 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+! Distributive law
+2 \ vreg-counter set-global
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 10 }
+ T{ ##shl-imm f 3 0 2 }
+ T{ ##add-imm f 2 3 40 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 10 }
+ T{ ##shl-imm f 2 1 2 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 10 }
+ T{ ##mul-imm f 4 0 3 }
+ T{ ##add-imm f 2 4 30 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 10 }
+ T{ ##mul-imm f 2 1 3 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 -10 }
+ T{ ##shl-imm f 5 0 2 }
+ T{ ##add-imm f 2 5 -40 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sub-imm f 1 0 10 }
+ T{ ##shl-imm f 2 1 2 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 -10 }
+ T{ ##mul-imm f 6 0 3 }
+ T{ ##add-imm f 2 6 -30 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sub-imm f 1 0 10 }
+ T{ ##mul-imm f 2 1 3 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+! Simplification
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add-imm f 3 0 0 }
+ T{ ##replace f 3 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##or-imm f 3 0 0 }
+ T{ ##replace f 3 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##xor-imm f 3 0 0 }
+ T{ ##replace f 3 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##and-imm f 1 0 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##and-imm f 1 0 -1 }
+ T{ ##replace f 1 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##and f 2 0 1 }
- T{ ##load-immediate f 3 50 }
- T{ ##and f 4 2 3 }
+ T{ ##and f 1 0 0 }
+ T{ ##replace f 1 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##and-imm f 2 0 100 }
- T{ ##load-immediate f 3 50 }
- T{ ##and-imm f 4 0 32 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##and f 2 1 0 }
- T{ ##load-immediate f 3 50 }
- T{ ##and f 4 3 2 }
+ T{ ##or-imm f 1 0 0 }
+ T{ ##replace f 1 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##or-imm f 2 0 100 }
- T{ ##load-immediate f 3 50 }
- T{ ##or-imm f 4 0 118 }
+ T{ ##load-integer f 1 -1 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##or f 2 0 1 }
- T{ ##load-immediate f 3 50 }
- T{ ##or f 4 2 3 }
+ T{ ##or-imm f 1 0 -1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##or-imm f 2 0 100 }
- T{ ##load-immediate f 3 50 }
- T{ ##or-imm f 4 0 118 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##or f 2 1 0 }
- T{ ##load-immediate f 3 50 }
- T{ ##or f 4 3 2 }
+ T{ ##or f 1 0 0 }
+ T{ ##replace f 1 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##xor-imm f 2 0 100 }
- T{ ##load-immediate f 3 50 }
- T{ ##xor-imm f 4 0 86 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##xor f 2 0 1 }
- T{ ##load-immediate f 3 50 }
- T{ ##xor f 4 2 3 }
+ T{ ##xor-imm f 1 0 0 }
+ T{ ##replace f 1 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##xor-imm f 2 0 100 }
- T{ ##load-immediate f 3 50 }
- T{ ##xor-imm f 4 0 86 }
+ T{ ##not f 1 0 }
+ T{ ##replace f 1 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##xor f 2 1 0 }
- T{ ##load-immediate f 3 50 }
- T{ ##xor f 4 3 2 }
+ T{ ##xor-imm f 1 0 -1 }
+ T{ ##replace f 1 D 0 }
} value-numbering-step
] unit-test
-! Simplification
[
{
T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##load-immediate f 2 0 }
- T{ ##copy f 3 0 any-rep }
- T{ ##replace f 3 D 0 }
+ T{ ##load-integer f 1 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##sub f 2 1 1 }
- T{ ##add f 3 0 2 }
- T{ ##replace f 3 D 0 }
+ T{ ##xor f 1 0 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##load-immediate f 2 0 }
- T{ ##copy f 3 0 any-rep }
- T{ ##replace f 3 D 0 }
+ T{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##sub f 2 1 1 }
- T{ ##sub f 3 0 2 }
- T{ ##replace f 3 D 0 }
+ T{ ##mul-imm f 2 0 1 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##load-immediate f 2 0 }
- T{ ##copy f 3 0 any-rep }
- T{ ##replace f 3 D 0 }
+ T{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##sub f 2 1 1 }
- T{ ##or f 3 0 2 }
- T{ ##replace f 3 D 0 }
+ T{ ##shl-imm f 2 0 0 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##load-immediate f 2 0 }
- T{ ##copy f 3 0 any-rep }
- T{ ##replace f 3 D 0 }
+ T{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##sub f 2 1 1 }
- T{ ##xor f 3 0 2 }
- T{ ##replace f 3 D 0 }
+ T{ ##shr-imm f 2 0 0 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
T{ ##copy f 2 0 any-rep }
T{ ##replace f 2 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##mul f 2 0 1 }
+ T{ ##sar-imm f 2 0 0 }
T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 3 }
- T{ ##load-immediate f 3 4 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 3 }
+ T{ ##load-integer f 3 4 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 3 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 3 }
T{ ##add f 3 1 2 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 3 }
- T{ ##load-immediate f 3 -2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 3 }
+ T{ ##load-integer f 3 -2 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 3 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 3 }
T{ ##sub f 3 1 2 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 3 }
- T{ ##load-immediate f 3 6 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 3 }
+ T{ ##load-integer f 3 6 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 3 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 3 }
T{ ##mul f 3 1 2 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 1 }
- T{ ##load-immediate f 3 0 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 1 }
+ T{ ##load-integer f 3 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 1 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 1 }
T{ ##and f 3 1 2 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 1 }
- T{ ##load-immediate f 3 3 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 1 }
+ T{ ##load-integer f 3 3 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 1 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 1 }
T{ ##or f 3 1 2 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 3 }
- T{ ##load-immediate f 3 1 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 3 }
+ T{ ##load-integer f 3 1 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 3 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 3 }
T{ ##xor f 3 1 2 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 3 8 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 3 8 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
+ T{ ##load-integer f 1 1 }
T{ ##shl-imm f 3 1 3 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
- T{ ##load-immediate f 3 HEX: ffffffffffff }
+ T{ ##load-integer f 1 -1 }
+ T{ ##load-integer f 3 HEX: ffffffffffff }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
+ T{ ##load-integer f 1 -1 }
T{ ##shr-imm f 3 1 16 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -8 }
- T{ ##load-immediate f 3 -4 }
+ T{ ##load-integer f 1 -8 }
+ T{ ##load-integer f 3 -4 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -8 }
+ T{ ##load-integer f 1 -8 }
T{ ##sar-imm f 3 1 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 65536 }
- T{ ##load-immediate f 2 140737488355328 }
+ T{ ##load-integer f 1 65536 }
+ T{ ##load-integer f 2 140737488355328 }
T{ ##add f 3 0 2 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 65536 }
+ T{ ##load-integer f 1 65536 }
T{ ##shl-imm f 2 1 31 }
T{ ##add f 3 0 2 }
} value-numbering-step
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 140737488355328 }
+ T{ ##load-integer f 2 140737488355328 }
T{ ##add f 3 0 2 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 140737488355328 }
+ T{ ##load-integer f 2 140737488355328 }
T{ ##add f 3 0 2 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 2147483647 }
+ T{ ##load-integer f 2 2147483647 }
T{ ##add-imm f 3 0 2147483647 }
T{ ##add-imm f 4 3 2147483647 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 2147483647 }
+ T{ ##load-integer f 2 2147483647 }
T{ ##add f 3 0 2 }
T{ ##add f 4 3 2 }
} value-numbering-step
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 -1 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 -1 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
+ T{ ##load-integer f 1 1 }
T{ ##neg f 2 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 -2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 -2 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
+ T{ ##load-integer f 1 1 }
T{ ##not f 2 1 }
} value-numbering-step
] unit-test
-! Displaced alien optimizations
-3 vreg-counter set-global
-
+! ##tagged>integer constant folding
[
{
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 16 }
- T{ ##box-displaced-alien f 1 2 0 c-ptr }
- T{ ##unbox-any-c-ptr f 4 0 }
- T{ ##add-imm f 3 4 16 }
+ T{ ##load-reference f 1 f }
+ T{ ##load-integer f 2 $[ \ f type-number ] }
+ T{ ##copy f 3 2 any-rep }
}
] [
{
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 16 }
- T{ ##box-displaced-alien f 1 2 0 c-ptr }
- T{ ##unbox-any-c-ptr f 3 1 }
+ T{ ##load-reference f 1 f }
+ T{ ##tagged>integer f 2 1 }
+ T{ ##and-imm f 3 2 15 }
} value-numbering-step
] unit-test
-4 vreg-counter set-global
-
[
{
- T{ ##box-alien f 0 1 }
- T{ ##load-immediate f 2 16 }
- T{ ##box-displaced-alien f 3 2 0 c-ptr }
- T{ ##copy f 5 1 any-rep }
- T{ ##add-imm f 4 5 16 }
+ T{ ##load-integer f 1 100 }
+ T{ ##load-integer f 2 $[ 100 tag-fixnum ] }
+ T{ ##load-integer f 3 $[ 100 tag-fixnum 1 + ] }
}
] [
{
- T{ ##box-alien f 0 1 }
- T{ ##load-immediate f 2 16 }
- T{ ##box-displaced-alien f 3 2 0 c-ptr }
- T{ ##unbox-any-c-ptr f 4 3 }
+ T{ ##load-integer f 1 100 }
+ T{ ##tagged>integer f 2 1 }
+ T{ ##add-imm f 3 2 1 }
} value-numbering-step
] unit-test
-3 vreg-counter set-global
-
+! Alien boxing and unboxing
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 0 }
- T{ ##copy f 3 0 any-rep }
- T{ ##replace f 3 D 1 }
+ T{ ##box-alien f 1 0 }
+ T{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 0 }
- T{ ##box-displaced-alien f 3 2 0 c-ptr }
- T{ ##replace f 3 D 1 }
- } value-numbering-step
-] unit-test
-
-! Branch folding
-[
- {
- T{ ##load-immediate f 1 10 }
- T{ ##load-immediate f 2 20 }
- T{ ##load-immediate f 3 $[ \ f type-number ] }
- }
-] [
- {
- T{ ##load-immediate f 1 10 }
- T{ ##load-immediate f 2 20 }
- T{ ##compare f 3 1 2 cc= }
- } value-numbering-step
-] unit-test
-
-[
- {
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##load-constant f 3 t }
- }
-] [
- {
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##compare f 3 1 2 cc/= }
- } value-numbering-step
-] unit-test
-
-[
- {
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##load-constant f 3 t }
- }
-] [
- {
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##compare f 3 1 2 cc< }
- } value-numbering-step
-] unit-test
-
-[
- {
- T{ ##load-immediate f 1 10 }
- T{ ##load-immediate f 2 20 }
- T{ ##load-immediate f 3 $[ \ f type-number ] }
- }
-] [
- {
- T{ ##load-immediate f 1 10 }
- T{ ##load-immediate f 2 20 }
- T{ ##compare f 3 2 1 cc< }
+ T{ ##box-alien f 1 0 }
+ T{ ##unbox-alien f 2 1 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 $[ \ f type-number ] }
+ T{ ##box-alien f 1 0 }
+ T{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc< }
+ T{ ##box-alien f 1 0 }
+ T{ ##unbox-any-c-ptr f 2 1 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 t }
+ T{ ##load-integer f 2 0 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc<= }
+ T{ ##load-integer f 2 0 }
+ T{ ##box-displaced-alien f 1 2 0 c-ptr }
+ T{ ##replace f 1 D 0 }
} value-numbering-step
] unit-test
-[
- {
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 $[ \ f type-number ] }
- }
-] [
- {
- T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc> }
- } value-numbering-step
-] unit-test
+3 vreg-counter set-global
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 t }
+ T{ ##load-integer f 2 16 }
+ T{ ##box-displaced-alien f 1 2 0 c-ptr }
+ T{ ##unbox-any-c-ptr f 4 0 }
+ T{ ##add-imm f 3 4 16 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc>= }
+ T{ ##load-integer f 2 16 }
+ T{ ##box-displaced-alien f 1 2 0 c-ptr }
+ T{ ##unbox-any-c-ptr f 3 1 }
} value-numbering-step
] unit-test
+4 vreg-counter set-global
+
[
{
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 $[ \ f type-number ] }
+ T{ ##box-alien f 0 1 }
+ T{ ##load-integer f 2 16 }
+ T{ ##box-displaced-alien f 3 2 0 c-ptr }
+ T{ ##copy f 5 1 any-rep }
+ T{ ##add-imm f 4 5 16 }
}
] [
{
- T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc/= }
+ T{ ##box-alien f 0 1 }
+ T{ ##load-integer f 2 16 }
+ T{ ##box-displaced-alien f 3 2 0 c-ptr }
+ T{ ##unbox-any-c-ptr f 4 3 }
} value-numbering-step
] unit-test
+3 vreg-counter set-global
+
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 t }
+ T{ ##load-integer f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 1 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc= }
+ T{ ##load-integer f 2 0 }
+ T{ ##box-displaced-alien f 3 2 0 c-ptr }
+ T{ ##replace f 3 D 1 }
} value-numbering-step
] unit-test
+! Various SIMD simplifications
[
{
T{ ##vector>scalar f 1 0 float-4-rep }
[
{
- T{ ##load-constant f 0 $[ 55 tag-fixnum ] }
- T{ ##load-constant f 1 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } }
- T{ ##copy f 2 1 any-rep }
+ T{ ##load-reference f 0 $[ 55 tag-fixnum ] }
+ T{ ##load-reference f 1 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } }
+ T{ ##load-reference f 2 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } }
}
] [
{
- T{ ##load-constant f 0 $[ 55 tag-fixnum ] }
+ T{ ##load-reference f 0 $[ 55 tag-fixnum ] }
T{ ##scalar>vector f 1 0 int-4-rep }
T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep }
} value-numbering-step
[
{
- T{ ##load-constant f 0 1.25 }
- T{ ##load-constant f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
- T{ ##copy f 2 1 any-rep }
+ T{ ##load-reference f 0 1.25 }
+ T{ ##load-reference f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
+ T{ ##load-reference f 2 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
}
] [
{
- T{ ##load-constant f 0 1.25 }
+ T{ ##load-reference f 0 1.25 }
T{ ##scalar>vector f 1 0 float-4-rep }
T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep }
} value-numbering-step
} value-numbering-step
] unit-test
-! branch folding
-
+! Branch folding
: test-branch-folding ( insns -- insns' n )
<basic-block>
[ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
[
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##branch }
}
1
] [
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##compare-branch f 1 2 cc= }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##branch }
}
0
] [
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##compare-branch f 1 2 cc/= }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##branch }
}
0
] [
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##compare-branch f 1 2 cc< }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##compare-integer-branch f 1 2 cc< }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##branch }
}
1
] [
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##compare-branch f 2 1 cc< }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##compare-integer-branch f 2 1 cc< }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc< }
+ T{ ##compare-integer-branch f 0 0 cc< }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc<= }
+ T{ ##compare-integer-branch f 0 0 cc<= }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc> }
+ T{ ##compare-integer-branch f 0 0 cc> }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc>= }
+ T{ ##compare-integer-branch f 0 0 cc>= }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc= }
+ T{ ##compare-integer-branch f 0 0 cc= }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc/= }
+ T{ ##compare-integer-branch f 0 0 cc/= }
} test-branch-folding
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 t }
+ T{ ##load-reference f 1 t }
T{ ##branch }
}
0
{
T{ ##peek f 0 D 0 }
T{ ##compare f 1 0 0 cc<= }
- T{ ##compare-imm-branch f 1 $[ \ f type-number ] cc/= }
+ T{ ##compare-imm-branch f 1 f cc/= }
} test-branch-folding
] unit-test
V{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc< }
+ T{ ##compare-integer-branch f 0 0 cc< }
} 1 test-bb
V{
- T{ ##load-immediate f 1 1 }
+ T{ ##load-integer f 1 1 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 2 2 }
T{ ##branch }
} 3 test-bb
V{
T{ ##peek f 1 D 1 }
- T{ ##compare-branch f 1 1 cc< }
+ T{ ##compare-integer-branch f 1 1 cc< }
} 1 test-bb
V{
} 2 test-bb
V{
- T{ ##phi f 3 V{ } }
+ T{ ##phi f 3 H{ { 1 1 } { 2 0 } } }
T{ ##branch }
} 3 test-bb
T{ ##return }
} 4 test-bb
-1 get 1 2array
-2 get 0 2array 2array 3 get instructions>> first (>>inputs)
-
test-diamond
[ ] [
T{ ##copy { dst 21 } { src 20 } { rep any-rep } }
T{ ##compare-imm-branch
{ src1 21 }
- { src2 $[ \ f type-number ] }
+ { src2 f }
{ cc cc/= }
}
} 1 test-bb
[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
+! Slot addressing optimization
+cpu x86? [
+ [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add-imm f 2 1 2 }
+ T{ ##slot f 3 0 1 $[ cell log2 ] $[ 7 2 cells - ] }
+ }
+ ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add-imm f 2 1 2 }
+ T{ ##slot f 3 0 2 $[ cell log2 ] 7 }
+ } value-numbering-step
+ ] unit-test
+] when
+
+! Alien addressing optimization
+
+! Base offset fusion on ##load/store-memory-imm
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##tagged>integer f 2 1 }
+ T{ ##add-imm f 3 2 10 }
+ T{ ##load-memory-imm f 4 2 10 int-rep c:uchar }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##tagged>integer f 2 1 }
+ T{ ##add-imm f 3 2 10 }
+ T{ ##load-memory-imm f 4 3 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 3 10 }
+ T{ ##store-memory-imm f 2 3 10 int-rep c:uchar }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 3 10 }
+ T{ ##store-memory-imm f 2 4 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+! Displacement fusion on ##load/store-memory-imm
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add f 4 2 3 }
+ T{ ##load-memory f 5 2 3 0 0 int-rep c:uchar }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add f 4 2 3 }
+ T{ ##load-memory-imm f 5 4 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add f 4 2 3 }
+ T{ ##store-memory f 5 2 3 0 0 int-rep c:uchar }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add f 4 2 3 }
+ T{ ##store-memory-imm f 5 4 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+! Base offset fusion on ##load/store-memory
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 2 31337 }
+ T{ ##load-memory f 5 2 3 0 31337 int-rep c:uchar }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 2 31337 }
+ T{ ##load-memory f 5 4 3 0 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+! Displacement offset fusion on ##load/store-memory
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 3 31337 }
+ T{ ##load-memory f 5 2 3 0 31338 int-rep c:uchar }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 3 31337 }
+ T{ ##load-memory f 5 2 4 0 1 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+! Displacement offset fusion should not occur on
+! ##load/store-memory with non-zero scale
+[ ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 3 10 }
+ T{ ##load-memory f 5 2 4 1 1 int-rep c:uchar }
+ } dup value-numbering-step assert=
+] unit-test
+
+! Scale fusion on ##load/store-memory
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##shl-imm f 4 3 2 }
+ T{ ##load-memory f 5 2 3 2 0 int-rep c:uchar }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##shl-imm f 4 3 2 }
+ T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+! Don't do scale fusion if there's already a scale
+[ ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##shl-imm f 4 3 2 }
+ T{ ##load-memory f 5 2 4 1 0 int-rep c:uchar }
+ } dup value-numbering-step assert=
+] unit-test
+
+! Don't do scale fusion if the scale factor is out of range
+[ ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##shl-imm f 4 3 4 }
+ T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
+ } dup value-numbering-step assert=
+] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs kernel accessors
-sorting sets sequences arrays
+USING: namespaces arrays assocs kernel accessors
+sorting sets sequences locals
cpu.architecture
sequences.deep
compiler.cfg
compiler.cfg.rpo
compiler.cfg.def-use
+compiler.cfg.utilities
compiler.cfg.instructions
+compiler.cfg.value-numbering.alien
+compiler.cfg.value-numbering.comparisons
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions
-compiler.cfg.value-numbering.simplify
-compiler.cfg.value-numbering.rewrite ;
+compiler.cfg.value-numbering.math
+compiler.cfg.value-numbering.rewrite
+compiler.cfg.value-numbering.slots
+compiler.cfg.value-numbering.misc
+compiler.cfg.value-numbering.expressions ;
IN: compiler.cfg.value-numbering
-! Local value numbering.
+GENERIC: process-instruction ( insn -- insn' )
-: >copy ( insn -- insn/##copy )
- dup defs-vreg dup vreg>vn vn>vreg
- 2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ;
+: redundant-instruction ( insn vn -- insn' )
+ [ dst>> ] dip [ swap set-vn ] [ <copy> ] 2bi ;
-GENERIC: process-instruction ( insn -- insn' )
+:: useful-instruction ( insn expr -- insn' )
+ insn dst>> :> vn
+ vn vn vregs>vns get set-at
+ vn expr exprs>vns get set-at
+ insn vn vns>insns get set-at
+ insn ;
+
+: check-redundancy ( insn -- insn' )
+ dup >expr dup exprs>vns get at
+ [ redundant-instruction ] [ useful-instruction ] ?if ;
M: insn process-instruction
dup rewrite
[ process-instruction ]
- [ dup defs-vreg [ dup number-values >copy ] when ] ?if ;
+ [ dup defs-vreg [ check-redundancy ] when ] ?if ;
+
+M: ##copy process-instruction
+ dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
M: array process-instruction
[ process-instruction ] map ;
init-value-graph
[ process-instruction ] map flatten ;
-: value-numbering ( cfg -- cfg' )
- [ value-numbering-step ] local-optimization
+: value-numbering ( cfg -- cfg )
+ dup [ value-numbering-step ] simple-optimization
cfg-changed predecessors-changed ;
-! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators.short-circuit
compiler.cfg.instructions compiler.cfg.rpo kernel namespaces
M: insn eliminate-write-barrier drop t ;
-: write-barriers-step ( bb -- )
+: write-barriers-step ( insns -- insns' )
H{ } clone fresh-allocations set
H{ } clone mutated-objects set
- instructions>> [ eliminate-write-barrier ] filter! drop ;
+ [ eliminate-write-barrier ] filter! ;
-: eliminate-write-barriers ( cfg -- cfg' )
- dup [ write-barriers-step ] each-basic-block ;
+: eliminate-write-barriers ( cfg -- cfg )
+ dup [ write-barriers-step ] simple-optimization ;
--- /dev/null
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.complex alien.c-types
+alien.libraries alien.private alien.strings arrays
+classes.struct combinators compiler.alien
+compiler.cfg.instructions compiler.codegen
+compiler.codegen.fixup compiler.errors compiler.utilities
+cpu.architecture fry kernel layouts libc locals make math
+math.order math.parser namespaces quotations sequences strings ;
+FROM: compiler.errors => no-such-symbol ;
+IN: compiler.codegen.alien
+
+! ##alien-invoke
+GENERIC: next-fastcall-param ( rep -- )
+
+: ?dummy-stack-params ( rep -- )
+ dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
+
+: ?dummy-int-params ( rep -- )
+ dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
+
+: ?dummy-fp-params ( rep -- )
+ drop dummy-fp-params? [ float-regs inc ] when ;
+
+M: int-rep next-fastcall-param
+ int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
+
+M: float-rep next-fastcall-param
+ float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
+
+M: double-rep next-fastcall-param
+ float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
+
+GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
+
+M: stack-params reg-class-full? 2drop t ;
+
+M: reg-class reg-class-full?
+ [ get ] swap '[ _ param-regs length ] bi >= ;
+
+: alloc-stack-param ( rep -- n reg-class rep )
+ stack-params get
+ [ rep-size cell align stack-params +@ ] dip
+ stack-params dup ;
+
+: alloc-fastcall-param ( rep -- n reg-class rep )
+ [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
+
+:: alloc-parameter ( parameter abi -- reg rep )
+ parameter c-type-rep dup reg-class-of abi reg-class-full?
+ [ alloc-stack-param ] [ alloc-fastcall-param ] if
+ [ abi param-reg ] dip ;
+
+SYMBOL: (stack-value)
+<< void* c-type clone \ (stack-value) define-primitive-type
+stack-params \ (stack-value) c-type (>>rep) >>
+
+: ((flatten-type)) ( type to-type -- seq )
+ [ stack-size cell align cell /i ] dip c-type <repetition> ; inline
+
+: (flatten-int-type) ( type -- seq )
+ void* ((flatten-type)) ;
+: (flatten-stack-type) ( type -- seq )
+ (stack-value) ((flatten-type)) ;
+
+GENERIC: flatten-value-type ( type -- types )
+
+M: object flatten-value-type 1array ;
+M: struct-c-type flatten-value-type (flatten-int-type) ;
+M: long-long-type flatten-value-type (flatten-int-type) ;
+M: c-type-name flatten-value-type c-type flatten-value-type ;
+
+: flatten-value-types ( params -- params )
+ #! Convert value type structs to consecutive void*s.
+ [
+ 0 [
+ c-type
+ [ parameter-align cell /i void* c-type <repetition> % ] keep
+ [ stack-size cell align + ] keep
+ flatten-value-type %
+ ] reduce drop
+ ] { } make ;
+
+: each-parameter ( parameters quot -- )
+ [ [ parameter-offsets nip ] keep ] dip 2each ; inline
+
+: reset-fastcall-counts ( -- )
+ { int-regs float-regs stack-params } [ 0 swap set ] each ;
+
+: with-param-regs ( quot -- )
+ #! In quot you can call alloc-parameter
+ [ reset-fastcall-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).
+ [ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
+ [ '[ _ alloc-parameter _ execute ] ]
+ bi* each-parameter ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+ [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
+
+: prepare-unbox-parameters ( parameters -- offsets types indices )
+ [ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
+
+: unbox-parameters ( offset node -- )
+ parameters>> swap
+ '[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
+ [ length neg %inc-d ]
+ bi ;
+
+: 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 registers 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 %push-stack ] if-void ;
+
+GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
+
+M: string dlsym-valid? dlsym ;
+
+M: array dlsym-valid? '[ _ dlsym ] any? ;
+
+: check-dlsym ( symbols dll -- )
+ dup dll-valid? [
+ dupd dlsym-valid?
+ [ drop ] [ compiling-word get no-such-symbol ] if
+ ] [
+ dll-path compiling-word get no-such-library drop
+ ] if ;
+
+: decorated-symbol ( params -- symbols )
+ [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
+ {
+ [ drop ]
+ [ "@" glue ]
+ [ "@" glue "_" prepend ]
+ [ "@" glue "@" prepend ]
+ } 2cleave
+ 4array ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+ [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
+ [ library>> load-library ]
+ bi 2dup check-dlsym ;
+
+M: ##alien-invoke generate-insn
+ params>>
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Call function
+ dup alien-invoke-dlsym %alien-invoke
+ ! Box return value
+ dup %cleanup
+ box-return* ;
+
+M: ##alien-assembly generate-insn
+ params>>
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Generate assembly
+ dup quot>> call( -- )
+ ! Box return value
+ box-return* ;
+
+! ##alien-indirect
+M: ##alien-indirect generate-insn
+ params>>
+ ! 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 %push-context-stack ] each-parameter ;
+
+: registers>objects ( node -- )
+ ! Generate code for boxing input parameters in a callback.
+ [
+ dup \ %save-param-reg move-parameters
+ %begin-callback
+ box-parameters
+ ] with-param-regs ;
+
+: 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
+ yield-hook get
+ '[ _ _ do-callback ]
+ >quotation ;
+
+M: ##alien-callback generate-insn
+ params>>
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;
--- /dev/null
+Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.order math.parser sequences
accessors kernel layouts assocs words summary arrays combinators
-classes.algebra alien alien.private alien.c-types alien.strings
-alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture classes
-classes.struct locals source-files.errors slots parser
-generic.parser strings quotations
-compiler.errors
-compiler.alien
+classes.algebra sets continuations.private fry cpu.architecture
+classes classes.struct locals slots parser generic.parser
+strings quotations hashtables
compiler.constants
compiler.cfg
+compiler.cfg.linearization
compiler.cfg.instructions
+compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.registers
compiler.cfg.builder
compiler.codegen.fixup
compiler.utilities ;
FROM: namespaces => set ;
-FROM: compiler.errors => no-such-symbol ;
IN: compiler.codegen
SYMBOL: insn-counts
GENERIC: generate-insn ( insn -- )
-! Mapping _label IDs to label instances
+! Control flow
SYMBOL: labels
-: generate ( mr -- code )
- dup label>> [
- H{ } clone labels set
+: lookup-label ( bb -- label )
+ labels get [ drop <label> ] cache ;
+
+: useless-branch? ( bb successor -- ? )
+ ! If our successor immediately follows us in linearization
+ ! order then we don't need to branch.
+ [ block-number ] bi@ 1 - = ; inline
+
+: emit-branch ( bb successor -- )
+ 2dup useless-branch?
+ [ 2drop ] [ nip lookup-label %jump-label ] if ;
+
+M: ##branch generate-insn
+ drop basic-block get dup successors>> first emit-branch ;
+
+GENERIC: generate-conditional-insn ( label insn -- )
+
+GENERIC: negate-insn-cc ( insn -- )
+
+M: conditional-branch-insn negate-insn-cc
+ [ negate-cc ] change-cc drop ;
+
+M: ##test-vector-branch negate-insn-cc
+ [ negate-vcc ] change-vcc drop ;
+
+M:: conditional-branch-insn generate-insn ( insn -- )
+ basic-block get :> bb
+ bb successors>> first2 :> ( first second )
+ bb second useless-branch?
+ [ bb second first ]
+ [ bb first second insn negate-insn-cc ] if
+ lookup-label insn generate-conditional-insn
+ emit-branch ;
+
+: %dispatch-label ( label -- )
+ cell 0 <repetition> %
+ rc-absolute-cell label-fixup ;
+
+M: ##dispatch generate-insn
+ [ src>> ] [ temp>> ] bi %dispatch
+ basic-block get successors>>
+ [ lookup-label %dispatch-label ] each ;
+
+: generate-block ( bb -- )
+ [ basic-block set ]
+ [ lookup-label resolve-label ]
+ [
instructions>> [
[ class insn-counts get inc-at ]
[ generate-insn ]
bi
] each
- ] with-fixup ;
+ ] tri ;
-: lookup-label ( id -- label )
- labels get [ drop <label> ] cache ;
+: generate ( cfg -- code )
+ dup label>> [
+ H{ } clone labels set
+ linearization-order
+ [ number-blocks ] [ [ generate-block ] each ] bi
+ ] with-fixup ;
! Special cases
M: ##no-tco generate-insn drop ;
-M: _dispatch-label generate-insn
- label>> lookup-label
- cell 0 <repetition> %
- rc-absolute-cell label-fixup ;
-
-M: _prologue generate-insn
- stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
+M: ##prologue generate-insn
+ drop
+ cfg get stack-frame>>
+ [ [ stack-frame set ] [ total-size>> %prologue ] bi ] when* ;
-M: _epilogue generate-insn
- stack-frame>> total-size>> %epilogue ;
-
-M: _spill-area-size generate-insn drop ;
+M: ##epilogue generate-insn
+ drop
+ cfg get stack-frame>> [ total-size>> %epilogue ] when* ;
! Some meta-programming to generate simple code generators, where
! the instruction is unpacked and then a %word is called
<<
: insn-slot-quot ( spec -- quot )
- name>> [ reader-word ] [ "label" = ] bi
- [ \ lookup-label [ ] 2sequence ] [ [ ] 1sequence ] if ;
+ name>> reader-word 1quotation ;
: codegen-method-body ( class word -- quot )
[
SYNTAX: CODEGEN:
scan-word [ \ generate-insn create-method-in ] keep scan-word
codegen-method-body define ;
+
>>
-CODEGEN: ##load-immediate %load-immediate
+CODEGEN: ##load-integer %load-immediate
+CODEGEN: ##load-tagged %load-immediate
CODEGEN: ##load-reference %load-reference
-CODEGEN: ##load-constant %load-reference
+CODEGEN: ##load-double %load-double
+CODEGEN: ##load-vector %load-vector
CODEGEN: ##peek %peek
CODEGEN: ##replace %replace
+CODEGEN: ##replace-imm %replace-imm
CODEGEN: ##inc-d %inc-d
CODEGEN: ##inc-r %inc-r
CODEGEN: ##call %call
CODEGEN: ##slot-imm %slot-imm
CODEGEN: ##set-slot %set-slot
CODEGEN: ##set-slot-imm %set-slot-imm
-CODEGEN: ##string-nth %string-nth
-CODEGEN: ##set-string-nth-fast %set-string-nth-fast
CODEGEN: ##add %add
CODEGEN: ##add-imm %add-imm
CODEGEN: ##sub %sub
CODEGEN: ##neg %neg
CODEGEN: ##log2 %log2
CODEGEN: ##copy %copy
+CODEGEN: ##tagged>integer %tagged>integer
CODEGEN: ##add-float %add-float
CODEGEN: ##sub-float %sub-float
CODEGEN: ##mul-float %mul-float
CODEGEN: ##box-displaced-alien %box-displaced-alien
CODEGEN: ##unbox-alien %unbox-alien
CODEGEN: ##unbox-any-c-ptr %unbox-any-c-ptr
-CODEGEN: ##alien-unsigned-1 %alien-unsigned-1
-CODEGEN: ##alien-unsigned-2 %alien-unsigned-2
-CODEGEN: ##alien-unsigned-4 %alien-unsigned-4
-CODEGEN: ##alien-signed-1 %alien-signed-1
-CODEGEN: ##alien-signed-2 %alien-signed-2
-CODEGEN: ##alien-signed-4 %alien-signed-4
-CODEGEN: ##alien-cell %alien-cell
-CODEGEN: ##alien-float %alien-float
-CODEGEN: ##alien-double %alien-double
-CODEGEN: ##alien-vector %alien-vector
-CODEGEN: ##set-alien-integer-1 %set-alien-integer-1
-CODEGEN: ##set-alien-integer-2 %set-alien-integer-2
-CODEGEN: ##set-alien-integer-4 %set-alien-integer-4
-CODEGEN: ##set-alien-cell %set-alien-cell
-CODEGEN: ##set-alien-float %set-alien-float
-CODEGEN: ##set-alien-double %set-alien-double
-CODEGEN: ##set-alien-vector %set-alien-vector
+CODEGEN: ##load-memory %load-memory
+CODEGEN: ##load-memory-imm %load-memory-imm
+CODEGEN: ##store-memory %store-memory
+CODEGEN: ##store-memory-imm %store-memory-imm
CODEGEN: ##allot %allot
CODEGEN: ##write-barrier %write-barrier
CODEGEN: ##write-barrier-imm %write-barrier-imm
CODEGEN: ##compare %compare
CODEGEN: ##compare-imm %compare-imm
+CODEGEN: ##compare-integer %compare
+CODEGEN: ##compare-integer-imm %compare-integer-imm
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
+CODEGEN: ##alien-global %alien-global
+CODEGEN: ##call-gc %call-gc
+CODEGEN: ##spill %spill
+CODEGEN: ##reload %reload
-CODEGEN: _fixnum-add %fixnum-add
-CODEGEN: _fixnum-sub %fixnum-sub
-CODEGEN: _fixnum-mul %fixnum-mul
-CODEGEN: _label resolve-label
-CODEGEN: _branch %jump-label
-CODEGEN: _compare-branch %compare-branch
-CODEGEN: _compare-imm-branch %compare-imm-branch
-CODEGEN: _compare-float-ordered-branch %compare-float-ordered-branch
-CODEGEN: _compare-float-unordered-branch %compare-float-unordered-branch
-CODEGEN: _test-vector-branch %test-vector-branch
-CODEGEN: _dispatch %dispatch
-CODEGEN: _spill %spill
-CODEGEN: _reload %reload
-
-! ##gc
-: wipe-locs ( locs temp -- )
- '[
- _
- [ 0 %load-immediate ]
- [ swap [ %replace ] with each ] bi
- ] unless-empty ;
-
-GENERIC# save-gc-root 1 ( gc-root operand temp -- )
-
-M:: spill-slot save-gc-root ( gc-root operand temp -- )
- temp int-rep operand %reload
- gc-root temp %save-gc-root ;
-
-M: object save-gc-root drop %save-gc-root ;
-
-: save-gc-roots ( gc-roots temp -- ) '[ _ save-gc-root ] assoc-each ;
-
-: save-data-regs ( data-regs -- ) [ first3 %spill ] each ;
-
-GENERIC# load-gc-root 1 ( gc-root operand temp -- )
-
-M:: spill-slot load-gc-root ( gc-root operand temp -- )
- gc-root temp %load-gc-root
- temp int-rep operand %spill ;
-
-M: object load-gc-root drop %load-gc-root ;
-
-: load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ;
-
-: load-data-regs ( data-regs -- ) [ first3 %reload ] each ;
-
-M: ##gc generate-insn
- "no-gc" define-label
- {
- [ [ "no-gc" get ] dip [ size>> ] [ temp1>> ] [ temp2>> ] tri %check-nursery ]
- [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
- [ data-values>> save-data-regs ]
- [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
- [ [ temp1>> ] [ temp2>> ] bi %save-context ]
- [ [ tagged-values>> length ] [ temp1>> ] bi %call-gc ]
- [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
- [ data-values>> load-data-regs ]
- } cleave
- "no-gc" resolve-label ;
-
-M: _loop-entry generate-insn drop %loop-entry ;
-
-M: ##alien-global generate-insn
- [ dst>> ] [ symbol>> ] [ library>> ] tri
- %alien-global ;
-
-! ##alien-invoke
-GENERIC: next-fastcall-param ( rep -- )
-
-: ?dummy-stack-params ( rep -- )
- dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
-
-: ?dummy-int-params ( rep -- )
- dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
-
-: ?dummy-fp-params ( rep -- )
- drop dummy-fp-params? [ float-regs inc ] when ;
-
-M: int-rep next-fastcall-param
- int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
-
-M: float-rep next-fastcall-param
- float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-
-M: double-rep next-fastcall-param
- float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-
-GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
-
-M: stack-params reg-class-full? 2drop t ;
-
-M: reg-class reg-class-full?
- [ get ] swap '[ _ param-regs length ] bi >= ;
-
-: alloc-stack-param ( rep -- n reg-class rep )
- stack-params get
- [ rep-size cell align stack-params +@ ] dip
- stack-params dup ;
-
-: alloc-fastcall-param ( rep -- n reg-class rep )
- [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
-
-:: alloc-parameter ( parameter abi -- reg rep )
- parameter c-type-rep dup reg-class-of abi reg-class-full?
- [ alloc-stack-param ] [ alloc-fastcall-param ] if
- [ abi param-reg ] dip ;
-
-SYMBOL: (stack-value)
-<< void* c-type clone \ (stack-value) define-primitive-type
-stack-params \ (stack-value) c-type (>>rep) >>
-
-: ((flatten-type)) ( type to-type -- seq )
- [ stack-size cell align cell /i ] dip c-type <repetition> ; inline
-
-: (flatten-int-type) ( type -- seq )
- void* ((flatten-type)) ;
-: (flatten-stack-type) ( type -- seq )
- (stack-value) ((flatten-type)) ;
-
-GENERIC: flatten-value-type ( type -- types )
-
-M: object flatten-value-type 1array ;
-M: struct-c-type flatten-value-type (flatten-int-type) ;
-M: long-long-type flatten-value-type (flatten-int-type) ;
-M: c-type-name flatten-value-type c-type flatten-value-type ;
-
-: flatten-value-types ( params -- params )
- #! Convert value type structs to consecutive void*s.
- [
- 0 [
- c-type
- [ parameter-align cell /i void* c-type <repetition> % ] keep
- [ stack-size cell align + ] keep
- flatten-value-type %
- ] reduce drop
- ] { } make ;
-
-: each-parameter ( parameters quot -- )
- [ [ parameter-offsets nip ] keep ] dip 2each ; inline
-
-: reset-fastcall-counts ( -- )
- { int-regs float-regs stack-params } [ 0 swap set ] each ;
-
-: with-param-regs ( quot -- )
- #! In quot you can call alloc-parameter
- [ reset-fastcall-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).
- [ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
- [ '[ _ alloc-parameter _ execute ] ]
- bi* each-parameter ; inline
-
-: reverse-each-parameter ( parameters quot -- )
- [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
-
-: prepare-unbox-parameters ( parameters -- offsets types indices )
- [ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
-
-: unbox-parameters ( offset node -- )
- parameters>> swap
- '[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
- [ length neg %inc-d ]
- bi ;
-
-: 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 registers 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 %push-stack ] if-void ;
-
-GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
-
-M: string dlsym-valid? dlsym ;
-
-M: array dlsym-valid? '[ _ dlsym ] any? ;
-
-: check-dlsym ( symbols dll -- )
- dup dll-valid? [
- dupd dlsym-valid?
- [ drop ] [ compiling-word get no-such-symbol ] if
- ] [
- dll-path compiling-word get no-such-library drop
- ] if ;
-
-: decorated-symbol ( params -- symbols )
- [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
- {
- [ drop ]
- [ "@" glue ]
- [ "@" glue "_" prepend ]
- [ "@" glue "@" prepend ]
- } 2cleave
- 4array ;
-
-: alien-invoke-dlsym ( params -- symbols dll )
- [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
- [ library>> load-library ]
- bi 2dup check-dlsym ;
-
-M: ##alien-invoke generate-insn
- params>>
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Call function
- dup alien-invoke-dlsym %alien-invoke
- ! Box return value
- dup %cleanup
- box-return* ;
-
-M: ##alien-assembly generate-insn
- params>>
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Generate assembly
- dup quot>> call( -- )
- ! Box return value
- box-return* ;
-
-! ##alien-indirect
-M: ##alien-indirect generate-insn
- params>>
- ! 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 %push-context-stack ] each-parameter ;
-
-: registers>objects ( node -- )
- ! Generate code for boxing input parameters in a callback.
- [
- dup \ %save-param-reg move-parameters
- %begin-callback
- box-parameters
- ] with-param-regs ;
-
-: 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 ;
+SYNTAX: CONDITIONAL:
+ scan-word [ \ generate-conditional-insn create-method-in ] keep scan-word
+ codegen-method-body define ;
-: wrap-callback-quot ( params -- quot )
- [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
- yield-hook get
- '[ _ _ do-callback ]
- >quotation ;
+>>
-M: ##alien-callback generate-insn
- params>>
- [ registers>objects ]
- [ wrap-callback-quot %alien-callback ]
- [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;
+CONDITIONAL: ##compare-branch %compare-branch
+CONDITIONAL: ##compare-imm-branch %compare-imm-branch
+CONDITIONAL: ##compare-integer-branch %compare-branch
+CONDITIONAL: ##compare-integer-imm-branch %compare-integer-imm-branch
+CONDITIONAL: ##compare-float-ordered-branch %compare-float-ordered-branch
+CONDITIONAL: ##compare-float-unordered-branch %compare-float-unordered-branch
+CONDITIONAL: ##test-vector-branch %test-vector-branch
+CONDITIONAL: ##check-nursery-branch %check-nursery-branch
+CONDITIONAL: ##fixnum-add %fixnum-add
+CONDITIONAL: ##fixnum-sub %fixnum-sub
+CONDITIONAL: ##fixnum-mul %fixnum-mul
accessors growable fry compiler.constants memoize ;
IN: compiler.codegen.fixup
+! Utilities
+: push-uint ( value vector -- )
+ [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+ swap set-alien-unsigned-4 ;
+
+: push-double ( value vector -- )
+ [ length ] [ B{ 0 0 0 0 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+ swap set-alien-double ;
+
! Owner
SYMBOL: compiling-word
! Relocation table
SYMBOL: relocation-table
-: push-4 ( value vector -- )
- [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
- swap set-alien-unsigned-4 ;
-
: add-relocation-entry ( type class offset -- )
- { 0 24 28 } bitfield relocation-table get push-4 ;
+ { 0 24 28 } bitfield relocation-table get push-uint ;
: rel-fixup ( class type -- )
swap compiled-offset add-relocation-entry ;
+! Binary literal table
+SYMBOL: binary-literal-table
+
+: add-binary-literal ( obj -- label )
+ <label> [ 2array binary-literal-table get push ] keep ;
+
! Caching common symbol names reduces image size a bit
MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
: rel-word-pic-tail ( word class -- )
[ add-literal ] dip rt-entry-point-pic-tail rel-fixup ;
-: rel-immediate ( literal class -- )
+: rel-literal ( literal class -- )
[ add-literal ] dip rt-literal rel-fixup ;
+: rel-binary-literal ( literal class -- )
+ [ add-binary-literal ] dip label-fixup ;
+
: rel-this ( class -- )
rt-this rel-fixup ;
rt-decks-offset rel-fixup ;
! And the rest
-: resolve-offset ( label-fixup -- offset )
+: compute-target ( label-fixup -- offset )
label>> offset>> [ "Unresolved label" throw ] unless* ;
-: resolve-absolute-label ( label-fixup -- )
- dup resolve-offset neg add-literal
- [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
+: compute-relative-label ( label-fixup -- label )
+ [ class>> ] [ offset>> ] [ compute-target ] tri 3array ;
-: resolve-relative-label ( label-fixup -- label )
- [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
+: compute-absolute-label ( label-fixup -- )
+ [ compute-target neg add-literal ]
+ [ [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ] bi ;
-: resolve-labels ( label-fixups -- labels' )
+: compute-labels ( label-fixups -- labels' )
[ class>> rc-absolute? ] partition
- [ [ resolve-absolute-label ] each ]
- [ [ resolve-relative-label ] map concat ]
+ [ [ compute-absolute-label ] each ]
+ [ [ compute-relative-label ] map concat ]
bi* ;
: init-fixup ( word -- )
V{ } clone parameter-table set
V{ } clone literal-table set
V{ } clone label-table set
- BV{ } clone relocation-table set ;
+ BV{ } clone relocation-table set
+ V{ } clone binary-literal-table set ;
+
+: alignment ( align -- n )
+ [ compiled-offset dup ] dip align swap - ;
+
+: (align-code) ( n -- )
+ 0 <repetition> % ;
+
+: align-code ( n -- )
+ alignment (align-code) ;
+
+GENERIC# emit-data 1 ( obj label -- )
+
+M: float emit-data
+ 8 align-code
+ resolve-label
+ building get push-double ;
+
+M: byte-array emit-data
+ 16 align-code
+ resolve-label
+ building get push-all ;
+
+: emit-binary-literals ( -- )
+ binary-literal-table get [ emit-data ] assoc-each ;
: with-fixup ( word quot -- code )
'[
init-fixup
@
- label-table [ resolve-labels ] change
+ emit-binary-literals
+ label-table [ compute-labels ] change
parameter-table get >array
literal-table get >array
relocation-table get >byte-array
compiler.cfg
compiler.cfg.builder
compiler.cfg.optimizer
-compiler.cfg.mr
+compiler.cfg.finalization
-compiler.codegen ;
+compiler.codegen
+compiler.codegen.alien ;
IN: compiler
SYMBOL: compiled
: backend ( tree word -- )
build-cfg [
- [ optimize-cfg build-mr ] with-cfg
- [ generate ] [ label>> ] bi compiled get set-at
+ [
+ optimize-cfg finalize-cfg
+ [ generate ] [ label>> ] bi compiled get set-at
+ ] with-cfg
] each ;
: compile-word ( word -- )
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system strings words quotations byte-arrays
-alien alien.syntax arrays literals sequences ;
+alien arrays literals sequences ;
IN: compiler.constants
! These constants must match vm/memory.h
: segment-end-offset ( -- n ) 2 bootstrap-cells ; inline
! Relocation classes
-C-ENUM: f
- rc-absolute-cell
- rc-absolute
- rc-relative
- rc-absolute-ppc-2/2
- rc-absolute-ppc-2
- rc-relative-ppc-2
- rc-relative-ppc-3
- rc-relative-arm-3
- rc-indirect-arm
- rc-indirect-arm-pc
- rc-absolute-2
- rc-absolute-1 ;
+CONSTANT: rc-absolute-cell 0
+CONSTANT: rc-absolute 1
+CONSTANT: rc-relative 2
+CONSTANT: rc-absolute-ppc-2/2 3
+CONSTANT: rc-absolute-ppc-2 4
+CONSTANT: rc-relative-ppc-2 5
+CONSTANT: rc-relative-ppc-3 6
+CONSTANT: rc-relative-arm-3 7
+CONSTANT: rc-indirect-arm 8
+CONSTANT: rc-indirect-arm-pc 9
+CONSTANT: rc-absolute-2 10
+CONSTANT: rc-absolute-1 11
! Relocation types
-C-ENUM: f
- rt-dlsym
- rt-entry-point
- rt-entry-point-pic
- rt-entry-point-pic-tail
- rt-here
- rt-this
- rt-literal
- rt-untagged
- rt-megamorphic-cache-hits
- rt-vm
- rt-cards-offset
- rt-decks-offset
- rt-exception-handler ;
+CONSTANT: rt-dlsym 0
+CONSTANT: rt-entry-point 1
+CONSTANT: rt-entry-point-pic 2
+CONSTANT: rt-entry-point-pic-tail 3
+CONSTANT: rt-here 4
+CONSTANT: rt-this 5
+CONSTANT: rt-literal 6
+CONSTANT: rt-untagged 7
+CONSTANT: rt-megamorphic-cache-hits 8
+CONSTANT: rt-vm 9
+CONSTANT: rt-cards-offset 10
+CONSTANT: rt-decks-offset 11
+CONSTANT: rt-exception-handler 12
: rc-absolute? ( n -- ? )
${
- rc-absolute-ppc-2/2
- rc-absolute-cell
- rc-absolute
- rc-absolute-2
- rc-absolute-1
+ $ rc-absolute-ppc-2/2
+ $ rc-absolute-cell
+ $ rc-absolute
+ $ rc-absolute-2
+ $ rc-absolute-1
} member? ;
USING: compiler.units compiler.test kernel kernel.private memory
math math.private tools.test math.floats.private math.order fry
-;
+specialized-arrays sequences ;
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
IN: compiler.tests.float
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
[ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test
[ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test
[ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test
+
+! Test vector ops
+[ 30.0 ] [
+ float-array{ 1 2 3 4 } float-array{ 1 2 3 4 }
+ [ { float-array float-array } declare [ * ] [ + ] 2map-reduce ] compile-call
+] unit-test
+
+[ 30.0 ] [
+ float-array{ 1 2 3 4 }
+ [ { float-array } declare dup [ * ] [ + ] 2map-reduce ] compile-call
+] unit-test
+
+[ 30.0 ] [
+ float-array{ 1 2 3 4 }
+ [ { float-array } declare [ dup * ] [ + ] map-reduce ] compile-call
+] unit-test
USING: accessors assocs compiler compiler.cfg
-compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr
-compiler.cfg.registers compiler.codegen compiler.units
-cpu.architecture hashtables kernel namespaces sequences
-tools.test vectors words layouts literals math arrays
-alien.syntax math.private ;
+compiler.cfg.debugger compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.linear-scan
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
+compiler.codegen compiler.units cpu.architecture hashtables
+kernel namespaces sequences tools.test vectors words layouts
+literals math arrays alien.c-types alien.syntax math.private ;
IN: compiler.tests.low-level-ir
: compile-cfg ( cfg -- word )
gensym
- [ build-mr generate ] dip
+ [ linear-scan build-stack-frame generate ] dip
[ associate >alist t t modify-code-heap ] keep ;
: compile-test-cfg ( -- word )
cfg new 0 get >>entry
dup cfg set
- dup fake-representations representations get >>reps
+ dup fake-representations
+ destruct-ssa
compile-cfg ;
: compile-test-bb ( insns -- result )
compile-test-cfg
execute( -- result ) ;
-! loading immediates
-[ f ] [
- V{
- T{ ##load-immediate f 0 $[ \ f type-number ] }
- } compile-test-bb
-] unit-test
-
+! loading constants
[ "hello" ] [
V{
T{ ##load-reference f 0 "hello" }
! one of the sources
[ t ] [
V{
- T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
+ T{ ##load-tagged f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
- T{ ##slot f 0 0 1 }
+ T{ ##slot f 0 0 1 0 0 }
} compile-test-bb
] unit-test
[ t ] [
V{
- T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
+ T{ ##load-tagged f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
- T{ ##set-slot f 0 0 1 }
+ T{ ##set-slot f 0 0 1 0 0 }
} compile-test-bb
dup first eq?
] unit-test
[ 4 ] [
V{
- T{ ##load-immediate f 0 4 }
+ T{ ##load-tagged f 0 4 }
T{ ##shl f 0 0 0 }
} compile-test-bb
] unit-test
[ 4 ] [
V{
- T{ ##load-immediate f 0 4 }
+ T{ ##load-tagged f 0 4 }
T{ ##shl-imm f 0 0 4 }
} compile-test-bb
] unit-test
V{
T{ ##load-reference f 1 B{ 31 67 52 } }
T{ ##unbox-any-c-ptr f 0 1 }
- T{ ##alien-unsigned-1 f 0 0 0 }
- T{ ##shl-imm f 0 0 4 }
- } compile-test-bb
-] unit-test
-
-[ CHAR: l ] [
- V{
- T{ ##load-reference f 0 "hello world" }
- T{ ##load-immediate f 1 3 }
- T{ ##string-nth f 0 0 1 2 }
+ T{ ##load-memory-imm f 0 0 0 int-rep uchar }
T{ ##shl-imm f 0 0 4 }
} compile-test-bb
] unit-test
[ 1 ] [
V{
- T{ ##load-immediate f 0 32 }
+ T{ ##load-tagged f 0 32 }
T{ ##add-imm f 0 0 -16 }
} compile-test-bb
] unit-test
2bi and maybe-or-never
] "outputs" set-word-prop
-\ both-fixnums? [
- [ class>> ] bi@ {
- { [ 2dup [ fixnum classes-intersect? not ] either? ] [ f <literal-info> ] }
- { [ 2dup [ fixnum class<= ] both? ] [ t <literal-info> ] }
- [ object-info ]
- } cond 2nip
-] "outputs" set-word-prop
-
{
{ >fixnum fixnum }
{ bignum>fixnum fixnum }
] "outputs" set-word-prop
] each
-\ string-nth [
- 2drop fixnum 0 23 2^ [a,b] <class/interval-info>
+\ string-nth-fast [
+ 2drop fixnum 0 255 [a,b] <class/interval-info>
] "outputs" set-word-prop
{
compiler.tree.debugger compiler.tree.checker slots.private words
hashtables classes assocs locals specialized-arrays system
sorting math.libm math.floats.private math.integers.private
-math.intervals quotations effects alien alien.data sets ;
+math.intervals quotations effects alien alien.data sets
+strings.private ;
FROM: math => float ;
SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: void*
[ t ] [ [ { 1 } diff ] { diff } inlined? ] unit-test
[ f ] [ [ { 1 } swap diff ] { diff } inlined? ] unit-test ! We could do this
+
+! Output range for string-nth now that string-nth is a library word and
+! not a primitive
+[ t ] [
+ ! Should actually be 0 23 2^ 1 - [a,b]
+ [ string-nth ] final-info first interval>> 0 23 2^ [a,b] =
+] unit-test
integer generalize-counter-interval
] unit-test
-[ T{ interval f { 0 t } { $[ most-positive-fixnum ] t } } ] [
+[ T{ interval f { 0 t } { $[ max-array-capacity ] t } } ] [
T{ interval f { 1 t } { 1 t } }
T{ interval f { 0 t } { 0 t } }
fixnum generalize-counter-interval
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors arrays fry math math.intervals
-layouts combinators namespaces locals
+USING: kernel classes.algebra sequences accessors arrays fry
+math math.intervals layouts combinators namespaces locals
stack-checker.inlining
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.simple
compiler.tree.propagation.branches
compiler.tree.propagation.constraints ;
+FROM: sequences.private => array-capacity ;
IN: compiler.tree.propagation.recursive
: check-fixed-point ( node infos1 infos2 -- )
[ label>> calls>> [ node>> node-input-infos ] map flip ]
[ latest-input-infos ] bi ;
+: counter-class ( interval class -- class' )
+ dup fixnum class<= [
+ swap array-capacity-interval interval-subset?
+ [ drop array-capacity ] when
+ ] [ nip ] if ;
+
:: generalize-counter-interval ( interval initial-interval class -- interval' )
+ interval class counter-class :> class
{
{ [ interval initial-interval interval-subset? ] [ initial-interval ] }
{ [ interval empty-interval eq? ] [ initial-interval ] }
! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel sequences words fry generic accessors
-classes.tuple classes classes.algebra definitions
-stack-checker.dependencies quotations classes.tuple.private math
-math.partial-dispatch math.private math.intervals sets.private
-math.floats.private math.integers.private layouts math.order
-vectors hashtables combinators effects generalizations assocs
-sets combinators.short-circuit sequences.private locals growable
+USING: alien.c-types kernel sequences words fry generic
+generic.single accessors classes.tuple classes classes.algebra
+definitions stack-checker.dependencies quotations
+classes.tuple.private math math.partial-dispatch math.private
+math.intervals sets.private math.floats.private
+math.integers.private layouts math.order vectors hashtables
+combinators effects generalizations assocs sets
+combinators.short-circuit sequences.private locals growable
stack-checker namespaces compiler.tree.propagation.info ;
FROM: math => float ;
FROM: sets => set ;
[ \ push def>> ] [ f ] if
] "custom-inlining" set-word-prop
+! Speeds up fasta benchmark
+\ >fixnum [
+ in-d>> first value-info class>> fixnum \ f class-or class<=
+ [ [ dup [ \ >fixnum no-method ] unless ] ] [ f ] if
+] "custom-inlining" set-word-prop
+
! We want to constant-fold calls to heap-size, and recompile those
! calls when a C type is redefined
\ heap-size [
[ depends-on-definition ] [ heap-size '[ _ ] ] bi
] [ drop f ] if
] 1 define-partial-eval
+
+! Eliminates a few redundant checks here and there
+\ both-fixnums? [
+ in-d>> first2 [ value-info class>> ] bi@ {
+ { [ 2dup [ fixnum classes-intersect? not ] either? ] [ [ 2drop f ] ] }
+ { [ 2dup [ fixnum class<= ] both? ] [ [ 2drop t ] ] }
+ { [ dup fixnum class<= ] [ [ drop fixnum? ] ] }
+ { [ over fixnum class<= ] [ [ nip fixnum? ] ] }
+ [ f ]
+ } cond 2nip
+] "custom-inlining" set-word-prop
opengl.gl literals ;
IN: core-graphics
-C-ENUM: CGImageAlphaInfo
-kCGImageAlphaNone
-kCGImageAlphaPremultipliedLast
-kCGImageAlphaPremultipliedFirst
-kCGImageAlphaLast
-kCGImageAlphaFirst
-kCGImageAlphaNoneSkipLast
-kCGImageAlphaNoneSkipFirst ;
+TYPEDEF: int CGImageAlphaInfo
+CONSTANT: kCGImageAlphaNone 0
+CONSTANT: kCGImageAlphaPremultipliedLast 1
+CONSTANT: kCGImageAlphaPremultipliedFirst 2
+CONSTANT: kCGImageAlphaLast 3
+CONSTANT: kCGImageAlphaFirst 4
+CONSTANT: kCGImageAlphaNoneSkipLast 5
+CONSTANT: kCGImageAlphaNoneSkipFirst 6
CONSTANT: kCGBitmapAlphaInfoMask HEX: 1f
CONSTANT: kCGBitmapFloatComponents 256
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs generic kernel kernel.private
-math memory namespaces make sequences layouts system hashtables
-classes alien byte-arrays combinators words sets fry ;
+math math.order memory namespaces make sequences layouts system
+hashtables classes alien byte-arrays combinators words sets fry
+;
IN: cpu.architecture
! Representations -- these are like low-level types
int-vector-rep
float-vector-rep ;
+CONSTANT: vector-reps
+ {
+ char-16-rep
+ uchar-16-rep
+ short-8-rep
+ ushort-8-rep
+ int-4-rep
+ uint-4-rep
+ longlong-2-rep
+ ulonglong-2-rep
+ float-4-rep
+ double-2-rep
+ }
+
UNION: representation
any-rep
tagged-rep
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
-HOOK: %load-immediate cpu ( reg obj -- )
+! Specifies if %slot, %set-slot and %write-barrier accept the
+! 'scale' and 'tag' parameters, and if %load-memory and
+! %store-memory work
+HOOK: complex-addressing? cpu ( -- ? )
+
+HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
+HOOK: %load-double cpu ( reg val -- )
+HOOK: %load-vector cpu ( reg val rep -- )
HOOK: %peek cpu ( vreg loc -- )
HOOK: %replace cpu ( vreg loc -- )
+HOOK: %replace-imm cpu ( src loc -- )
HOOK: %inc-d cpu ( n -- )
HOOK: %inc-r cpu ( n -- )
HOOK: %dispatch cpu ( src temp -- )
-HOOK: %slot cpu ( dst obj slot -- )
+HOOK: %slot cpu ( dst obj slot scale tag -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- )
-HOOK: %set-slot cpu ( src obj slot -- )
+HOOK: %set-slot cpu ( src obj slot scale tag -- )
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
-HOOK: %string-nth cpu ( dst obj index temp -- )
-HOOK: %set-string-nth-fast cpu ( ch obj index temp -- )
-
HOOK: %add cpu ( dst src1 src2 -- )
HOOK: %add-imm cpu ( dst src1 src2 -- )
HOOK: %sub cpu ( dst src1 src2 -- )
HOOK: %copy cpu ( dst src rep -- )
-HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
-HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
-HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
+: %tagged>integer ( dst src -- ) int-rep %copy ;
+
+HOOK: %fixnum-add cpu ( label dst src1 src2 cc -- )
+HOOK: %fixnum-sub cpu ( label dst src1 src2 cc -- )
+HOOK: %fixnum-mul cpu ( label dst src1 src2 cc -- )
HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %box-alien cpu ( dst src temp -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
-HOOK: %alien-unsigned-1 cpu ( dst src offset -- )
-HOOK: %alien-unsigned-2 cpu ( dst src offset -- )
-HOOK: %alien-unsigned-4 cpu ( dst src offset -- )
-HOOK: %alien-signed-1 cpu ( dst src offset -- )
-HOOK: %alien-signed-2 cpu ( dst src offset -- )
-HOOK: %alien-signed-4 cpu ( dst src offset -- )
-HOOK: %alien-cell cpu ( dst src offset -- )
-HOOK: %alien-float cpu ( dst src offset -- )
-HOOK: %alien-double cpu ( dst src offset -- )
-HOOK: %alien-vector cpu ( dst src offset rep -- )
-
-HOOK: %set-alien-integer-1 cpu ( ptr offset value -- )
-HOOK: %set-alien-integer-2 cpu ( ptr offset value -- )
-HOOK: %set-alien-integer-4 cpu ( ptr offset value -- )
-HOOK: %set-alien-cell cpu ( ptr offset value -- )
-HOOK: %set-alien-float cpu ( ptr offset value -- )
-HOOK: %set-alien-double cpu ( ptr offset value -- )
-HOOK: %set-alien-vector cpu ( ptr offset value rep -- )
+HOOK: %load-memory cpu ( dst base displacement scale offset rep c-type -- )
+HOOK: %load-memory-imm cpu ( dst base offset rep c-type -- )
+HOOK: %store-memory cpu ( value base displacement scale offset rep c-type -- )
+HOOK: %store-memory-imm cpu ( value base offset rep c-type -- )
HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %vm-field cpu ( dst offset -- )
: %context ( dst -- ) 0 %vm-field ;
HOOK: %allot cpu ( dst size class temp -- )
-HOOK: %write-barrier cpu ( src slot temp1 temp2 -- )
-HOOK: %write-barrier-imm cpu ( src slot temp1 temp2 -- )
+HOOK: %write-barrier cpu ( src slot scale tag temp1 temp2 -- )
+HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- )
! GC checks
-HOOK: %check-nursery cpu ( label size temp1 temp2 -- )
-HOOK: %save-gc-root cpu ( gc-root register -- )
-HOOK: %load-gc-root cpu ( gc-root register -- )
-HOOK: %call-gc cpu ( gc-root-count temp1 -- )
+HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
+HOOK: %call-gc cpu ( gc-roots -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
HOOK: %compare cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- )
+HOOK: %compare-integer-imm cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-float-ordered cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-float-unordered cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-integer-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- )
M: stack-params param-reg 2drop ;
-! Is this integer small enough to be an immediate operand for
-! %add-imm, %sub-imm, and %mul-imm?
+! Does this architecture support %load-double, %load-vector and
+! objects in %compare-imm?
+HOOK: fused-unboxing? cpu ( -- ? )
+
+M: object fused-unboxing? f ;
+
+! Can this value be an immediate operand for %add-imm, %sub-imm,
+! or %mul-imm?
HOOK: immediate-arithmetic? cpu ( n -- ? )
-! Is this integer small enough to be an immediate operand for
-! %and-imm, %or-imm, and %xor-imm?
+! Can this value be an immediate operand for %and-imm, %or-imm,
+! or %xor-imm?
HOOK: immediate-bitwise? cpu ( n -- ? )
-! What c-type describes the implicit struct return pointer for large structs?
+! Can this value be an immediate operand for %compare-imm or
+! %compare-imm-branch?
+HOOK: immediate-comparand? cpu ( n -- ? )
+
+! Can this value be an immediate operand for %replace-imm?
+HOOK: immediate-store? cpu ( obj -- ? )
+
+M: object immediate-comparand? ( n -- ? )
+ {
+ { [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
+ { [ dup not ] [ drop t ] }
+ [ drop f ]
+ } cond ;
+
+: immediate-shift-count? ( n -- ? )
+ 0 cell-bits 1 - between? ;
+
+! What c-type describes the implicit struct return pointer for
+! large structs?
HOOK: struct-return-pointer-type cpu ( -- c-type )
! Is this structure small enough to be returned in registers?
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M: ppc %load-reference ( reg obj -- )
- [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
+ [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ;
M: ppc %alien-global ( register symbol dll -- )
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
M: ppc %set-slot ( src obj slot -- ) swapd STWX ;
M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ;
-M:: ppc %string-nth ( dst src index temp -- )
- [
- "end" define-label
- temp src index ADD
- dst temp string-offset LBZ
- 0 dst HEX: 80 CMPI
- "end" get BLT
- temp src string-aux-offset LWZ
- temp temp index ADD
- temp temp index ADD
- temp temp byte-array-offset LHZ
- temp temp 7 SLWI
- dst dst temp XOR
- "end" resolve-label
- ] with-scope ;
-
-M:: ppc %set-string-nth-fast ( ch obj index temp -- )
- temp obj index ADD
- ch temp string-offset STB ;
-
M: ppc %add ADD ;
M: ppc %add-imm ADDI ;
M: ppc %sub swap SUBF ;
M: ppc %copy ( dst src rep -- )
2over eq? [ 3drop ] [
{
+ { tagged-rep [ MR ] }
{ int-rep [ MR ] }
{ double-rep [ FMR ] }
} case
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
-: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline
+: (%compare-imm) ( src1 src2 -- ) [ 0 ] [ ] [ \ f type-number or ] tri* CMPI ; inline
: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: locals alien alien.c-types alien.libraries alien.syntax
arrays kernel fry math namespaces sequences system layouts io
-vocabs.loader accessors init classes.struct combinators command-line
-make compiler compiler.units compiler.constants compiler.alien
-compiler.codegen compiler.codegen.fixup
+vocabs.loader accessors init classes.struct combinators
+command-line make words compiler compiler.units
+compiler.constants compiler.alien compiler.codegen
+compiler.codegen.alien compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics compiler.cfg.stack-frame
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
M: x86.32 frame-reg EBP ;
M: x86.32 temp-reg ECX ;
+M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
+
+M: x86.32 %load-double ( dst val -- )
+ [ 0 [] MOVSD ] dip rc-absolute rel-binary-literal ;
+
+M:: x86.32 %load-vector ( dst val rep -- )
+ dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ;
+
M: x86.32 %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ;
temp HEX: 7f [+] JMP
building get length :> end
! Fix up the displacement above
- cell code-alignment
+ cell alignment
[ end start - + building get dup pop* push ]
- [ align-code ]
+ [ (align-code) ]
bi ;
M: x86.32 pic-tail-reg EDX ;
M: x86.32 %cleanup ( params -- )
stack-cleanup [ ESP swap SUB ] unless-zero ;
-M:: x86.32 %call-gc ( gc-root-count temp -- )
- temp gc-root-base special@ LEA
- 8 save-vm-ptr
- 4 stack@ gc-root-count MOV
- 0 stack@ temp MOV
+M:: x86.32 %call-gc ( gc-roots -- )
+ 4 save-vm-ptr
+ 0 stack@ gc-roots gc-root-offsets %load-reference
"inline_gc" f %alien-invoke ;
M: x86.32 dummy-stack-params? f ;
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.libraries
slots splitting assocs combinators locals compiler.constants
-compiler.codegen compiler.codegen.fixup
+compiler.codegen compiler.codegen.alien compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics compiler.cfg.stack-frame
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
M: x86.64 %vm-field ( dst offset -- )
[ vm-reg ] dip [+] MOV ;
+M: x86.64 %load-double ( dst val -- )
+ [ 0 [RIP+] MOVSD ] dip rc-relative rel-binary-literal ;
+
+M:: x86.64 %load-vector ( dst val rep -- )
+ dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ;
+
M: x86.64 %set-vm-field ( src offset -- )
[ vm-reg ] dip [+] swap MOV ;
temp HEX: 7f [+] JMP
building get length :> end
! Fix up the displacement above
- cell code-alignment
+ cell alignment
[ end start - + building get dup pop* push ]
- [ align-code ]
+ [ (align-code) ]
bi ;
M: stack-params copy-register*
] [
rep load-return-value
] if
- rep int-rep?
- cpu x86.64? os windows? and or
- param-reg-1 param-reg-0 ? %mov-vm-ptr
+ rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
func f %alien-invoke ;
: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
func "libm" load-library %alien-invoke
dst float-function-return ;
-M:: x86.64 %call-gc ( gc-root-count temp -- )
- ! Pass pointer to start of GC roots as first parameter
- param-reg-0 gc-root-base param@ LEA
- ! Pass number of roots as second parameter
- param-reg-1 gc-root-count MOV
- ! Pass VM ptr as third parameter
- param-reg-2 %mov-vm-ptr
- ! Call GC
+M:: x86.64 %call-gc ( gc-roots -- )
+ param-reg-0 gc-roots gc-root-offsets %load-reference
+ param-reg-1 %mov-vm-ptr
"inline_gc" f %alien-invoke ;
M: x86.64 struct-return-pointer-type void* ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 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 classes.struct cpu.architecture
-cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen
-compiler.cfg.registers ;
+USING: accessors arrays sequences math splitting make assocs
+kernel layouts system alien.c-types classes.struct
+cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
+cpu.x86 compiler.codegen.alien compiler.cfg.registers ;
IN: cpu.x86.64.unix
M: int-regs param-regs
kernel tools.test namespaces make layouts ;
IN: cpu.x86.assembler.tests
+! immediate operands
+[ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
+[ { HEX: 83 HEX: c1 HEX: 01 } ] [ [ ECX 1 ADD ] { } make ] unit-test
+[ { HEX: 81 HEX: c1 HEX: 96 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 150 ADD ] { } make ] unit-test
+[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
+
+! 64-bit registers
[ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
[ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
+! memory address modes
+[ { HEX: 8a HEX: 18 } ] [ [ BL RAX [] MOV ] { } make ] unit-test
+[ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX RAX [] MOV ] { } make ] unit-test
+[ { HEX: 8b HEX: 18 } ] [ [ EBX RAX [] MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 8b HEX: 18 } ] [ [ RBX RAX [] MOV ] { } make ] unit-test
+[ { HEX: 88 HEX: 18 } ] [ [ RAX [] BL MOV ] { } make ] unit-test
+[ { HEX: 66 HEX: 89 HEX: 18 } ] [ [ RAX [] BX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 18 } ] [ [ RAX [] EBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 18 } ] [ [ RAX [] RBX MOV ] { } make ] unit-test
+
+[ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test
+[ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test
+
+[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
+[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1a } ] [ [ R10 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1b } ] [ [ R11 RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1c } ] [ [ R12 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 04 HEX: 1c } ] [ [ RSP RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ R13 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ RBP RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 4a HEX: 89 HEX: 04 HEX: 23 } ] [ [ RBX R12 [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 4a HEX: 89 HEX: 04 HEX: 2b } ] [ [ RBX R13 [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 4b HEX: 89 HEX: 44 HEX: 25 HEX: 00 } ] [ [ R13 R12 [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 4b HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 R13 [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
+[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail
+
+[ { HEX: 89 HEX: 1c HEX: 11 } ] [ [ ECX EDX [+] EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 1c HEX: 51 } ] [ [ ECX EDX 1 0 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 1c HEX: 91 } ] [ [ ECX EDX 2 0 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 1c HEX: d1 } ] [ [ ECX EDX 3 0 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: 11 HEX: 64 } ] [ [ ECX EDX 0 100 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: 51 HEX: 64 } ] [ [ ECX EDX 1 100 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: 91 HEX: 64 } ] [ [ ECX EDX 2 100 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: d1 HEX: 64 } ] [ [ ECX EDX 3 100 <indirect> EBX MOV ] { } make ] unit-test
+
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: 11 } ] [ [ RCX RDX [+] RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: 51 } ] [ [ RCX RDX 1 0 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: 91 } ] [ [ RCX RDX 2 0 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: d1 } ] [ [ RCX RDX 3 0 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: 11 HEX: 64 } ] [ [ RCX RDX 0 100 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: 51 HEX: 64 } ] [ [ RCX RDX 1 100 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: 91 HEX: 64 } ] [ [ RCX RDX 2 100 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: d1 HEX: 64 } ] [ [ RCX RDX 3 100 <indirect> RBX MOV ] { } make ] unit-test
+
! r-rm / m-r sse instruction
[ { HEX: 0f HEX: 10 HEX: c1 } ] [ [ XMM0 XMM1 MOVUPS ] { } make ] unit-test
[ { HEX: 0f HEX: 10 HEX: 01 } ] [ [ XMM0 ECX [] MOVUPS ] { } make ] unit-test
[ { HEX: f2 HEX: 48 HEX: 0f HEX: 2a HEX: c0 } ] [ [ XMM0 RAX CVTSI2SD ] { } make ] unit-test
[ { HEX: f2 HEX: 49 HEX: 0f HEX: 2a HEX: c4 } ] [ [ XMM0 R12 CVTSI2SD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 49 HEX: 0f HEX: 2c HEX: c1 } ] [ [ XMM9 RAX CVTSI2SD ] { } make ] unit-test
-
-! [ { HEX: f2 HEX: 0f HEX: 10 HEX: 00 } ] [ [ XMM0 RAX [] MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 10 HEX: 04 HEX: 24 } ] [ [ XMM0 R12 [] MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 0f HEX: 11 HEX: 00 } ] [ [ RAX [] XMM0 MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 11 HEX: 04 HEX: 24 } ] [ [ R12 [] XMM0 MOVSD ] { } make ] unit-test
-
! 3-operand r-rm-imm sse instructions
[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ]
[ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test
[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: c1 } ] [ [ EAX ECX CRC32 ] { } make ] unit-test
[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: 01 } ] [ [ EAX ECX [] CRC32 ] { } make ] unit-test
-! memory address modes
-[ { HEX: 8a HEX: 18 } ] [ [ BL RAX [] MOV ] { } make ] unit-test
-[ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX RAX [] MOV ] { } make ] unit-test
-[ { HEX: 8b HEX: 18 } ] [ [ EBX RAX [] MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 8b HEX: 18 } ] [ [ RBX RAX [] MOV ] { } make ] unit-test
-[ { HEX: 88 HEX: 18 } ] [ [ RAX [] BL MOV ] { } make ] unit-test
-[ { HEX: 66 HEX: 89 HEX: 18 } ] [ [ RAX [] BX MOV ] { } make ] unit-test
-[ { HEX: 89 HEX: 18 } ] [ [ RAX [] EBX MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 89 HEX: 18 } ] [ [ RAX [] RBX MOV ] { } make ] unit-test
-
-[ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test
-[ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test
-
-[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
-[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1a } ] [ [ R10 RBX [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1b } ] [ [ R11 RBX [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1c } ] [ [ R12 RBX [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 89 HEX: 04 HEX: 1c } ] [ [ RSP RBX [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ R13 RBX [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ RBP RBX [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 4a HEX: 89 HEX: 04 HEX: 23 } ] [ [ RBX R12 [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 4a HEX: 89 HEX: 04 HEX: 2b } ] [ [ RBX R13 [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 4b HEX: 89 HEX: 44 HEX: 25 HEX: 00 } ] [ [ R13 R12 [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 4b HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 R13 [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
-[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail
-
+! shifts
[ { 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
-[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
+[ { HEX: c1 HEX: e0 HEX: 05 } ] [ [ EAX 5 SHL ] { } make ] unit-test
+[ { HEX: c1 HEX: e1 HEX: 05 } ] [ [ ECX 5 SHL ] { } make ] unit-test
+[ { HEX: c1 HEX: e8 HEX: 05 } ] [ [ EAX 5 SHR ] { } make ] unit-test
+[ { HEX: c1 HEX: e9 HEX: 05 } ] [ [ ECX 5 SHR ] { } make ] unit-test
+! multiplication
[ { HEX: 4d HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 R8 3 IMUL3 ] { } make ] unit-test
[ { HEX: 49 HEX: 6b HEX: c0 HEX: 03 } ] [ [ RAX R8 3 IMUL3 ] { } make ] unit-test
[ { HEX: 4c HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 RAX 3 IMUL3 ] { } make ] unit-test
combinators.short-circuit math math.bitwise locals namespaces
make sequences words system layouts math.order accessors
cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
-QUALIFIED: sequences
IN: cpu.x86.assembler
! A postfix assembler for x86-32 and x86-64.
: 2, ( n -- ) 2 n, ; inline
: cell, ( n -- ) bootstrap-cell n, ; inline
-: mod-r/m, ( reg# indirect -- )
+: mod-r/m, ( reg operand -- )
[ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
-: sib, ( indirect -- )
+: sib, ( operand -- )
dup sib-present? [
[ indirect-base* ]
[ indirect-index* 3 shift ]
M: register displacement, drop ;
-: addressing ( reg# indirect -- )
+: addressing ( reg operand -- )
[ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
: rex.w? ( rex.w reg r/m -- ? )
{
- { [ dup register-128? ] [ drop operand-64? ] }
- { [ dup not ] [ drop operand-64? ] }
- [ nip operand-64? ]
+ { [ over register-128? ] [ nip operand-64? ] }
+ { [ over not ] [ nip operand-64? ] }
+ [ drop operand-64? ]
} cond and ;
: rex.r ( m op -- n )
:: rex-prefix ( reg r/m rex.w -- )
#! Compile an AMD64 REX prefix.
rex.w reg r/m rex.w? BIN: 01001000 BIN: 01000000 ?
- r/m rex.r
- reg rex.b
+ reg rex.r
+ r/m rex.b
dup reg r/m no-prefix? [ drop ] [ , ] if ;
-: 16-prefix ( reg r/m -- )
- [ register-16? ] either? [ HEX: 66 , ] when ;
+: 16-prefix ( reg -- )
+ register-16? [ HEX: 66 , ] when ;
-: prefix ( reg r/m rex.w -- ) [ drop 16-prefix ] [ rex-prefix ] 3bi ;
-
-: prefix-1 ( reg rex.w -- ) f swap prefix ;
+: prefix-1 ( reg rex.w -- )
+ [ drop 16-prefix ] [ [ f ] 2dip rex-prefix ] 2bi ;
: short-operand ( reg rex.w n -- )
#! Some instructions encode their single operand as part of
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
: extended-opcode ( opcode -- opcode' )
- dup array? [ OCT: 17 sequences:prefix ] [ OCT: 17 swap 2array ] if ;
+ dup array? [ OCT: 17 prefix ] [ OCT: 17 swap 2array ] if ;
: extended-opcode, ( opcode -- ) extended-opcode opcode, ;
: opcode-or ( opcode mask -- opcode' )
- swap dup array?
- [ unclip-last rot bitor suffix ] [ bitor ] if ;
+ over array?
+ [ [ unclip-last ] dip bitor suffix ] [ bitor ] if ;
-: 1-operand ( op reg,rex.w,opcode -- )
+: 1-operand ( operand 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 [ [ over ] dip prefix-1 ] dip 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-operand-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+ over integer? [ first3 BIN: 1 opcode-or 3array ] when ;
-: immediate-1 ( imm dst reg,rex.w,opcode -- )
- immediate-operand-size-bit 1-operand 1, ;
+: immediate-1 ( dst imm reg,rex.w,opcode -- )
+ immediate-operand-size-bit swap [ 1-operand ] dip 1, ;
-: immediate-4 ( imm dst reg,rex.w,opcode -- )
- immediate-operand-size-bit 1-operand 4, ;
+: immediate-4 ( dst imm reg,rex.w,opcode -- )
+ immediate-operand-size-bit swap [ 1-operand ] dip 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-fits-in-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+ over integer? [ first3 BIN: 10 opcode-or 3array ] when ;
-: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
+: immediate-1/4 ( dst imm 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? [
+ over fits-in-byte? [
immediate-fits-in-size-bit immediate-1
] [
immediate-4
] if ;
-: (2-operand) ( dst src op -- )
+: (2-operand) ( reg operand op -- )
[ 2dup t rex-prefix ] dip opcode,
- reg-code swap addressing ;
+ [ reg-code ] dip addressing ;
-: direction-bit ( dst src op -- dst' src' op' )
+: direction-bit ( dst src op -- reg operand op' )
pick register? pick register? not and
- [ BIN: 10 opcode-or swapd ] when ;
+ [ BIN: 10 opcode-or ] [ swapd ] if ;
-: operand-size-bit ( dst src op -- dst' src' op' )
- over register-8? [ BIN: 1 opcode-or ] unless ;
+: operand-size-bit ( reg operand op -- reg operand op' )
+ pick 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.
- [ drop 16-prefix ] [ direction-bit operand-size-bit (2-operand) ] 3bi ;
+ direction-bit operand-size-bit
+ pick 16-prefix
+ (2-operand) ;
PRIVATE>
! MOV where the src is immediate.
<PRIVATE
-GENERIC: (MOV-I) ( src dst -- )
-M: register (MOV-I) t HEX: b8 short-operand cell, ;
+GENERIC# (MOV-I) 1 ( dst src -- )
+M: register (MOV-I) [ t HEX: b8 short-operand ] [ cell, ] bi* ;
M: operand (MOV-I)
{ BIN: 000 t HEX: c6 }
- pick byte? [ immediate-1 ] [ immediate-4 ] if ;
+ over byte? [ immediate-1 ] [ immediate-4 ] if ;
PRIVATE>
GENERIC: MOV ( dst src -- )
-M: immediate MOV swap (MOV-I) ;
+M: immediate MOV (MOV-I) ;
M: operand MOV HEX: 88 2-operand ;
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
! Arithmetic
GENERIC: ADD ( dst src -- )
-M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
+M: immediate ADD { 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: immediate OR { 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: immediate ADC { 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: immediate SBB { 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: immediate AND { 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: immediate SUB { 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: immediate XOR { 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: immediate CMP { BIN: 111 t HEX: 80 } immediate-1/4 ;
M: operand CMP OCT: 070 2-operand ;
GENERIC: TEST ( dst src -- )
-M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ;
+M: immediate TEST { BIN: 0 t HEX: f7 } immediate-4 ;
M: operand TEST OCT: 204 2-operand ;
: XCHG ( dst src -- ) OCT: 207 2-operand ;
-: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
+: BSR ( dst src -- ) { HEX: 0f HEX: bd } (2-operand) ;
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
<PRIVATE
-: (SHIFT) ( dst src op -- )
- over CL eq? [
- nip t HEX: d3 3array 1-operand
+:: (SHIFT) ( dst src op -- )
+ src CL eq? [
+ dst { op t HEX: d3 } 1-operand
] [
- swapd t HEX: c0 3array immediate-1
+ dst src { op t HEX: c0 } immediate-1
] if ; inline
PRIVATE>
] if ;
: MOVSX ( dst src -- )
- swap
- over register-32? OCT: 143 OCT: 276 extended-opcode ?
- pick register-16? [ BIN: 1 opcode-or ] when
+ dup register-32? OCT: 143 OCT: 276 extended-opcode ?
+ over register-16? [ BIN: 1 opcode-or ] when
(2-operand) ;
: MOVZX ( dst src -- )
- swap
OCT: 266 extended-opcode
- pick register-16? [ BIN: 1 opcode-or ] when
+ over register-16? [ BIN: 1 opcode-or ] when
(2-operand) ;
! Conditional move
-: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
+: MOVcc ( dst src cc -- ) extended-opcode (2-operand) ;
: CMOVO ( dst src -- ) HEX: 40 MOVcc ;
: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
<PRIVATE
: direction-bit-sse ( dst src op1 -- dst' src' op1' )
- pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
+ pick register-128? [ swapd BIN: 1 bitor ] unless ;
: 2-operand-sse ( dst src op1 op2 -- )
[ , ] when* direction-bit-sse extended-opcode (2-operand) ;
: direction-op-sse ( dst src op1s -- dst' src' op1' )
- pick register-128? [ swapd first ] [ second ] if ;
+ pick register-128? [ first ] [ swapd second ] if ;
: 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- )
[ , ] when* direction-op-sse extended-opcode (2-operand) ;
: 2-operand-rm-sse ( dst src op1 op2 -- )
- [ , ] when* swapd extended-opcode (2-operand) ;
+ [ , ] when* extended-opcode (2-operand) ;
: 2-operand-mr-sse ( dst src op1 op2 -- )
- [ , ] when* extended-opcode (2-operand) ;
+ [ , ] when* extended-opcode swapd (2-operand) ;
: 2-operand-int/sse ( dst src op1 op2 -- )
- [ , ] when* swapd extended-opcode (2-operand) ;
+ [ , ] when* extended-opcode (2-operand) ;
-: 3-operand-rm-sse ( dst src imm op1 op2 -- )
- rot [ 2-operand-rm-sse ] dip , ;
+:: 3-operand-rm-sse ( dst src imm op1 op2 -- )
+ dst src op1 op2 2-operand-rm-sse imm , ;
-: 3-operand-mr-sse ( dst src imm op1 op2 -- )
- rot [ 2-operand-mr-sse ] dip , ;
+:: 3-operand-mr-sse ( dst src imm op1 op2 -- )
+ dst src op1 op2 2-operand-mr-sse imm , ;
-: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- )
- rot [ 2-operand-rm-mr-sse ] dip , ;
+:: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- )
+ dst src op1 op2 2-operand-rm-mr-sse imm , ;
: 2-operand-sse-cmp ( dst src cmp op1 op2 -- )
3-operand-rm-sse ; inline
: CMPNLESS ( dest src -- ) 6 HEX: c2 HEX: f3 2-operand-sse-cmp ;
: CMPORDSS ( dest src -- ) 7 HEX: c2 HEX: f3 2-operand-sse-cmp ;
-: MOVNTI ( dest src -- ) { HEX: 0f HEX: c3 } (2-operand) ;
+: MOVNTI ( dest src -- ) swap { HEX: 0f HEX: c3 } (2-operand) ;
: PINSRW ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-rm-sse ;
: SHUFPS ( dest src imm -- ) 4shuffler HEX: c6 f 3-operand-rm-sse ;
: HWNT ( -- ) HEX: 2e , ; ! Hint branch Weakly Not Taken
: HST ( -- ) HEX: 3e , ; ! Hint branch Strongly Taken
-
M: indirect extended? base>> extended? ;
+: canonicalize-displacement ( indirect -- indirect )
+ dup [ base>> ] [ displacement>> 0 = ] bi and
+ [ f >>displacement ] when ;
+
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
- canonicalize-EBP check-ESP ;
-
-: <indirect> ( base index scale displacement -- indirect )
- indirect boa canonicalize ;
+ canonicalize-displacement canonicalize-EBP check-ESP ;
! Utilities
UNION: operand register indirect ;
PRIVATE>
-: [] ( reg/displacement -- indirect )
+: <indirect> ( base index scale displacement -- indirect )
+ indirect boa canonicalize ;
+
+: [] ( base/displacement -- indirect )
dup integer?
[ [ f f bootstrap-cell 8 = 0 f ? ] dip <indirect> ]
[ f f f <indirect> ]
: [RIP+] ( displacement -- indirect )
[ f f f ] dip <indirect> ;
-: [+] ( reg displacement -- indirect )
+: [+] ( base index/displacement -- indirect )
dup integer?
- [ dup zero? [ drop f ] when [ f f ] dip ]
+ [ [ f f ] dip ]
[ f f ] if
<indirect> ;
+: [++] ( base index displacement -- indirect )
+ [ f ] dip <indirect> ;
+
+: [+*2+] ( base index displacement -- indirect )
+ [ 1 ] dip <indirect> ;
+
+: [+*4+] ( base index displacement -- indirect )
+ [ 2 ] dip <indirect> ;
+
+: [+*8+] ( base index displacement -- indirect )
+ [ 3 ] dip <indirect> ;
+
TUPLE: byte value ;
C: <byte> byte
USING: bootstrap.image.private compiler.constants
compiler.units cpu.x86.assembler cpu.x86.assembler.operands
kernel kernel.private layouts locals.backend make math
-math.private namespaces sequences slots.private vocabs ;
+math.private namespaces sequences slots.private strings.private
+vocabs ;
IN: bootstrap.x86
big-endian off
ds-reg [] temp0 MOV
] \ slot define-sub-primitive
+[
+ ! load string index from stack
+ temp0 ds-reg bootstrap-cell neg [+] MOV
+ temp0 tag-bits get SHR
+ ! load string from stack
+ temp1 ds-reg [] MOV
+ ! load character
+ temp0 8-bit-version-of temp0 temp1 string-offset [++] MOV
+ temp0 temp0 8-bit-version-of MOVZX
+ temp0 tag-bits get SHL
+ ! store character to stack
+ ds-reg bootstrap-cell SUB
+ ds-reg [] temp0 MOV
+] \ string-nth-fast define-sub-primitive
+
! Shufflers
[
ds-reg bootstrap-cell SUB
! multiply
temp0 temp1 IMUL2
! push result
- ds-reg [] temp1 MOV
+ ds-reg [] temp0 MOV
] \ fixnum*fast define-sub-primitive
[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
cpu.x86.features cpu.x86.features.private cpu.architecture kernel
kernel.private math memory namespaces make sequences words system
layouts combinators math.order math.vectors fry locals compiler.constants
-byte-arrays io macros quotations compiler compiler.units init vm
+byte-arrays io macros quotations classes.algebra compiler
+compiler.units init vm
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.codegen.fixup ;
+QUALIFIED-WITH: alien.c-types c
FROM: layouts => cell ;
FROM: math => float ;
IN: cpu.x86
: stack@ ( n -- op ) stack-reg swap [+] ;
-: special@ ( n -- op )
+: special-offset ( m -- n )
stack-frame get extra-stack-space +
- reserved-stack-space +
- stack@ ;
+ reserved-stack-space + ;
-: spill@ ( n -- op ) spill-offset special@ ;
+: special@ ( n -- op ) special-offset stack@ ;
-: gc-root@ ( n -- op ) gc-root-offset special@ ;
+: spill@ ( n -- op ) spill-offset special@ ;
: param@ ( n -- op ) reserved-stack-space + stack@ ;
+: gc-root-offsets ( seq -- seq' )
+ [ n>> special-offset ] map f like ;
+
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
HOOK: pic-tail-reg cpu ( -- reg )
+M: x86 complex-addressing? t ;
+
+M: x86 fused-unboxing? ( -- ? ) t ;
+
+M: x86 immediate-store? ( obj -- ? ) immediate-comparand? ;
+
M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
-M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
+M: x86 %load-reference
+ [ swap 0 MOV rc-absolute-cell rel-literal ]
+ [ \ f type-number MOV ]
+ if* ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
M: rs-loc loc>operand n>> rs-reg reg-stack ;
M: x86 %peek loc>operand MOV ;
+
M: x86 %replace loc>operand swap MOV ;
+
+M: x86 %replace-imm
+ loc>operand swap
+ {
+ { [ dup not ] [ drop \ f type-number MOV ] }
+ { [ dup fixnum? ] [ tag-fixnum MOV ] }
+ [ [ HEX: ffffffff MOV ] dip rc-absolute rel-literal ]
+ } cond ;
+
: (%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) ;
M: x86 %return ( -- ) 0 RET ;
-: code-alignment ( align -- n )
- [ building get length dup ] dip align swap - ;
-
-: align-code ( n -- )
- 0 <repetition> % ;
+: (%slot) ( obj slot scale tag -- op ) neg <indirect> ; inline
+: (%slot-imm) ( obj slot tag -- op ) slot-offset [+] ; inline
-:: (%slot-imm) ( obj slot tag -- op )
- obj slot tag slot-offset [+] ; inline
-
-M: x86 %slot ( dst obj slot -- ) [+] MOV ;
+M: x86 %slot ( dst obj slot scale tag -- ) (%slot) MOV ;
M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
-M: x86 %set-slot ( src obj slot -- ) [+] swap MOV ;
+M: x86 %set-slot ( src obj slot scale tag -- ) (%slot) swap MOV ;
M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
:: two-operand ( dst src1 src2 rep -- dst src )
M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ;
M: x86 %sub int-rep two-operand SUB ;
M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ;
-M: x86 %mul int-rep two-operand swap IMUL2 ;
+M: x86 %mul int-rep two-operand IMUL2 ;
M: x86 %mul-imm IMUL3 ;
M: x86 %and int-rep two-operand AND ;
M: x86 %and-imm int-rep two-operand AND ;
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
] if ;
-M: x86 %fixnum-add ( label dst src1 src2 -- )
- int-rep two-operand ADD JO ;
+: fixnum-overflow ( label dst src1 src2 cc quot -- )
+ swap [ [ int-rep two-operand ] dip call ] dip
+ {
+ { cc-o [ JO ] }
+ { cc/o [ JNO ] }
+ } case ; inline
+
+M: x86 %fixnum-add ( label dst src1 src2 cc -- )
+ [ ADD ] fixnum-overflow ;
-M: x86 %fixnum-sub ( label dst src1 src2 -- )
- int-rep two-operand SUB JO ;
+M: x86 %fixnum-sub ( label dst src1 src2 cc -- )
+ [ SUB ] fixnum-overflow ;
-M: x86 %fixnum-mul ( label dst src1 src2 -- )
- int-rep two-operand swap IMUL2 JO ;
+M: x86 %fixnum-mul ( label dst src1 src2 cc -- )
+ [ IMUL2 ] fixnum-overflow ;
M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ;
"end" resolve-label
] with-scope ;
+:: %box-displaced-alien/f ( dst displacement -- )
+ dst 1 alien@ \ f type-number MOV
+ dst 3 alien@ displacement MOV
+ dst 4 alien@ displacement MOV ;
+
+:: %box-displaced-alien/alien ( dst displacement base temp -- )
+ ! Set new alien's base to base.base
+ temp base 1 alien@ MOV
+ dst 1 alien@ temp MOV
+
+ ! Compute displacement
+ temp base 3 alien@ MOV
+ temp displacement ADD
+ dst 3 alien@ temp MOV
+
+ ! Compute address
+ temp base 4 alien@ MOV
+ temp displacement ADD
+ dst 4 alien@ temp MOV ;
+
+:: %box-displaced-alien/byte-array ( dst displacement base temp -- )
+ dst 1 alien@ base MOV
+ dst 3 alien@ displacement MOV
+ temp base displacement byte-array-offset [++] LEA
+ dst 4 alien@ temp MOV ;
+
+:: %box-displaced-alien/dynamic ( dst displacement base temp -- )
+ "not-f" define-label
+ "not-alien" define-label
+
+ ! Check base type
+ temp base MOV
+ temp tag-mask get AND
+
+ ! Is base f?
+ temp \ f type-number CMP
+ "not-f" get JNE
+
+ ! Yes, it is f. Fill in new object
+ dst displacement %box-displaced-alien/f
+
+ "end" get JMP
+
+ "not-f" resolve-label
+
+ ! Is base an alien?
+ temp alien type-number CMP
+ "not-alien" get JNE
+
+ dst displacement base temp %box-displaced-alien/alien
+
+ ! We are done
+ "end" get JMP
+
+ ! Is base a byte array? It has to be, by now...
+ "not-alien" resolve-label
+
+ dst displacement base temp %box-displaced-alien/byte-array ;
+
M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
- ! This is ridiculous
[
"end" define-label
- "not-f" define-label
- "not-alien" define-label
! If displacement is zero, return the base
dst base MOV
! Set expired to f
dst 2 alien@ \ f type-number MOV
- ! Is base f?
- base \ f type-number CMP
- "not-f" get JNE
-
- ! Yes, it is f. Fill in new object
- dst 1 alien@ base MOV
- dst 3 alien@ displacement MOV
- dst 4 alien@ displacement MOV
-
- "end" get JMP
-
- "not-f" resolve-label
-
- ! Check base type
- temp base MOV
- temp tag-mask get AND
-
- ! Is base an alien?
- temp alien type-number CMP
- "not-alien" get JNE
-
- ! Yes, it is an alien. Set new alien's base to base.base
- temp base 1 alien@ MOV
- dst 1 alien@ temp MOV
-
- ! Compute displacement
- temp base 3 alien@ MOV
- temp displacement ADD
- dst 3 alien@ temp MOV
-
- ! Compute address
- temp base 4 alien@ MOV
- temp displacement ADD
- dst 4 alien@ temp MOV
-
- ! We are done
- "end" get JMP
-
- ! Is base a byte array? It has to be, by now...
- "not-alien" resolve-label
-
- dst 1 alien@ base MOV
- dst 3 alien@ displacement MOV
- temp base MOV
- temp byte-array-offset ADD
- temp displacement ADD
- dst 4 alien@ temp MOV
+ dst displacement base temp
+ {
+ { [ base-class \ f class<= ] [ 2drop %box-displaced-alien/f ] }
+ { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
+ { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
+ [ %box-displaced-alien/dynamic ]
+ } cond
"end" resolve-label
] with-scope ;
[ quot call ] with-save/restore
] if ; inline
-M:: x86 %string-nth ( dst src index temp -- )
- ! We request a small-reg of size 8 since those of size 16 are
- ! a superset.
- "end" define-label
- dst { src index temp } 8 [| new-dst |
- ! Load the least significant 7 bits into new-dst.
- ! 8th bit indicates whether we have to load from
- ! the aux vector or not.
- temp src index [+] LEA
- new-dst 8-bit-version-of temp string-offset [+] MOV
- new-dst new-dst 8-bit-version-of MOVZX
- ! Do we have to look at the aux vector?
- new-dst HEX: 80 CMP
- "end" get JL
- ! Yes, this is a non-ASCII character. Load aux vector
- temp src string-aux-offset [+] MOV
- new-dst temp XCHG
- ! Compute index
- new-dst index ADD
- new-dst index ADD
- ! Load high 16 bits
- new-dst 16-bit-version-of new-dst byte-array-offset [+] MOV
- new-dst new-dst 16-bit-version-of MOVZX
- new-dst 7 SHL
- ! Compute code point
- new-dst temp XOR
- "end" resolve-label
- dst new-dst int-rep %copy
- ] with-small-register ;
-
-M:: x86 %set-string-nth-fast ( ch str index temp -- )
- ch { index str temp } 8 [| new-ch |
- new-ch ch int-rep %copy
- temp str index [+] LEA
- temp string-offset [+] new-ch 8-bit-version-of MOV
- ] with-small-register ;
-
-:: %alien-integer-getter ( dst src offset size quot -- )
- dst { src } size [| new-dst |
- new-dst dup size n-bit-version-of dup src offset [+] MOV
+:: %alien-integer-getter ( dst exclude address bits quot -- )
+ dst exclude bits [| new-dst |
+ new-dst dup bits n-bit-version-of dup address MOV
quot call
dst new-dst int-rep %copy
] with-small-register ; inline
-: %alien-unsigned-getter ( dst src offset size -- )
+: %alien-unsigned-getter ( dst exclude address bits -- )
[ MOVZX ] %alien-integer-getter ; inline
-: %alien-signed-getter ( dst src offset size -- )
+: %alien-signed-getter ( dst exclude address bits -- )
[ MOVSX ] %alien-integer-getter ; inline
-:: %alien-integer-setter ( ptr offset value size -- )
- value { ptr } size [| new-value |
+:: %alien-integer-setter ( value exclude address bits -- )
+ value exclude bits [| new-value |
new-value value int-rep %copy
- ptr offset [+] new-value size n-bit-version-of MOV
+ address new-value bits n-bit-version-of MOV
] with-small-register ; inline
-M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
-M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
-M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
+: (%memory) ( base displacement scale offset rep c-type -- exclude address rep c-type )
+ [ [ [ 2array ] 2keep ] 2dip <indirect> ] 2dip ;
+
+: (%memory-imm) ( base offset rep c-type -- exclude address rep c-type )
+ [ [ drop 1array ] [ [+] ] 2bi ] 2dip ;
+
+: (%load-memory) ( dst exclude address rep c-type -- )
+ [
+ {
+ { c:char [ 8 %alien-signed-getter ] }
+ { c:uchar [ 8 %alien-unsigned-getter ] }
+ { c:short [ 16 %alien-signed-getter ] }
+ { c:ushort [ 16 %alien-unsigned-getter ] }
+ { c:int [ 32 %alien-signed-getter ] }
+ { c:uint [ 32 [ 2drop ] %alien-integer-getter ] }
+ } case
+ ] [ [ drop ] 2dip %copy ] ?if ;
+
+M: x86 %load-memory ( dst base displacement scale offset rep c-type -- )
+ (%memory) (%load-memory) ;
+
+M: x86 %load-memory-imm ( dst base offset rep c-type -- )
+ (%memory-imm) (%load-memory) ;
-M: x86 %alien-signed-1 8 %alien-signed-getter ;
-M: x86 %alien-signed-2 16 %alien-signed-getter ;
-M: x86 %alien-signed-4 32 %alien-signed-getter ;
+: (%store-memory) ( src exclude address rep c-type -- )
+ [
+ {
+ { c:char [ 8 %alien-integer-setter ] }
+ { c:uchar [ 8 %alien-integer-setter ] }
+ { c:short [ 16 %alien-integer-setter ] }
+ { c:ushort [ 16 %alien-integer-setter ] }
+ { c:int [ 32 %alien-integer-setter ] }
+ { c:uint [ 32 %alien-integer-setter ] }
+ } case
+ ] [ [ nip swap ] dip %copy ] ?if ;
-M: x86 %alien-cell [+] MOV ;
-M: x86 %alien-float [+] MOVSS ;
-M: x86 %alien-double [+] MOVSD ;
-M: x86 %alien-vector [ [+] ] dip %copy ;
+M: x86 %store-memory ( src base displacement scale offset rep c-type -- )
+ (%memory) (%store-memory) ;
-M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
-M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
-M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
-M: x86 %set-alien-cell [ [+] ] dip MOV ;
-M: x86 %set-alien-float [ [+] ] dip MOVSS ;
-M: x86 %set-alien-double [ [+] ] dip MOVSD ;
-M: x86 %set-alien-vector [ [+] ] 2dip %copy ;
+M: x86 %store-memory-imm ( src base offset rep c-type -- )
+ (%memory-imm) (%store-memory) ;
: shift-count? ( reg -- ? ) { ECX RCX } member-eq? ;
HOOK: %mark-card cpu ( card temp -- )
HOOK: %mark-deck cpu ( card temp -- )
-:: (%write-barrier) ( src slot temp1 temp2 -- )
- temp1 src slot [+] LEA
+:: (%write-barrier) ( temp1 temp2 -- )
temp1 card-bits SHR
temp1 temp2 %mark-card
temp1 deck-bits card-bits - SHR
temp1 temp2 %mark-deck ;
-M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ;
+M:: x86 %write-barrier ( src slot scale tag temp1 temp2 -- )
+ temp1 src slot scale tag (%slot) LEA
+ temp1 temp2 (%write-barrier) ;
-M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
+M:: x86 %write-barrier-imm ( src slot tag temp1 temp2 -- )
+ temp1 src slot tag (%slot-imm) LEA
+ temp1 temp2 (%write-barrier) ;
-M:: x86 %check-nursery ( label size temp1 temp2 -- )
+M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- )
temp1 load-zone-offset
- ! Load 'here' into temp2
temp2 temp1 [] MOV
temp2 size ADD
- ! Load 'end' into temp1
- temp1 temp1 2 cells [+] MOV
- temp2 temp1 CMP
- label JLE ;
-
-M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
-
-M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
+ temp2 temp1 2 cells [+] CMP
+ cc {
+ { cc<= [ label JLE ] }
+ { cc/<= [ label JG ] }
+ } case ;
M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
-:: %boolean ( dst temp word -- )
+:: (%boolean) ( dst temp insn -- )
dst \ f type-number MOV
- temp 0 MOV \ t rc-absolute-cell rel-immediate
- dst temp word execute ; inline
-
-: (%compare) ( src1 src2 cc -- )
- 2over [ { cc= cc/= } member? ] [ register? ] [ 0 = ] tri* and and
- [ drop dup TEST ]
- [ CMP ] if ;
+ temp 0 MOV \ t rc-absolute-cell rel-literal
+ dst temp insn execute ; inline
+
+: %boolean ( dst cc temp -- )
+ swap order-cc {
+ { cc< [ \ CMOVL (%boolean) ] }
+ { cc<= [ \ CMOVLE (%boolean) ] }
+ { cc> [ \ CMOVG (%boolean) ] }
+ { cc>= [ \ CMOVGE (%boolean) ] }
+ { cc= [ \ CMOVE (%boolean) ] }
+ { cc/= [ \ CMOVNE (%boolean) ] }
+ } case ;
M:: x86 %compare ( dst src1 src2 cc temp -- )
- src1 src2 cc (%compare)
- cc order-cc {
- { cc< [ dst temp \ CMOVL %boolean ] }
- { cc<= [ dst temp \ CMOVLE %boolean ] }
- { cc> [ dst temp \ CMOVG %boolean ] }
- { cc>= [ dst temp \ CMOVGE %boolean ] }
- { cc= [ dst temp \ CMOVE %boolean ] }
- { cc/= [ dst temp \ CMOVNE %boolean ] }
- } case ;
+ src1 src2 CMP
+ dst cc temp %boolean ;
-M: x86 %compare-imm ( dst src1 src2 cc temp -- )
- %compare ;
+: use-test? ( src1 src2 cc -- ? )
+ [ register? ] [ 0 = ] [ { cc= cc/= } member? ] tri* and and ;
-M:: x86 %compare-branch ( label src1 src2 cc -- )
- src1 src2 cc (%compare)
- cc order-cc {
- { cc< [ label JL ] }
- { cc<= [ label JLE ] }
- { cc> [ label JG ] }
- { cc>= [ label JGE ] }
- { cc= [ label JE ] }
- { cc/= [ label JNE ] }
+: (%compare-tagged) ( src1 src2 -- )
+ [ HEX: ffffffff CMP ] dip rc-absolute rel-literal ;
+
+: (%compare-integer-imm) ( src1 src2 cc -- )
+ 3dup use-test? [ 2drop dup TEST ] [ drop CMP ] if ;
+
+M:: x86 %compare-integer-imm ( dst src1 src2 cc temp -- )
+ src1 src2 cc (%compare-integer-imm)
+ dst cc temp %boolean ;
+
+: (%compare-imm) ( src1 src2 cc -- )
+ {
+ { [ over fixnum? ] [ [ tag-fixnum ] dip (%compare-integer-imm) ] }
+ { [ over not ] [ 2drop \ f type-number CMP ] }
+ [ drop (%compare-tagged) ]
+ } cond ;
+
+M:: x86 %compare-imm ( dst src1 src2 cc temp -- )
+ src1 src2 cc (%compare-imm)
+ dst cc temp %boolean ;
+
+: %branch ( label cc -- )
+ order-cc {
+ { 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-branch ( label src1 src2 cc -- )
+ src1 src2 CMP
+ label cc %branch ;
+
+M:: x86 %compare-integer-imm-branch ( label src1 src2 cc -- )
+ src1 src2 cc (%compare-integer-imm)
+ label cc %branch ;
+
+M:: x86 %compare-imm-branch ( label src1 src2 cc -- )
+ src1 src2 cc (%compare-imm)
+ label cc %branch ;
M: x86 %add-float double-rep two-operand ADDSD ;
M: x86 %sub-float double-rep two-operand SUBSD ;
:: (%compare-float) ( dst src1 src2 cc temp compare -- )
cc {
- { cc< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
- { cc<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
- { cc> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
- { cc>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
- { cc= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= %boolean ] }
- { cc<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE %boolean ] }
- { cc<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP %boolean ] }
- { cc/< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
- { cc/<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
- { cc/> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
- { cc/>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
- { cc/= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= %boolean ] }
- { cc/<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE %boolean ] }
- { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP %boolean ] }
+ { cc< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA (%boolean) ] }
+ { cc<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+ { cc> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA (%boolean) ] }
+ { cc>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+ { cc= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= (%boolean) ] }
+ { cc<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE (%boolean) ] }
+ { cc<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP (%boolean) ] }
+ { cc/< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+ { cc/<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB (%boolean) ] }
+ { cc/> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+ { cc/>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB (%boolean) ] }
+ { cc/= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= (%boolean) ] }
+ { cc/<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE (%boolean) ] }
+ { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP (%boolean) ] }
} case ; inline
M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
:: %test-vector-mask ( dst temp mask vcc -- )
vcc {
- { vcc-any [ dst dst TEST dst temp \ CMOVNE %boolean ] }
- { vcc-none [ dst dst TEST dst temp \ CMOVE %boolean ] }
- { vcc-all [ dst mask CMP dst temp \ CMOVE %boolean ] }
- { vcc-notall [ dst mask CMP dst temp \ CMOVNE %boolean ] }
+ { vcc-any [ dst dst TEST dst temp \ CMOVNE (%boolean) ] }
+ { vcc-none [ dst dst TEST dst temp \ CMOVE (%boolean) ] }
+ { vcc-all [ dst mask CMP dst temp \ CMOVE (%boolean) ] }
+ { vcc-notall [ dst mask CMP dst temp \ CMOVNE (%boolean) ] }
} case ;
: %move-vector-mask ( dst src rep -- mask )
M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
-M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
+M: x86 %loop-entry 16 alignment [ NOP ] times ;
M:: x86 %restore-context ( temp1 temp2 -- )
#! Load Factor stack pointers on entry from C to Factor.
frame-reg swap 2 cells + [+] ;
enable-min/max
-enable-fixnum-log2
+enable-log2
:: install-sse2-check ( -- )
[
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs debugger io kernel literals math.parser namespaces
-prettyprint sequences system windows.kernel32 ;
+USING: accessors assocs debugger io kernel literals math.parser
+namespaces prettyprint sequences system windows.kernel32
+windows.ole32 windows.errors math ;
IN: debugger.windows
CONSTANT: seh-names
M: windows signal-error.
"Windows exception 0x" write
third [ >hex write ] [ seh-name. ] bi nl ;
+
+M: ole32-error error.
+ "COM error 0x" write
+ dup code>> HEX: ffff,ffff bitand >hex write ": " write
+ message>> write ;
+
+M: windows-error error.
+ "Win32 error 0x" write
+ dup n>> HEX: ffff,ffff bitand >hex write ": " write
+ string>> write ;
+
M: disjoint-set disjoint-set-member? parents>> key? ;
+GENERIC: disjoint-set-members ( disjoint-set -- seq )
+
+M: disjoint-set disjoint-set-members parents>> keys ;
+
GENERIC: equiv-set-size ( a disjoint-set -- n )
M: disjoint-set equiv-set-size [ representative ] keep count ;
{ } buttons-delta-as ; inline
{
- { [ os windows? ] [ "game.input.xinput" require ] }
+ { [ os windows? ] [ "game.input.dinput" require ] }
{ [ os macosx? ] [ "game.input.iokit" require ] }
{ [ os linux? ] [ "game.input.x11" require ] }
[ ]
+++ /dev/null
-USING: accessors alien.c-types alien.syntax half-floats kernel
-math tools.test specialized-arrays alien.data classes.struct ;
-SPECIALIZED-ARRAY: half
-IN: half-floats.tests
-
-[ HEX: 0000 ] [ 0.0 half>bits ] unit-test
-[ HEX: 8000 ] [ -0.0 half>bits ] unit-test
-[ HEX: 3e00 ] [ 1.5 half>bits ] unit-test
-[ HEX: be00 ] [ -1.5 half>bits ] unit-test
-[ HEX: 7c00 ] [ 1/0. half>bits ] unit-test
-[ HEX: fc00 ] [ -1/0. half>bits ] unit-test
-[ HEX: 7eaa ] [ NAN: aaaaaaaaaaaaa half>bits ] unit-test
-
-! too-big floats overflow to infinity
-[ HEX: 7c00 ] [ 65536.0 half>bits ] unit-test
-[ HEX: fc00 ] [ -65536.0 half>bits ] unit-test
-[ HEX: 7c00 ] [ 131072.0 half>bits ] unit-test
-[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test
-
-! too-small floats flush to zero
-[ HEX: 0000 ] [ 1.0e-9 half>bits ] unit-test
-[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test
-
-[ 0.0 ] [ HEX: 0000 bits>half ] unit-test
-[ -0.0 ] [ HEX: 8000 bits>half ] unit-test
-[ 1.5 ] [ HEX: 3e00 bits>half ] unit-test
-[ -1.5 ] [ HEX: be00 bits>half ] unit-test
-[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test
-[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
-[ 3.0 ] [ HEX: 4200 bits>half ] unit-test
-[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
-
-STRUCT: halves
- { tom half }
- { dick half }
- { harry half }
- { harry-jr half } ;
-
-[ 8 ] [ halves heap-size ] unit-test
-
-[ 3.0 ] [
- halves <struct>
- 3.0 >>dick
- dick>>
-] unit-test
-
-[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ]
-[ { 1.0 2.0 3.0 1/0. -1/0. } >half-array ] unit-test
-
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: accessors alien.accessors alien.c-types alien.data
-alien.syntax kernel math math.order ;
-FROM: math => float ;
-IN: half-floats
-
-: half>bits ( float -- bits )
- float>bits
- [ -31 shift 15 shift ] [
- HEX: 7fffffff bitand
- dup zero? [
- dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [
- -13 shift
- 112 10 shift -
- 0 HEX: 7c00 clamp
- ] if
- ] unless
- ] bi bitor ;
-
-: bits>half ( bits -- float )
- [ -15 shift 31 shift ] [
- HEX: 7fff bitand
- dup zero? [
- dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [
- 13 shift
- 112 23 shift +
- ] if
- ] unless
- ] bi bitor bits>float ;
-
-SYMBOL: half
-
-<<
-
-<c-type>
- float >>class
- float >>boxed-class
- [ alien-unsigned-2 bits>half ] >>getter
- [ [ >float half>bits ] 2dip set-alien-unsigned-2 ] >>setter
- 2 >>size
- 2 >>align
- 2 >>align-first
- [ >float ] >>unboxer-quot
-\ half define-primitive-type
-
->>
+++ /dev/null
-Half-precision float support for FFI
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays byte-vectors classes
combinators definitions effects fry generic generic.single
-generic.standard hashtables io.binary io.streams.string kernel
-kernel.private math math.integers.private math.parser
-namespaces parser sbufs sequences splitting splitting.private strings
-vectors words ;
+generic.standard hashtables io.binary io.encodings
+io.streams.string kernel kernel.private math
+math.integers.private math.parser namespaces parser sbufs
+sequences splitting splitting.private strings vectors words ;
IN: hints
GENERIC: specializer-predicate ( spec -- quot )
M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
\ bignum/f { { bignum bignum } { bignum fixnum } { fixnum bignum } { fixnum fixnum } } "specializer" set-word-prop
+
+\ encode-string { string object object } "specializer" set-word-prop
: http-delete ( url -- response data )
<delete-request> http-request ;
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
-"debugger" "http.client.debugger" require-when
+{ "http.client" "debugger" } "http.client.debugger" require-when
-USING: images.bitmap images.bitmap.loading images.testing kernel ;
+USING: images.bitmap images.testing kernel ;
IN: images.bitmap.tests
! "vocab:images/testing/bmp/1bit.bmp" decode-test
USING: accessors alien alien.c-types arrays byte-arrays columns
combinators compression.run-length endian fry grouping images
images.loader images.normalization io io.binary
-io.encodings.binary io.encodings.string io.files
-io.streams.limited kernel locals macros math math.bitwise
-math.functions namespaces sequences specialized-arrays
-strings summary ;
+io.encodings.8-bit.latin1 io.encodings.binary
+io.encodings.string io.files io.streams.limited kernel locals
+macros math math.bitwise math.functions namespaces sequences
+specialized-arrays summary ;
+QUALIFIED-WITH: bitstreams b
SPECIALIZED-ARRAYS: uint ushort ;
IN: images.bitmap
+! http://www.fileformat.info/format/bmp/egff.htm
+! http://www.digicamsoft.com/bmp/bmp.html
+
SINGLETON: bmp-image
"bmp" bmp-image register-image-class
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
+ERROR: unknown-component-order bitmap ;
+ERROR: unknown-bitmap-header n ;
+
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
+
+TUPLE: loading-bitmap
+ file-header header
+ color-palette color-index bitfields ;
+
+TUPLE: file-header
+ { magic initial: "BM" }
+ { size }
+ { reserved1 initial: 0 }
+ { reserved2 initial: 0 }
+ { offset }
+ { header-length } ;
+
+TUPLE: v3-header
+ { width initial: 0 }
+ { height initial: 0 }
+ { planes initial: 0 }
+ { bit-count initial: 0 }
+ { compression initial: 0 }
+ { image-size initial: 0 }
+ { x-resolution initial: 0 }
+ { y-resolution initial: 0 }
+ { colors-used initial: 0 }
+ { colors-important initial: 0 } ;
+
+TUPLE: v4-header < v3-header
+ { red-mask initial: 0 }
+ { green-mask initial: 0 }
+ { blue-mask initial: 0 }
+ { alpha-mask initial: 0 }
+ { cs-type initial: 0 }
+ { end-points initial: 0 }
+ { gamma-red initial: 0 }
+ { gamma-green initial: 0 }
+ { gamma-blue initial: 0 } ;
+
+TUPLE: v5-header < v4-header
+ { intent initial: 0 }
+ { profile-data initial: 0 }
+ { profile-size initial: 0 }
+ { reserved3 initial: 0 } ;
+
+TUPLE: os2v1-header
+ { width initial: 0 }
+ { height initial: 0 }
+ { planes initial: 0 }
+ { bit-count initial: 0 } ;
+
+TUPLE: os2v2-header < os2v1-header
+ { compression initial: 0 }
+ { image-size initial: 0 }
+ { x-resolution initial: 0 }
+ { y-resolution initial: 0 }
+ { colors-used initial: 0 }
+ { colors-important initial: 0 }
+ { units initial: 0 }
+ { reserved initial: 0 }
+ { recording initial: 0 }
+ { rendering initial: 0 }
+ { size1 initial: 0 }
+ { size2 initial: 0 }
+ { color-encoding initial: 0 }
+ { identifier initial: 0 } ;
+
+UNION: v-header v3-header v4-header v5-header ;
+UNION: os2-header os2v1-header os2v2-header ;
+
+: parse-file-header ( -- file-header )
+ \ file-header new
+ 2 read latin1 decode >>magic
+ read4 >>size
+ read2 >>reserved1
+ read2 >>reserved2
+ read4 >>offset
+ read4 >>header-length ;
+
+: read-v3-header-data ( header -- header )
+ read4 >>width
+ read4 32 >signed >>height
+ read2 >>planes
+ read2 >>bit-count
+ read4 >>compression
+ read4 >>image-size
+ read4 >>x-resolution
+ read4 >>y-resolution
+ read4 >>colors-used
+ read4 >>colors-important ;
+
+: read-v3-header ( -- header )
+ \ v3-header new
+ read-v3-header-data ;
+
+: read-v4-header-data ( header -- header )
+ read4 >>red-mask
+ read4 >>green-mask
+ read4 >>blue-mask
+ read4 >>alpha-mask
+ read4 >>cs-type
+ read4 read4 read4 3array >>end-points
+ read4 >>gamma-red
+ read4 >>gamma-green
+ read4 >>gamma-blue ;
+
+: read-v4-header ( -- v4-header )
+ \ v4-header new
+ read-v3-header-data
+ read-v4-header-data ;
+
+: read-v5-header-data ( v5-header -- v5-header )
+ read4 >>intent
+ read4 >>profile-data
+ read4 >>profile-size
+ read4 >>reserved3 ;
+
+: read-v5-header ( -- loading-bitmap )
+ \ v5-header new
+ read-v3-header-data
+ read-v4-header-data
+ read-v5-header-data ;
+
+: read-os2v1-header ( -- os2v1-header )
+ \ os2v1-header new
+ read2 >>width
+ read2 16 >signed >>height
+ read2 >>planes
+ read2 >>bit-count ;
+
+: read-os2v2-header-data ( os2v2-header -- os2v2-header )
+ read4 >>width
+ read4 32 >signed >>height
+ read2 >>planes
+ read2 >>bit-count
+ read4 >>compression
+ read4 >>image-size
+ read4 >>x-resolution
+ read4 >>y-resolution
+ read4 >>colors-used
+ read4 >>colors-important
+ read2 >>units
+ read2 >>reserved
+ read2 >>recording
+ read2 >>rendering
+ read4 >>size1
+ read4 >>size2
+ read4 >>color-encoding
+ read4 >>identifier ;
+
+: read-os2v2-header ( -- os2v2-header )
+ \ os2v2-header new
+ read-os2v2-header-data ;
+
+: parse-header ( n -- header )
+ {
+ { 12 [ read-os2v1-header ] }
+ { 64 [ read-os2v2-header ] }
+ { 40 [ read-v3-header ] }
+ { 108 [ read-v4-header ] }
+ { 124 [ read-v5-header ] }
+ [ unknown-bitmap-header ]
+ } case ;
+
+: color-index-length ( header -- n )
+ {
+ [ width>> ]
+ [ planes>> * ]
+ [ bit-count>> * 31 + 32 /i 4 * ]
+ [ height>> abs * ]
+ } cleave ;
+
+: color-palette-length ( loading-bitmap -- n )
+ file-header>>
+ [ offset>> 14 - ] [ header-length>> ] bi - ;
+
+: parse-color-palette ( loading-bitmap -- loading-bitmap )
+ dup color-palette-length read >>color-palette ;
+
+GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
+
+: parse-color-data ( loading-bitmap -- loading-bitmap )
+ dup header>> parse-color-data* ;
+
+M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
+ color-index-length read >>color-index ;
+
+M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
+ dup image-size>> [ 0 ] unless* dup 0 >
+ [ nip ] [ drop color-index-length ] if read >>color-index ;
+
+: alpha-used? ( loading-bitmap -- ? )
+ color-index>> 4 <sliced-groups> [ fourth 0 = ] all? not ;
+
+GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
+
+: bitmap>component-order ( loading-bitmap -- object )
+ dup header>> bitmap>component-order* ;
+
+: simple-bitmap>component-order ( loading-bitamp -- object )
+ header>> bit-count>> {
+ { 32 [ BGRX ] }
+ { 24 [ BGR ] }
+ { 16 [ BGR ] }
+ { 8 [ BGR ] }
+ { 4 [ BGR ] }
+ { 1 [ BGR ] }
+ [ unknown-component-order ]
+ } case ;
+
+: advanced-bitmap>component-order ( loading-bitmap -- object )
+ [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
+ { { 32 t } [ drop BGRA ] }
+ { { 32 f } [ drop BGRX ] }
+ [ drop simple-bitmap>component-order ]
+ } case ;
+
+: color-lookup3 ( loading-bitmap -- seq )
+ [ color-index>> >array ]
+ [ color-palette>> 3 <sliced-groups> ] bi
+ '[ _ nth ] map concat ;
+
+: color-lookup4 ( loading-bitmap -- seq )
+ [ color-index>> >array ]
+ [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
+ '[ _ nth ] map concat ;
+
+! os2v1 is 3bytes each, all others are 3 + 1 unused
+: color-lookup ( loading-bitmap -- seq )
+ dup file-header>> header-length>> {
+ { 12 [ color-lookup3 ] }
+ { 64 [ color-lookup4 ] }
+ { 40 [ color-lookup4 ] }
+ { 108 [ color-lookup4 ] }
+ { 124 [ color-lookup4 ] }
+ } case ;
+
+M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
+M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
+
+: uncompress-bitfield ( seq masks -- bytes' )
+ '[
+ _ [
+ [ bitand ] [ bit-count ] [ log2 ] tri - shift
+ ] with map
+ ] { } map-as B{ } concat-as ;
+
+ERROR: bmp-not-supported n ;
+
+: bitmap>bytes ( loading-bitmap -- byte-array )
+ dup header>> bit-count>>
+ {
+ { 32 [ color-index>> ] }
+ { 24 [ color-index>> ] }
+ { 16 [
+ [
+ ! byte-array>ushort-array
+ 2 group [ le> ] map
+ ! 5 6 5
+ ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
+ ! 5 5 5
+ { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
+ ] change-color-index
+ color-index>>
+ ] }
+ { 8 [ color-lookup ] }
+ { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
+ { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
+ [ bmp-not-supported ]
+ } case >byte-array ;
+
+: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+ dup header>> bit-count>> {
+ { 16 [ dup color-palette>> 4 group [ le> ] map ] }
+ { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
+ } case reverse >>bitfields ;
+
+ERROR: unsupported-bitfield-widths n ;
+
+M: unsupported-bitfield-widths summary
+ drop "Bitmaps only support bitfield compression in 16/32bit images" ;
+
+: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+ set-bitfield-widths
+ dup header>> bit-count>> {
+ { 16 [
+ dup bitfields>> '[
+ byte-array>ushort-array _ uncompress-bitfield
+ ] change-color-index
+ ] }
+ { 32 [ ] }
+ [ unsupported-bitfield-widths ]
+ } case ;
+
+ERROR: unsupported-bitmap-compression compression ;
+
+GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
+
+: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
+ dup header>> uncompress-bitmap* ;
+
+M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+ drop ;
+
+: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
+ dupd '[
+ _ header>> [ width>> ] [ height>> ] bi
+ _ execute
+ ] change-color-index ; inline
+
+M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+ compression>> {
+ { f [ ] }
+ { 0 [ ] }
+ { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
+ { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
+ { 3 [ uncompress-bitfield-widths ] }
+ { 4 [ "jpeg" unsupported-bitmap-compression ] }
+ { 5 [ "png" unsupported-bitmap-compression ] }
+ } case ;
+
+ERROR: unsupported-bitmap-file magic ;
+
+: load-bitmap ( stream -- loading-bitmap )
+ [
+ \ loading-bitmap new
+ parse-file-header [ >>file-header ] [ ] bi magic>> {
+ { "BM" [
+ dup file-header>> header-length>> parse-header >>header
+ parse-color-palette
+ parse-color-data
+ ] }
+ ! { "BA" [ parse-os2-bitmap-array ] }
+ ! { "CI" [ parse-os2-color-icon ] }
+ ! { "CP" [ parse-os2-color-pointer ] }
+ ! { "IC" [ parse-os2-icon ] }
+ ! { "PT" [ parse-os2-pointer ] }
+ [ unsupported-bitmap-file ]
+ } case
+ ] with-input-stream ;
+
+: loading-bitmap>bytes ( loading-bitmap -- byte-array )
+ uncompress-bitmap bitmap>bytes ;
+
+M: bmp-image stream>image ( stream bmp-image -- bitmap )
+ drop load-bitmap
+ [ image new ] dip
+ {
+ [ loading-bitmap>bytes >>bitmap ]
+ [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
+ [ header>> height>> 0 < not >>upside-down? ]
+ [ bitmap>component-order >>component-order ubyte-components >>component-type ]
+ } cleave ;
+
: output-width-and-height ( image -- )
[ dim>> first write4 ]
[
io.binary io.encodings.binary
io.encodings.string io.streams.limited kernel math math.bitwise
io.encodings.8-bit.latin1 sequences specialized-arrays summary images.bitmap ;
-QUALIFIED-WITH: bitstreams b
-SPECIALIZED-ARRAY: ushort
-IN: images.bitmap.loading
-
-! http://www.fileformat.info/format/bmp/egff.htm
-! http://www.digicamsoft.com/bmp/bmp.html
-
-ERROR: unknown-component-order bitmap ;
-ERROR: unknown-bitmap-header n ;
-
-: read2 ( -- n ) 2 read le> ;
-: read4 ( -- n ) 4 read le> ;
-
-TUPLE: loading-bitmap
- file-header header
- color-palette color-index bitfields ;
-
-TUPLE: file-header
- { magic initial: "BM" }
- { size }
- { reserved1 initial: 0 }
- { reserved2 initial: 0 }
- { offset }
- { header-length } ;
-
-TUPLE: v3-header
- { width initial: 0 }
- { height initial: 0 }
- { planes initial: 0 }
- { bit-count initial: 0 }
- { compression initial: 0 }
- { image-size initial: 0 }
- { x-resolution initial: 0 }
- { y-resolution initial: 0 }
- { colors-used initial: 0 }
- { colors-important initial: 0 } ;
-
-TUPLE: v4-header < v3-header
- { red-mask initial: 0 }
- { green-mask initial: 0 }
- { blue-mask initial: 0 }
- { alpha-mask initial: 0 }
- { cs-type initial: 0 }
- { end-points initial: 0 }
- { gamma-red initial: 0 }
- { gamma-green initial: 0 }
- { gamma-blue initial: 0 } ;
-
-TUPLE: v5-header < v4-header
- { intent initial: 0 }
- { profile-data initial: 0 }
- { profile-size initial: 0 }
- { reserved3 initial: 0 } ;
-
-TUPLE: os2v1-header
- { width initial: 0 }
- { height initial: 0 }
- { planes initial: 0 }
- { bit-count initial: 0 } ;
-
-TUPLE: os2v2-header < os2v1-header
- { compression initial: 0 }
- { image-size initial: 0 }
- { x-resolution initial: 0 }
- { y-resolution initial: 0 }
- { colors-used initial: 0 }
- { colors-important initial: 0 }
- { units initial: 0 }
- { reserved initial: 0 }
- { recording initial: 0 }
- { rendering initial: 0 }
- { size1 initial: 0 }
- { size2 initial: 0 }
- { color-encoding initial: 0 }
- { identifier initial: 0 } ;
-
-UNION: v-header v3-header v4-header v5-header ;
-UNION: os2-header os2v1-header os2v2-header ;
-
-: parse-file-header ( -- file-header )
- \ file-header new
- 2 read latin1 decode >>magic
- read4 >>size
- read2 >>reserved1
- read2 >>reserved2
- read4 >>offset
- read4 >>header-length ;
-
-: read-v3-header-data ( header -- header )
- read4 >>width
- read4 32 >signed >>height
- read2 >>planes
- read2 >>bit-count
- read4 >>compression
- read4 >>image-size
- read4 >>x-resolution
- read4 >>y-resolution
- read4 >>colors-used
- read4 >>colors-important ;
-
-: read-v3-header ( -- header )
- \ v3-header new
- read-v3-header-data ;
-
-: read-v4-header-data ( header -- header )
- read4 >>red-mask
- read4 >>green-mask
- read4 >>blue-mask
- read4 >>alpha-mask
- read4 >>cs-type
- read4 read4 read4 3array >>end-points
- read4 >>gamma-red
- read4 >>gamma-green
- read4 >>gamma-blue ;
-
-: read-v4-header ( -- v4-header )
- \ v4-header new
- read-v3-header-data
- read-v4-header-data ;
-
-: read-v5-header-data ( v5-header -- v5-header )
- read4 >>intent
- read4 >>profile-data
- read4 >>profile-size
- read4 >>reserved3 ;
-
-: read-v5-header ( -- loading-bitmap )
- \ v5-header new
- read-v3-header-data
- read-v4-header-data
- read-v5-header-data ;
-
-: read-os2v1-header ( -- os2v1-header )
- \ os2v1-header new
- read2 >>width
- read2 16 >signed >>height
- read2 >>planes
- read2 >>bit-count ;
-
-: read-os2v2-header-data ( os2v2-header -- os2v2-header )
- read4 >>width
- read4 32 >signed >>height
- read2 >>planes
- read2 >>bit-count
- read4 >>compression
- read4 >>image-size
- read4 >>x-resolution
- read4 >>y-resolution
- read4 >>colors-used
- read4 >>colors-important
- read2 >>units
- read2 >>reserved
- read2 >>recording
- read2 >>rendering
- read4 >>size1
- read4 >>size2
- read4 >>color-encoding
- read4 >>identifier ;
-
-: read-os2v2-header ( -- os2v2-header )
- \ os2v2-header new
- read-os2v2-header-data ;
-
-: parse-header ( n -- header )
- {
- { 12 [ read-os2v1-header ] }
- { 64 [ read-os2v2-header ] }
- { 40 [ read-v3-header ] }
- { 108 [ read-v4-header ] }
- { 124 [ read-v5-header ] }
- [ unknown-bitmap-header ]
- } case ;
-
-: color-index-length ( header -- n )
- {
- [ width>> ]
- [ planes>> * ]
- [ bit-count>> * 31 + 32 /i 4 * ]
- [ height>> abs * ]
- } cleave ;
-
-: color-palette-length ( loading-bitmap -- n )
- file-header>>
- [ offset>> 14 - ] [ header-length>> ] bi - ;
-
-: parse-color-palette ( loading-bitmap -- loading-bitmap )
- dup color-palette-length read >>color-palette ;
-
-GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
-
-: parse-color-data ( loading-bitmap -- loading-bitmap )
- dup header>> parse-color-data* ;
-
-M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
- color-index-length read >>color-index ;
-
-M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
- dup image-size>> [ 0 ] unless* dup 0 >
- [ nip ] [ drop color-index-length ] if read >>color-index ;
-
-: alpha-used? ( loading-bitmap -- ? )
- color-index>> 4 <sliced-groups> [ fourth 0 = ] all? not ;
-
-GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
-
-: bitmap>component-order ( loading-bitmap -- object )
- dup header>> bitmap>component-order* ;
-
-: simple-bitmap>component-order ( loading-bitamp -- object )
- header>> bit-count>> {
- { 32 [ BGRX ] }
- { 24 [ BGR ] }
- { 16 [ BGR ] }
- { 8 [ BGR ] }
- { 4 [ BGR ] }
- { 1 [ BGR ] }
- [ unknown-component-order ]
- } case ;
-
-: advanced-bitmap>component-order ( loading-bitmap -- object )
- [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
- { { 32 t } [ drop BGRA ] }
- { { 32 f } [ drop BGRX ] }
- [ drop simple-bitmap>component-order ]
- } case ;
-
-: color-lookup3 ( loading-bitmap -- seq )
- [ color-index>> >array ]
- [ color-palette>> 3 <sliced-groups> ] bi
- '[ _ nth ] map concat ;
-
-: color-lookup4 ( loading-bitmap -- seq )
- [ color-index>> >array ]
- [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
- '[ _ nth ] map concat ;
-
-! os2v1 is 3bytes each, all others are 3 + 1 unused
-: color-lookup ( loading-bitmap -- seq )
- dup file-header>> header-length>> {
- { 12 [ color-lookup3 ] }
- { 64 [ color-lookup4 ] }
- { 40 [ color-lookup4 ] }
- { 108 [ color-lookup4 ] }
- { 124 [ color-lookup4 ] }
- } case ;
-
-M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
-M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
-M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
-M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
-M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
-
-: uncompress-bitfield ( seq masks -- bytes' )
- '[
- _ [
- [ bitand ] [ bit-count ] [ log2 ] tri - shift
- ] with map
- ] { } map-as B{ } concat-as ;
-
-ERROR: bmp-not-supported n ;
-
-: bitmap>bytes ( loading-bitmap -- byte-array )
- dup header>> bit-count>>
- {
- { 32 [ color-index>> ] }
- { 24 [ color-index>> ] }
- { 16 [
- [
- ! byte-array>ushort-array
- 2 group [ le> ] map
- ! 5 6 5
- ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
- ! 5 5 5
- { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
- ] change-color-index
- color-index>>
- ] }
- { 8 [ color-lookup ] }
- { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
- { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
- [ bmp-not-supported ]
- } case >byte-array ;
-
-: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
- dup header>> bit-count>> {
- { 16 [ dup color-palette>> 4 group [ le> ] map ] }
- { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
- } case reverse >>bitfields ;
-
-ERROR: unsupported-bitfield-widths n ;
-
-M: unsupported-bitfield-widths summary
- drop "Bitmaps only support bitfield compression in 16/32bit images" ;
-
-: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
- set-bitfield-widths
- dup header>> bit-count>> {
- { 16 [
- dup bitfields>> '[
- byte-array>ushort-array _ uncompress-bitfield
- ] change-color-index
- ] }
- { 32 [ ] }
- [ unsupported-bitfield-widths ]
- } case ;
-
-ERROR: unsupported-bitmap-compression compression ;
-
-GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
-
-: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
- dup header>> uncompress-bitmap* ;
-
-M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
- drop ;
-
-: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
- dupd '[
- _ header>> [ width>> ] [ height>> ] bi
- _ execute
- ] change-color-index ; inline
-
-M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
- compression>> {
- { f [ ] }
- { 0 [ ] }
- { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
- { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
- { 3 [ uncompress-bitfield-widths ] }
- { 4 [ "jpeg" unsupported-bitmap-compression ] }
- { 5 [ "png" unsupported-bitmap-compression ] }
- } case ;
-
-ERROR: unsupported-bitmap-file magic ;
-
-: load-bitmap ( stream -- loading-bitmap )
- [
- \ loading-bitmap new
- parse-file-header [ >>file-header ] [ ] bi magic>> {
- { "BM" [
- dup file-header>> header-length>> parse-header >>header
- parse-color-palette
- parse-color-data
- ] }
- ! { "BA" [ parse-os2-bitmap-array ] }
- ! { "CI" [ parse-os2-color-icon ] }
- ! { "CP" [ parse-os2-color-pointer ] }
- ! { "IC" [ parse-os2-icon ] }
- ! { "PT" [ parse-os2-pointer ] }
- [ unsupported-bitmap-file ]
- } case
- ] with-input-stream ;
-
-: loading-bitmap>bytes ( loading-bitmap -- byte-array )
- uncompress-bitmap bitmap>bytes ;
-
-M: bmp-image stream>image ( stream bmp-image -- bitmap )
- drop load-bitmap
- [ image new ] dip
- {
- [ loading-bitmap>bytes >>bitmap ]
- [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
- [ header>> height>> 0 < not >>upside-down? ]
- [ bitmap>component-order >>component-order ubyte-components >>component-type ]
- } cleave ;
! 1>x
[ B{ 255 255 } ]
-[ B{ 0 1 } A L permute ] unit-test
+[ B{ 0 1 } 2 2 A L permute ] unit-test
[ B{ 255 255 255 255 } ]
-[ B{ 0 1 } A RG permute ] unit-test
+[ B{ 0 1 } 2 2 A RG permute ] unit-test
[ B{ 255 255 255 255 255 255 } ]
-[ B{ 0 1 } A BGR permute ] unit-test
+[ B{ 0 1 } 2 2 A BGR permute ] unit-test
[ B{ 0 255 255 255 1 255 255 255 } ]
-[ B{ 0 1 } A ABGR permute ] unit-test
+[ B{ 0 1 } 2 2 A ABGR permute ] unit-test
+
+! Difference stride
+! The last byte is padding, so it should not end up in the image
+
+[ B{ 255 255 } ]
+[ B{ 0 1 0 } 2 3 A L permute ] unit-test
+
+[ B{ 255 255 255 255 } ]
+[ B{ 0 1 0 } 2 3 A RG permute ] unit-test
+
+[ B{ 255 255 255 255 255 255 } ]
+[ B{ 0 1 0 } 2 3 A BGR permute ] unit-test
+
+[ B{ 0 255 255 255 1 255 255 255 } ]
+[ B{ 0 1 0 } 2 3 A ABGR permute ] unit-test
! 2>x
[ B{ 0 2 } ]
-[ B{ 0 1 2 3 } LA L permute ] unit-test
+[ B{ 0 1 2 3 } 2 4 LA L permute ] unit-test
[ B{ 255 255 255 255 } ]
-[ B{ 0 1 2 3 } LA RG permute ] unit-test
+[ B{ 0 1 2 3 } 2 4 LA RG permute ] unit-test
[ B{ 255 255 255 255 255 255 } ]
-[ B{ 0 1 2 3 } LA BGR permute ] unit-test
+[ B{ 0 1 2 3 } 2 4 LA BGR permute ] unit-test
[ B{ 1 255 255 255 3 255 255 255 } ]
-[ B{ 0 1 2 3 } LA ABGR permute ] unit-test
+[ B{ 0 1 2 3 } 2 4 LA ABGR permute ] unit-test
! 3>x
[ B{ 255 255 } ]
-[ B{ 0 1 2 3 4 5 } RGB L permute ] unit-test
+[ B{ 0 1 2 3 4 5 } 2 6 RGB L permute ] unit-test
[ B{ 0 1 3 4 } ]
-[ B{ 0 1 2 3 4 5 } RGB RG permute ] unit-test
+[ B{ 0 1 2 3 4 5 } 2 6 RGB RG permute ] unit-test
[ B{ 2 1 0 5 4 3 } ]
-[ B{ 0 1 2 3 4 5 } RGB BGR permute ] unit-test
+[ B{ 0 1 2 3 4 5 } 2 6 RGB BGR permute ] unit-test
[ B{ 255 2 1 0 255 5 4 3 } ]
-[ B{ 0 1 2 3 4 5 } RGB ABGR permute ] unit-test
+[ B{ 0 1 2 3 4 5 } 2 6 RGB ABGR permute ] unit-test
! 4>x
[ B{ 255 255 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA L permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA L permute ] unit-test
[ B{ 0 1 4 5 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA RG permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA RG permute ] unit-test
[ B{ 2 1 0 6 5 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA BGR permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA BGR permute ] unit-test
[ B{ 3 2 1 0 7 6 5 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA ABGR permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA ABGR permute ] unit-test
! Edge cases
[ B{ 0 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA R permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA R permute ] unit-test
[ B{ 255 0 1 2 255 4 5 6 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA XRGB permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA XRGB permute ] unit-test
[ B{ 1 2 3 255 5 6 7 255 } ]
-[ B{ 0 1 2 3 4 5 6 7 } XRGB RGBA permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 XRGB RGBA permute ] unit-test
[ B{ 255 255 255 255 255 255 255 255 } ]
-[ B{ 0 1 } L RGBA permute ] unit-test
+[ B{ 0 1 } 2 2 L RGBA permute ] unit-test
! Invalid inputs
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types byte-arrays combinators fry
grouping images kernel locals math math.vectors
-sequences specialized-arrays half-floats ;
+sequences specialized-arrays math.floats.half ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: half
SPECIALIZED-ARRAY: float
dup 4 >= [ drop fill-value ] [ _ nth ] if
] B{ } map-as ;
-:: permute ( bytes src-order dst-order -- new-bytes )
+:: permute ( bytes width stride src-order dst-order -- new-bytes )
src-order name>> :> src
dst-order name>> :> dst
- bytes src length group
- [ pad4 src dst permutation shuffle dst length head ]
- map concat ;
+ bytes stride group
+ [
+ src length group width head
+ [ pad4 src dst permutation shuffle dst length head ] map concat
+ ] map concat ;
+
+: stride ( image -- n )
+ [ bitmap>> length ] [ dim>> second ] bi / ;
: (reorder-components) ( image src-order dest-order -- image )
- [ permute ] 2curry change-bitmap ;
+ [ [ ] [ dim>> first ] [ stride ] tri ] 2dip
+ '[ _ _ _ _ permute ] change-bitmap ;
GENERIC: normalize-component-type* ( image component-type -- image )
! Copyright (C) 2008 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.parser arrays io.encodings sequences kernel assocs
-hashtables io.encodings.ascii generic parser classes.tuple words
-words.symbol io io.files splitting namespaces math
-compiler.units accessors classes.singleton classes.mixin
-io.encodings.iana fry simple-flat-file lexer ;
+USING: arrays assocs biassocs kernel io.encodings math.parser
+sequences hashtables io.encodings.ascii generic parser
+classes.tuple words words.symbol io io.files splitting
+namespaces math compiler.units accessors classes.singleton
+classes.mixin io.encodings.iana fry simple-flat-file lexer ;
IN: io.encodings.8-bit
<PRIVATE
SYMBOL: 8-bit-encodings
8-bit-encodings [ H{ } clone ] initialize
-TUPLE: 8-bit biassoc ;
+TUPLE: 8-bit { biassoc biassoc read-only } ;
-: encode-8-bit ( char stream assoc -- )
- swapd value-at
- [ swap stream-write1 ] [ encode-error ] if* ; inline
+: 8-bit-encode ( char 8-bit -- byte )
+ biassoc>> value-at [ encode-error ] unless* ; inline
-M: 8-bit encode-char biassoc>> encode-8-bit ;
+M: 8-bit encode-char
+ swap [ 8-bit-encode ] dip stream-write1 ;
-: decode-8-bit ( stream assoc -- char/f )
- swap stream-read1
- [ swap at [ replacement-char ] unless* ]
- [ drop f ] if* ; inline
+M: 8-bit encode-string
+ swap [ '[ _ 8-bit-encode ] B{ } map-as ] dip stream-write ;
-M: 8-bit decode-char biassoc>> decode-8-bit ;
+M: 8-bit decode-char
+ swap stream-read1 dup
+ [ swap biassoc>> at [ replacement-char ] unless* ]
+ [ 2drop f ]
+ if ;
MIXIN: 8-bit-encoding
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings kernel math io.encodings.private ;
+USING: accessors byte-arrays io io.encodings
+io.encodings.private kernel math sequences ;
IN: io.encodings.ascii
-<PRIVATE
-: encode-if< ( char stream encoding max -- )
- nip 1 - pick < [ encode-error ] [ stream-write1 ] if ; inline
-
-: decode-if< ( stream encoding max -- character )
- nip swap stream-read1 dup
- [ [ nip ] [ > ] 2bi [ >fixnum ] [ drop replacement-char ] if ]
- [ 2drop f ] if ; inline
-PRIVATE>
-
SINGLETON: ascii
M: ascii encode-char
- 128 encode-if< ; inline
+ drop
+ over 127 <= [ stream-write1 ] [ encode-error ] if ; inline
+
+M: ascii encode-string
+ drop
+ [
+ dup aux>>
+ [ [ dup 127 <= [ encode-error ] unless ] B{ } map-as ]
+ [ >byte-array ]
+ if
+ ] dip
+ stream-write ;
M: ascii decode-char
- 128 decode-if< ; inline
+ drop
+ stream-read1 dup [
+ dup 127 <= [ >fixnum ] [ drop replacement-char ] if
+ ] when ; inline
] in-thread
p 1 seconds ?promise-timeout handle>> kill-process*
- s ?promise 0 =
+ s 3 seconds ?promise-timeout 0 =
]
] unit-test
: write-in-groups ( byte-array port -- )
[ binary-object <direct-uchar-array> ] dip
- [ buffer>> size>> <groups> ] [ '[ _ stream-write ] ] bi
+ [ buffer>> size>> <sliced-groups> ] [ '[ _ stream-write ] ] bi
each ;
M: output-port stream-write
HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } ;
HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
-
-HINTS: encoder-write { object output-port utf8 } { object output-port ascii } ;
}
}
{ $notes
- "To accept UDP/IP packets from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "f 1234 <inet> resolve-host" }
- "To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "\"localhost\" 1234 <inet> resolve-host" }
+ "To accept UDP/IP packets from any host, use an address specifier where the host name is set to " { $link f } ":"
+ { $code "f 1234 <inet4> <datagram>" }
+ "To create a datagram socket bound to a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the datagram instance to obtain the actual port number it is bound to:"
+ { $code "f 0 <inet4> <datagram>" }
+ "To accept UDP/IP packets from the loopback interface only, use an address specifier like the following:"
+ { $code "\"127.0.0.1\" 1234 <inet4> <datagram>s" }
"Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly."
- "Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding"
}
{ $errors "Throws an error if the port is already in use, or if the OS forbids access." } ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien byte-vectors io kernel libc math sequences ;
+IN: io.streams.byte-array.fast
+
+! This is split off from io.streams.byte-array because it uses
+! memcpy, which is a non-core word that only works after the
+! optimizing compiler has been loaded.
+
+M: byte-vector stream-write
+ [ dup byte-length tail-slice ]
+ [ [ [ byte-length ] bi@ + ] keep lengthen ]
+ [ drop byte-length ]
+ 2tri
+ [ >c-ptr swap >c-ptr ] dip memcpy ;
"locals.fry"
} [ require ] each
-"prettyprint" "locals.definitions" require-when
-"prettyprint" "locals.prettyprint" require-when
+{ "locals" "prettyprint" } "locals.definitions" require-when
+{ "locals" "prettyprint" } "locals.prettyprint" require-when
--- /dev/null
+USING: accessors alien.c-types alien.syntax math.floats.half kernel
+math tools.test specialized-arrays alien.data classes.struct ;
+SPECIALIZED-ARRAY: half
+IN: math.floats.half.tests
+
+[ HEX: 0000 ] [ 0.0 half>bits ] unit-test
+[ HEX: 8000 ] [ -0.0 half>bits ] unit-test
+[ HEX: 3e00 ] [ 1.5 half>bits ] unit-test
+[ HEX: be00 ] [ -1.5 half>bits ] unit-test
+[ HEX: 7c00 ] [ 1/0. half>bits ] unit-test
+[ HEX: fc00 ] [ -1/0. half>bits ] unit-test
+[ HEX: 7eaa ] [ NAN: aaaaaaaaaaaaa half>bits ] unit-test
+
+! too-big floats overflow to infinity
+[ HEX: 7c00 ] [ 65536.0 half>bits ] unit-test
+[ HEX: fc00 ] [ -65536.0 half>bits ] unit-test
+[ HEX: 7c00 ] [ 131072.0 half>bits ] unit-test
+[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test
+
+! too-small floats flush to zero
+[ HEX: 0000 ] [ 1.0e-9 half>bits ] unit-test
+[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test
+
+[ 0.0 ] [ HEX: 0000 bits>half ] unit-test
+[ -0.0 ] [ HEX: 8000 bits>half ] unit-test
+[ 1.5 ] [ HEX: 3e00 bits>half ] unit-test
+[ -1.5 ] [ HEX: be00 bits>half ] unit-test
+[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test
+[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
+[ 3.0 ] [ HEX: 4200 bits>half ] unit-test
+[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
+
+STRUCT: halves
+ { tom half }
+ { dick half }
+ { harry half }
+ { harry-jr half } ;
+
+[ 8 ] [ halves heap-size ] unit-test
+
+[ 3.0 ] [
+ halves <struct>
+ 3.0 >>dick
+ dick>>
+] unit-test
+
+[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ]
+[ { 1.0 2.0 3.0 1/0. -1/0. } >half-array ] unit-test
+
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.accessors alien.c-types alien.data
+alien.syntax kernel math math.order ;
+FROM: math => float ;
+IN: math.floats.half
+
+: half>bits ( float -- bits )
+ float>bits
+ [ -31 shift 15 shift ] [
+ HEX: 7fffffff bitand
+ dup zero? [
+ dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [
+ -13 shift
+ 112 10 shift -
+ 0 HEX: 7c00 clamp
+ ] if
+ ] unless
+ ] bi bitor ;
+
+: bits>half ( bits -- float )
+ [ -15 shift 31 shift ] [
+ HEX: 7fff bitand
+ dup zero? [
+ dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [
+ 13 shift
+ 112 23 shift +
+ ] if
+ ] unless
+ ] bi bitor bits>float ;
+
+SYMBOL: half
+
+<<
+
+<c-type>
+ float >>class
+ float >>boxed-class
+ [ alien-unsigned-2 bits>half ] >>getter
+ [ [ >float half>bits ] 2dip set-alien-unsigned-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ 2 >>align-first
+ [ >float ] >>unboxer-quot
+\ half define-primitive-type
+
+>>
--- /dev/null
+Half-precision float support for FFI
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 } { 0 1 } p- ." "{ 1 0 1 }" } } ;
HELP: n*p
-{ $values { "n" number } { "p" "a polynomial" } { "n*p" "a polynomial" } }
+{ $values { "n" number } { "v" "a polynomial" } { "w" "a polynomial" } }
{ $description "Multiplies each element of " { $snippet "p" } " by " { $snippet "n" } "." }
{ $examples { $example "USING: math.polynomials prettyprint ;" "4 { 3 0 1 } n*p ." "{ 12 0 4 }" } } ;
HELP: pextend-conv
{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p'" "a polynomial" } { "q'" "a polynomial" } }
{ $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." }
-{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv [ . ] bi@" "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ;
+{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv [ . ] bi@" "{ 1 0 1 0 }\n{ 0 1 0 0 }" } } ;
HELP: p*
{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel make math math.order math.vectors sequences
-splitting vectors macros combinators math.bits ;
+USING: arrays combinators fry kernel macros make math math.bits
+math.order math.vectors sequences splitting vectors ;
IN: math.polynomials
<PRIVATE
: 2ptrim ( p q -- p' q' ) [ ptrim ] bi@ ;
: p+ ( p q -- r ) pextend v+ ;
: p- ( p q -- r ) pextend v- ;
-: n*p ( n p -- n*p ) n*v ;
+ALIAS: n*p n*v
: pextend-conv ( p q -- p' q' )
- 2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
+ 2dup [ length ] bi@ + 1 - 2pad-tail ;
: p* ( p q -- r )
- 2unempty pextend-conv <reversed> dup length iota
- [ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
+ 2unempty pextend-conv
+ [ drop length [ iota ] keep ]
+ [ nip <reversed> ]
+ [ drop ] 2tri
+ '[ _ _ <slice> _ v* sum ] map reverse ;
-: p-sq ( p -- p^2 )
- dup p* ;
+: p-sq ( p -- p^2 ) dup p* ; inline
ERROR: negative-power-polynomial p n ;
dup 1 < [ drop 1 ] when
[ over length + 0 pad-head pextend ] keep 1 + ;
-: /-last ( seq seq -- a )
- #! divide the last two numbers in the sequences
- [ last ] bi@ / ;
+: /-last ( seq1 seq2 -- x ) [ last ] bi@ / ;
: (p/mod) ( p p -- p p )
2dup /-last
<PRIVATE
: (pgcd) ( b a y x -- a d )
- dup V{ 0 } clone p= [
+ dup V{ 0 } p= [
drop nip
] [
[ nip ] [ p/mod ] 2bi
USE: vocabs.loader
-"prettyprint" "math.rectangles.prettyprint" require-when
+{ "math.rectangles" "prettyprint" } "math.rectangles.prettyprint" require-when
BOA-EFFECT define-inline
: A-with ( n -- v )
- [ A/2-with ] [ A/2-with ] bi cord-append ;
+ [ A/2-with ] [ A/2-with ] bi cord-append ; inline
: A-cast ( v -- v' )
- [ A/2-cast ] cord-map ;
+ [ A/2-cast ] cord-map ; inline
M: A >pprint-sequence ;
M: A pprint* pprint-object ;
@
[ dup [ class ] { } map-as ] dip '[ _ declare @ ]
{
- [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
+ [ "print-mr" get [ nip regs. ] [ 2drop ] if ]
[ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
[ [ [ call ] dip call ] call( quot quot -- result ) ]
[ [ [ call ] dip compile-call ] call( quot quot -- result ) ]
M: int-4 v*hs+
int-4-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op longlong-2-cast ; inline
-"mirrors" "math.vectors.simd.mirrors" require-when
+{ "math.vectors.simd" "mirrors" } "math.vectors.simd.mirrors" require-when
GENERIC: (vmerge-tail) ( u v -- t )
M: object (vmerge-tail) over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ; inline
-GENERIC: (vmerge) ( u v -- h t )
-M: object (vmerge)
+: (vmerge) ( u v -- h t )
[ (vmerge-head) ] [ (vmerge-tail) ] 2bi ; inline
GENERIC: vmerge ( u v -- w )
LIBRARY: pango
-C-ENUM: PangoStyle
+ENUM: PangoStyle
PANGO_STYLE_NORMAL
PANGO_STYLE_OBLIQUE
PANGO_STYLE_ITALIC ;
] append!
] ;
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
-"debugger" "peg.debugger" require-when
+{ "debugger" "peg" } "peg.debugger" require-when
SYNTAX: R{ CHAR: } parsing-regexp ;
SYNTAX: R| CHAR: | parsing-regexp ;
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
-"prettyprint" "regexp.prettyprint" require-when
+{ "prettyprint" "regexp" } "regexp.prettyprint" require-when
[ ] [
[
struct-resize-test specialized-array-vocab forget-vocab
+ \ struct-resize-test-usage forget
] with-compilation-unit
] unit-test
SYNTAX: SPECIALIZED-ARRAY:
scan-c-type define-array-vocab use-vocab ;
-"prettyprint" "specialized-arrays.prettyprint" require-when
+{ "specialized-arrays" "prettyprint" } "specialized-arrays.prettyprint" require-when
-"mirrors" "specialized-arrays.mirrors" require-when
+{ "specialized-arrays" "mirrors" } "specialized-arrays.mirrors" require-when
ERROR: unbalanced-branches-error < inference-error word quots declareds actuals ;
-"debugger" "stack-checker.errors.prettyprint" require-when
+{ "stack-checker.errors" "debugger" } "stack-checker.errors.prettyprint" require-when
\ both-fixnums? { object object } { object } define-primitive
\ byte-array>bignum { byte-array } { bignum } define-primitive \ byte-array>bignum make-foldable
\ callstack { } { callstack } define-primitive \ callstack make-flushable
+\ callstack-bounds { } { alien alien } define-primitive \ callstack-bounds make-flushable
\ callstack-for { c-ptr } { callstack } define-primitive \ callstack make-flushable
\ callstack>array { callstack } { array } define-primitive \ callstack>array make-flushable
\ check-datastack { array integer integer } { object } define-primitive \ check-datastack make-flushable
\ set-slot { object object fixnum } { } define-primitive
\ set-special-object { object fixnum } { } define-primitive
\ set-string-nth-fast { fixnum fixnum string } { } define-primitive
-\ set-string-nth-slow { fixnum fixnum string } { } define-primitive
\ size { object } { fixnum } define-primitive \ size make-flushable
\ slot { object fixnum } { object } define-primitive \ slot make-flushable
\ special-object { fixnum } { object } define-primitive \ special-object make-flushable
-\ string-nth { fixnum string } { fixnum } define-primitive \ string-nth make-flushable
+\ string-nth-fast { fixnum string } { fixnum } define-primitive \ string-nth-fast make-flushable
\ strip-stack-traces { } { } define-primitive
\ system-micros { } { integer } define-primitive \ system-micros make-flushable
\ tag { object } { fixnum } define-primitive \ tag make-foldable
sequences.private words memory kernel.private continuations io
vocabs.loader system strings sets vectors quotations byte-arrays
sorting compiler.units definitions generic generic.standard
-generic.single tools.deploy.config combinators classes
+generic.single tools.deploy.config combinators classes vocabs.loader.private
classes.builtin slots.private grouping command-line io.pathnames ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes.private
lexer-factory
print-use-hook
root-cache
+ require-when-vocabs
+ require-when-table
source-files.errors:error-types
source-files.errors:error-observers
vocabs:dictionary
USING: namespaces tools.deploy.config fry sequences system kernel ui ui.gadgets.worlds ;
deploy-name get "Factor" or '[
- _ " encountered an unhandled error." append
- "The application will now exit."
+ _ " encountered an error." append
+ "The application encountered an error it cannot recover from and will now exit."
system-alert die
] ui-error-hook set-global
tools.disassembler words ;
IN: typed.debugger
-: typed-test-mr ( word -- mrs )
- "typed-word" word-prop test-mr ; inline
-: typed-test-mr. ( word -- )
- "typed-word" word-prop test-mr mr. ; inline
+M: typed-word test-builder
+ "typed-word" word-prop test-builder ;
+
: typed-optimized. ( word -- )
- "typed-word" word-prop optimized. ; inline
+ "typed-word" word-prop optimized. ;
-: typed-disassemble ( word -- )
- "typed-word" word-prop disassemble ; inline
+M: typed-word disassemble ( word -- )
+ "typed-word" word-prop disassemble ;
SYNTAX: TYPED::
(::) define-typed ;
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
-"prettyprint" "typed.prettyprint" require-when
+{ "typed" "prettyprint" } "typed.prettyprint" require-when
+{ "typed" "compiler.cfg.debugger" } "typed.debugger" require-when
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
[ drop window ]
2tri send-button-up ;
-: send-wheel$ ( view event -- )
- [ nip [ -> deltaX ] [ -> deltaY ] bi [ sgn neg ] bi@ 2array ]
+: send-scroll$ ( view event -- )
+ [ nip [ -> deltaX ] [ -> deltaY ] bi [ neg ] bi@ 2array ]
[ mouse-location ]
[ drop window ]
- 2tri send-wheel ;
+ 2tri send-scroll ;
: send-action$ ( view event gesture -- junk )
[ drop window ] dip send-action f ;
}
{ "scrollWheel:" void { id SEL id }
- [ nip send-wheel$ ]
+ [ nip send-scroll$ ]
}
{ "keyDown:" void { id SEL id }
! Copyright (C) 2005, 2006 Doug Coleman.
-! Portions copyright (C) 2007, 2009 Slava Pestov.
+! Portions copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs ui
ui.private ui.gadgets ui.gadgets.private ui.backend
message>button nc-buttons get
swap [ push ] [ remove! drop ] if ;
-: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
+: mouse-scroll ( wParam -- array )
+ >lo-hi [ -120 /f ] map ;
: mouse-event>gesture ( uMsg -- button )
key-modifiers swap message>button
>lo-hi swap window move-hand fire-motion ;
:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
- wParam mouse-wheel hand-loc get hWnd window send-wheel ;
+ wParam mouse-scroll hand-loc get hWnd window send-scroll ;
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
#! message sent if windows needs application to stop dragging
f ClipCursor drop
1 ShowCursor drop ;
-CONSTANT: fullscreen-flags { WS_CAPTION WS_BORDER WS_THICKFRAME }
+CONSTANT: fullscreen-flags flags{ WS_CAPTION WS_BORDER WS_THICKFRAME }
: enter-fullscreen ( world -- )
handle>> hWnd>>
-! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types ascii assocs classes.struct combinators
combinators.short-circuit command-line environment io.encodings.ascii
{ 7 { 1 0 } }
} at ;
-M: world wheel-event
+M: world scroll-event
[ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
- send-wheel ;
+ send-scroll ;
M: world enter-event motion-event ;
[ dup CHAR: ' = [ drop "'\\''" ] [ 1string ] if ] { } map-as concat ;
: xmessage ( string -- )
- escape-' "/usr/X11R6/bin/xmessage '" "'" surround system drop ;
+ escape-' "/usr/bin/env xmessage '" "'" surround system drop ;
PRIVATE>
M: x11-ui-backend system-alert
USE: vocabs.loader
-"prettyprint" "ui.gadgets.prettyprint" require-when
+{ "ui.gadgets" "prettyprint" } "ui.gadgets.prettyprint" require-when
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math namespaces sequences
vectors models models.range math.vectors math.functions quotations
: <slider> ( range orientation -- slider )
slider new-track
swap >>model
- 32 >>line
+ 16 >>line
dup orientation>> {
[ <slider-pen> >>interior ]
[ <thumb> >>thumb ]
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables math.parser
stop-drag-timer
button-gesture ;
-: send-wheel ( direction loc world -- )
+: send-scroll ( direction loc world -- )
move-hand
scroll-direction set-global
mouse-scroll hand-gadget get-global propagate-gesture ;
<PRIVATE
! Grapheme breaks
-C-ENUM: f Any L V T LV LVT Extend Control CR LF
- SpacingMark Prepend graphemes ;
+CONSTANT: Any 0
+CONSTANT: L 1
+CONSTANT: V 2
+CONSTANT: T 3
+CONSTANT: LV 4
+CONSTANT: LVT 5
+CONSTANT: Extend 6
+CONSTANT: Control 7
+CONSTANT: CR 8
+CONSTANT: LF 9
+CONSTANT: SpacingMark 10
+CONSTANT: Prepend 11
+CONSTANT: graphemes 12
: jamo-class ( ch -- class )
dup initial? [ drop L ]
"vocab:unicode/data/WordBreakProperty.txt" load-interval-file
to: word-break-table
-C-ENUM: f wOther wCR wLF wNewline wExtend wFormat wKatakana wALetter wMidLetter
-wMidNum wMidNumLet wNumeric wExtendNumLet words ;
+CONSTANT: wOther 0
+CONSTANT: wCR 1
+CONSTANT: wLF 2
+CONSTANT: wNewline 3
+CONSTANT: wExtend 4
+CONSTANT: wFormat 5
+CONSTANT: wKatakana 6
+CONSTANT: wALetter 7
+CONSTANT: wMidLetter 8
+CONSTANT: wMidNum 9
+CONSTANT: wMidNumLet 10
+CONSTANT: wNumeric 11
+CONSTANT: wExtendNumLet 12
+CONSTANT: words 13
: word-break-classes ( -- table ) ! Is there a way to avoid this?
H{
<<
-"debugger" "unix.debugger" require-when
+{ "unix" "debugger" } "unix.debugger" require-when
>>
USE: vocabs.loader
-"prettyprint" "urls.prettyprint" require-when
+{ "urls" "prettyprint" } "urls.prettyprint" require-when
: vm-field-offset ( field -- offset ) vm offset-of ; inline
-C-ENUM: f
-collect-nursery-op
-collect-aging-op
-collect-to-tenured-op
-collect-full-op
-collect-compact-op
-collect-growing-heap-op ;
+CONSTANT: collect-nursery-op 0
+CONSTANT: collect-aging-op 1
+CONSTANT: collect-to-tenured-op 2
+CONSTANT: collect-full-op 3
+CONSTANT: collect-compact-op 4
+CONSTANT: collect-growing-heap-op 5
STRUCT: copying-sizes
{ size cell }
CONSTANT: TokenSandBoxInert 15
! } TOKEN_INFORMATION_CLASS;
-C-ENUM: ACCESS_MODE
+ENUM: ACCESS_MODE
NOT_USED_ACCESS
GRANT_ACCESS
SET_ACCESS
SET_AUDIT_SUCCESS
SET_AUDIT_FAILURE ;
-C-ENUM: MULTIPLE_TRUSTEE_OPERATION
+ENUM: MULTIPLE_TRUSTEE_OPERATION
NO_MULTIPLE_TRUSTEE
TRUSTEE_IS_IMPERSONATE ;
-C-ENUM: TRUSTEE_FORM
+ENUM: TRUSTEE_FORM
TRUSTEE_IS_SID
TRUSTEE_IS_NAME
TRUSTEE_BAD_FORM
TRUSTEE_IS_OBJECTS_AND_SID
TRUSTEE_IS_OBJECTS_AND_NAME ;
-C-ENUM: TRUSTEE_TYPE
+ENUM: TRUSTEE_TYPE
TRUSTEE_IS_UNKNOWN
TRUSTEE_IS_USER
TRUSTEE_IS_GROUP
TRUSTEE_IS_INVALID
TRUSTEE_IS_COMPUTER ;
-C-ENUM: SE_OBJECT_TYPE
+ENUM: SE_OBJECT_TYPE
SE_UNKNOWN_OBJECT_TYPE
SE_FILE_OBJECT
SE_SERVICE
USE: vocabs.loader
-"prettyprint" "windows.com.prettyprint" require-when
+{ "windows.com" "prettyprint" } "windows.com.prettyprint" require-when
CONSTANT: HIDP_LINK_COLLECTION_ROOT -1
CONSTANT: HIDP_LINK_COLLECTION_UNSPECIFIED 0
-C-ENUM: HIDP_REPORT_TYPE
+ENUM: HIDP_REPORT_TYPE
HidP_Input
HidP_Output
HidP_Feature ;
ULONG UsageListLength
) ;
-C-ENUM: HIDP_KEYBOARD_DIRECTION
+ENUM: HIDP_KEYBOARD_DIRECTION
HidP_Keyboard_Break
HidP_Keyboard_Make ;
FUNCTION: BOOL SetupRemoveFileLogEntryW ( HSPFILELOG FileLogHandle, PCWSTR LogSectionName, PCWSTR TargetFilename ) ;
ALIAS: SetupRemoveFileLogEntry SetupRemoveFileLogEntryW
-C-ENUM: SetupFileLogInfo
+ENUM: SetupFileLogInfo
SetupFileLogSourceFilename
SetupFileLogChecksum
SetupFileLogDiskTagfile
{ iInterface UCHAR } ;
TYPEDEF: USB_INTERFACE_DESCRIPTOR* PUSB_INTERFACE_DESCRIPTOR
-C-ENUM: USBD_PIPE_TYPE
+ENUM: USBD_PIPE_TYPE
UsbdPipeTypeControl
UsbdPipeTypeIsochronous
UsbdPipeTypeBulk
CONSTANT: D3D11_RETURN_TYPE_CONTINUED 8
TYPEDEF: int D3D11_RESOURCE_RETURN_TYPE
-C-ENUM: D3D11_CBUFFER_TYPE
+ENUM: D3D11_CBUFFER_TYPE
D3D11_CT_CBUFFER
D3D11_CT_TBUFFER
D3D11_CT_INTERFACE_POINTERS
CONSTANT: MAXD3DDECLUSAGEINDEX 15
CONSTANT: MAXD3DDECLLENGTH 64
-C-ENUM: D3DDECLMETHOD
+ENUM: D3DDECLMETHOD
D3DDECLMETHOD_DEFAULT
D3DDECLMETHOD_PARTIALU
D3DDECLMETHOD_PARTIALV
HRESULT ForwardTransform ( ID3D11UnorderedAccessView* pInputBuffer, ID3D11UnorderedAccessView** ppOutputBuffer )
HRESULT InverseTransform ( ID3D11UnorderedAccessView* pInputBuffer, ID3D11UnorderedAccessView** ppOutputBuffer ) ;
-C-ENUM: D3DX11_FFT_DATA_TYPE
+ENUM: D3DX11_FFT_DATA_TYPE
D3DX11_FFT_DATA_TYPE_REAL
D3DX11_FFT_DATA_TYPE_COMPLEX ;
{ UsageIndex UINT } ;
TYPEDEF: D3DXSEMANTIC* LPD3DXSEMANTIC
-C-ENUM: D3DXREGISTER_SET
+ENUM: D3DXREGISTER_SET
D3DXRS_BOOL
D3DXRS_INT4
D3DXRS_FLOAT4
D3DXRS_SAMPLER ;
TYPEDEF: D3DXREGISTER_SET* LPD3DXREGISTER_SET
-C-ENUM: D3DXPARAMETER_CLASS
+ENUM: D3DXPARAMETER_CLASS
D3DXPC_SCALAR
D3DXPC_VECTOR
D3DXPC_MATRIX_ROWS
D3DXPC_STRUCT ;
TYPEDEF: D3DXPARAMETER_CLASS* LPD3DXPARAMETER_CLASS
-C-ENUM: D3DXPARAMETER_TYPE
+ENUM: D3DXPARAMETER_TYPE
D3DXPT_VOID
D3DXPT_BOOL
D3DXPT_INT
HRESULT SetMatrixTransposeArray ( D3DXHANDLE hConstant, D3DXMATRIX* pMatrix, UINT Count )
HRESULT SetMatrixTransposePointerArray ( D3DXHANDLE hConstant, D3DXMATRIX** ppMatrix, UINT Count ) ;
-C-ENUM: D3DXINCLUDE_TYPE
+ENUM: D3DXINCLUDE_TYPE
D3DXINC_LOCAL
D3DXINC_SYSTEM ;
TYPEDEF: D3DXINCLUDE_TYPE* LPD3DXINCLUDE_TYPE
USING: alien.c-types alien.syntax ;
IN: windows.directx.dcommon
-C-ENUM: DWRITE_MEASURING_MODE
+ENUM: DWRITE_MEASURING_MODE
DWRITE_MEASURING_MODE_NATURAL
DWRITE_MEASURING_MODE_GDI_CLASSIC
DWRITE_MEASURING_MODE_GDI_NATURAL ;
kernel system namespaces combinators sequences fry math accessors
macros words quotations libc continuations generalizations
splitting locals assocs init specialized-arrays memoize
-classes.struct strings arrays ;
+classes.struct strings arrays literals ;
SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT
IN: windows.directx.dinput.constants
<PRIVATE
+<<
+
MEMO: c-type* ( name -- c-type ) c-type ;
MEMO: heap-size* ( c-type -- n ) heap-size ;
GENERIC: array-base-type ( c-type -- c-type' )
M: object array-base-type ;
-M: string array-base-type "[" split1 drop ;
M: array array-base-type first ;
: (field-spec-of) ( field struct -- field-spec )
: (flags) ( array -- n )
0 [ (flag) bitor ] reduce ;
-: <DIOBJECTDATAFORMAT> ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- alien )
+: <DIOBJECTDATAFORMAT>-quot ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- quot )
{
- [ first dup word? [ get ] when ]
+ [ drop f ]
[ second rot [ (offsetof) ] [ (sizeof) ] 2bi ]
[ third * + ]
[ fourth (flags) ]
[ 4 swap nth (flag) ]
+ [ first dup word? [ '[ _ get ] ] [ drop [ f ] ] if ]
} cleave
- DIOBJECTDATAFORMAT <struct-boa> ;
+ [ DIOBJECTDATAFORMAT <struct-boa> ] dip
+ '[ _ clone @ >>pguid ] ;
-:: make-DIOBJECTDATAFORMAT-array ( struct array -- alien )
- array length malloc-DIOBJECTDATAFORMAT-array :> alien
+:: make-DIOBJECTDATAFORMAT-array-quot ( struct array -- quot )
+ array length '[ _ malloc-DIOBJECTDATAFORMAT-array ]
array [| args i |
- struct args <DIOBJECTDATAFORMAT>
- i alien set-nth
- ] each-index
- alien ;
+ struct args <DIOBJECTDATAFORMAT>-quot
+ i '[ _ pick set-nth ] compose compose
+ ] each-index ;
-: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
- [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
- [ nip length ] [ make-DIOBJECTDATAFORMAT-array ] 2bi
- DIDATAFORMAT <struct-boa> ;
+>>
-: initialize ( symbol quot -- )
- call swap set-global ; inline
+MACRO: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
+ [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
+ [ nip length ] [ make-DIOBJECTDATAFORMAT-array-quot ] 2bi
+ '[ _ _ _ _ _ @ DIDATAFORMAT <struct-boa> ] ;
: (malloc-guid-symbol) ( symbol guid -- )
- '[ _ execute( -- value ) malloc-byte-array ] initialize ;
+ '[ _ malloc-byte-array ] initialize ;
: define-guid-constants ( -- )
{
- { GUID_XAxis_malloced GUID_XAxis }
- { GUID_YAxis_malloced GUID_YAxis }
- { GUID_ZAxis_malloced GUID_ZAxis }
- { GUID_RxAxis_malloced GUID_RxAxis }
- { GUID_RyAxis_malloced GUID_RyAxis }
- { GUID_RzAxis_malloced GUID_RzAxis }
- { GUID_Slider_malloced GUID_Slider }
- { GUID_Button_malloced GUID_Button }
- { GUID_Key_malloced GUID_Key }
- { GUID_POV_malloced GUID_POV }
- { GUID_Unknown_malloced GUID_Unknown }
- { GUID_SysMouse_malloced GUID_SysMouse }
- { GUID_SysKeyboard_malloced GUID_SysKeyboard }
- { GUID_Joystick_malloced GUID_Joystick }
- { GUID_SysMouseEm_malloced GUID_SysMouseEm }
- { GUID_SysMouseEm2_malloced GUID_SysMouseEm2 }
- { GUID_SysKeyboardEm_malloced GUID_SysKeyboardEm }
- { GUID_SysKeyboardEm2_malloced GUID_SysKeyboardEm2 }
+ { GUID_XAxis_malloced $ GUID_XAxis }
+ { GUID_YAxis_malloced $ GUID_YAxis }
+ { GUID_ZAxis_malloced $ GUID_ZAxis }
+ { GUID_RxAxis_malloced $ GUID_RxAxis }
+ { GUID_RyAxis_malloced $ GUID_RyAxis }
+ { GUID_RzAxis_malloced $ GUID_RzAxis }
+ { GUID_Slider_malloced $ GUID_Slider }
+ { GUID_Button_malloced $ GUID_Button }
+ { GUID_Key_malloced $ GUID_Key }
+ { GUID_POV_malloced $ GUID_POV }
+ { GUID_Unknown_malloced $ GUID_Unknown }
+ { GUID_SysMouse_malloced $ GUID_SysMouse }
+ { GUID_SysKeyboard_malloced $ GUID_SysKeyboard }
+ { GUID_Joystick_malloced $ GUID_Joystick }
+ { GUID_SysMouseEm_malloced $ GUID_SysMouseEm }
+ { GUID_SysMouseEm2_malloced $ GUID_SysMouseEm2 }
+ { GUID_SysKeyboardEm_malloced $ GUID_SysKeyboardEm }
+ { GUID_SysKeyboardEm2_malloced $ GUID_SysKeyboardEm2 }
} [ first2 (malloc-guid-symbol) ] each ;
: define-joystick-format-constant ( -- )
c_dfDIJoystick2 [
DIDF_ABSAXIS
- DIJOYSTATE2 heap-size
+ $[ DIJOYSTATE2 heap-size ]
DIJOYSTATE2 {
{ GUID_XAxis_malloced "lX" 0 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } 0 }
{ GUID_YAxis_malloced "lY" 0 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } 0 }
: define-mouse-format-constant ( -- )
c_dfDIMouse2 [
DIDF_RELAXIS
- DIMOUSESTATE2 heap-size
+ $[ DIMOUSESTATE2 heap-size ]
DIMOUSESTATE2 {
{ GUID_XAxis_malloced "lX" 0 { DIDFT_ANYINSTANCE DIDFT_AXIS } 0 }
{ GUID_YAxis_malloced "lY" 0 { DIDFT_ANYINSTANCE DIDFT_AXIS } 0 }
[ define-constants ] "windows.directx.dinput.constants" add-startup-hook
: uninitialize ( variable quot -- )
- '[ _ when* f ] change-global ; inline
+ [ '[ _ when* f ] change-global ]
+ [ drop global delete-at ] 2bi ; inline
: free-dinput-constants ( -- )
{
LIBRARY: dwrite
-C-ENUM: DWRITE_FONT_FILE_TYPE
+ENUM: DWRITE_FONT_FILE_TYPE
DWRITE_FONT_FILE_TYPE_UNKNOWN
DWRITE_FONT_FILE_TYPE_CFF
DWRITE_FONT_FILE_TYPE_TRUETYPE
DWRITE_FONT_FILE_TYPE_VECTOR
DWRITE_FONT_FILE_TYPE_BITMAP ;
-C-ENUM: DWRITE_FONT_FACE_TYPE
+ENUM: DWRITE_FONT_FACE_TYPE
DWRITE_FONT_FACE_TYPE_CFF
DWRITE_FONT_FACE_TYPE_TRUETYPE
DWRITE_FONT_FACE_TYPE_TRUETYPE_COLLECTION
DWRITE_FONT_FACE_TYPE_BITMAP
DWRITE_FONT_FACE_TYPE_UNKNOWN ;
-C-ENUM: DWRITE_FONT_SIMULATIONS
+ENUM: DWRITE_FONT_SIMULATIONS
DWRITE_FONT_SIMULATIONS_NONE
DWRITE_FONT_SIMULATIONS_BOLD
DWRITE_FONT_SIMULATIONS_OBLIQUE ;
-C-ENUM: DWRITE_FONT_WEIGHT
+ENUM: DWRITE_FONT_WEIGHT
{ DWRITE_FONT_WEIGHT_THIN 100 }
{ DWRITE_FONT_WEIGHT_EXTRA_LIGHT 200 }
{ DWRITE_FONT_WEIGHT_ULTRA_LIGHT 200 }
{ DWRITE_FONT_WEIGHT_EXTRA_BLACK 950 }
{ DWRITE_FONT_WEIGHT_ULTRA_BLACK 950 } ;
-C-ENUM: DWRITE_FONT_STRETCH
+ENUM: DWRITE_FONT_STRETCH
{ DWRITE_FONT_STRETCH_UNDEFINED 0 }
{ DWRITE_FONT_STRETCH_ULTRA_CONDENSED 1 }
{ DWRITE_FONT_STRETCH_EXTRA_CONDENSED 2 }
{ DWRITE_FONT_STRETCH_EXTRA_EXPANDED 8 }
{ DWRITE_FONT_STRETCH_ULTRA_EXPANDED 9 } ;
-C-ENUM: DWRITE_FONT_STYLE
+ENUM: DWRITE_FONT_STYLE
DWRITE_FONT_STYLE_NORMAL
DWRITE_FONT_STYLE_OBLIQUE
DWRITE_FONT_STYLE_ITALIC ;
-C-ENUM: DWRITE_INFORMATIONAL_STRING_ID
+ENUM: DWRITE_INFORMATIONAL_STRING_ID
DWRITE_INFORMATIONAL_STRING_NONE
DWRITE_INFORMATIONAL_STRING_COPYRIGHT_NOTICE
DWRITE_INFORMATIONAL_STRING_VERSION_STRINGS
{ advanceOffset FLOAT }
{ ascenderOffset FLOAT } ;
-C-ENUM: DWRITE_FACTORY_TYPE
+ENUM: DWRITE_FACTORY_TYPE
DWRITE_FACTORY_TYPE_SHARED
DWRITE_FACTORY_TYPE_ISOLATED ;
HRESULT GetLoader ( IDWriteFontFileLoader** fontFileLoader )
HRESULT Analyze ( BOOL* isSupportedFontType, DWRITE_FONT_FILE_TYPE* fontFileType, DWRITE_FONT_FACE_TYPE* fontFaceType, UINT32* numberOfFaces ) ;
-C-ENUM: DWRITE_PIXEL_GEOMETRY
+ENUM: DWRITE_PIXEL_GEOMETRY
DWRITE_PIXEL_GEOMETRY_FLAT
DWRITE_PIXEL_GEOMETRY_RGB
DWRITE_PIXEL_GEOMETRY_BGR ;
-C-ENUM: DWRITE_RENDERING_MODE
+ENUM: DWRITE_RENDERING_MODE
DWRITE_RENDERING_MODE_DEFAULT
DWRITE_RENDERING_MODE_ALIASED
DWRITE_RENDERING_MODE_CLEARTYPE_GDI_CLASSIC
HRESULT HasCharacter ( UINT32 unicodeValue, BOOL* exists )
HRESULT CreateFontFace ( IDWriteFontFace** fontFace ) ;
-C-ENUM: DWRITE_READING_DIRECTION
+ENUM: DWRITE_READING_DIRECTION
DWRITE_READING_DIRECTION_LEFT_TO_RIGHT
DWRITE_READING_DIRECTION_RIGHT_TO_LEFT ;
-C-ENUM: DWRITE_FLOW_DIRECTION
+ENUM: DWRITE_FLOW_DIRECTION
DWRITE_FLOW_DIRECTION_TOP_TO_BOTTOM ;
-C-ENUM: DWRITE_TEXT_ALIGNMENT
+ENUM: DWRITE_TEXT_ALIGNMENT
DWRITE_TEXT_ALIGNMENT_LEADING
DWRITE_TEXT_ALIGNMENT_TRAILING
DWRITE_TEXT_ALIGNMENT_CENTER ;
-C-ENUM: DWRITE_PARAGRAPH_ALIGNMENT
+ENUM: DWRITE_PARAGRAPH_ALIGNMENT
DWRITE_PARAGRAPH_ALIGNMENT_NEAR
DWRITE_PARAGRAPH_ALIGNMENT_FAR
DWRITE_PARAGRAPH_ALIGNMENT_CENTER ;
-C-ENUM: DWRITE_WORD_WRAPPING
+ENUM: DWRITE_WORD_WRAPPING
DWRITE_WORD_WRAPPING_WRAP
DWRITE_WORD_WRAPPING_NO_WRAP ;
-C-ENUM: DWRITE_LINE_SPACING_METHOD
+ENUM: DWRITE_LINE_SPACING_METHOD
DWRITE_LINE_SPACING_METHOD_DEFAULT
DWRITE_LINE_SPACING_METHOD_UNIFORM ;
-C-ENUM: DWRITE_TRIMMING_GRANULARITY
+ENUM: DWRITE_TRIMMING_GRANULARITY
DWRITE_TRIMMING_GRANULARITY_NONE
DWRITE_TRIMMING_GRANULARITY_CHARACTER
DWRITE_TRIMMING_GRANULARITY_WORD ;
UINT32 GetFontFeatureCount ( )
HRESULT GetFontFeature ( UINT32 fontFeatureIndex, DWRITE_FONT_FEATURE* fontFeature ) ;
-C-ENUM: DWRITE_SCRIPT_SHAPES
+ENUM: DWRITE_SCRIPT_SHAPES
DWRITE_SCRIPT_SHAPES_DEFAULT
DWRITE_SCRIPT_SHAPES_NO_VISUAL ;
{ script USHORT }
{ shapes DWRITE_SCRIPT_SHAPES } ;
-C-ENUM: DWRITE_BREAK_CONDITION
+ENUM: DWRITE_BREAK_CONDITION
DWRITE_BREAK_CONDITION_NEUTRAL
DWRITE_BREAK_CONDITION_CAN_BREAK
DWRITE_BREAK_CONDITION_MAY_NOT_BREAK
STRUCT: DWRITE_LINE_BREAKPOINT
{ data BYTE } ;
-C-ENUM: DWRITE_NUMBER_SUBSTITUTION_METHOD
+ENUM: DWRITE_NUMBER_SUBSTITUTION_METHOD
DWRITE_NUMBER_SUBSTITUTION_METHOD_FROM_CULTURE
DWRITE_NUMBER_SUBSTITUTION_METHOD_CONTEXTUAL
DWRITE_NUMBER_SUBSTITUTION_METHOD_NONE
HRESULT CreateFontFaceFromHdc ( HDC hdc, IDWriteFontFace** fontFace )
HRESULT CreateBitmapRenderTarget ( HDC hdc, UINT32 width, UINT32 height, IDWriteBitmapRenderTarget** renderTarget ) ;
-C-ENUM: DWRITE_TEXTURE_TYPE
+ENUM: DWRITE_TEXTURE_TYPE
DWRITE_TEXTURE_ALIASED_1x1
DWRITE_TEXTURE_CLEARTYPE_3x1 ;
{ Numerator UINT }
{ Denominator UINT } ;
-C-ENUM: DXGI_MODE_SCANLINE_ORDER
+ENUM: DXGI_MODE_SCANLINE_ORDER
DXGI_MODE_SCANLINE_ORDER_UNSPECIFIED
DXGI_MODE_SCANLINE_ORDER_PROGRESSIVE
DXGI_MODE_SCANLINE_ORDER_UPPER_FIELD_FIRST
DXGI_MODE_SCANLINE_ORDER_LOWER_FIELD_FIRST ;
-C-ENUM: DXGI_MODE_SCALING
+ENUM: DXGI_MODE_SCALING
DXGI_MODE_SCALING_UNSPECIFIED
DXGI_MODE_SCALING_CENTERED
DXGI_MODE_SCALING_STRETCHED ;
-C-ENUM: DXGI_MODE_ROTATION
+ENUM: DXGI_MODE_ROTATION
DXGI_MODE_ROTATION_UNSPECIFIED
DXGI_MODE_ROTATION_IDENTITY
DXGI_MODE_ROTATION_ROTATE90
{ pFormat WAVEFORMATEX* }
{ MaxFrameCount UINT32 } ;
-C-ENUM: XAPO_BUFFER_FLAGS
+ENUM: XAPO_BUFFER_FLAGS
XAPO_BUFFER_SILENT
XAPO_BUFFER_VALID ;
{ EffectCount UINT32 }
{ pEffectDescriptors XAUDIO2_EFFECT_DESCRIPTOR* } ;
-C-ENUM: XAUDIO2_FILTER_TYPE
+ENUM: XAUDIO2_FILTER_TYPE
LowPassFilter
BandPassFilter
HighPassFilter
USING: alien.data kernel locals math math.bitwise
windows.kernel32 sequences byte-arrays unicode.categories
io.encodings.string io.encodings.utf16n alien.strings
-arrays literals windows.types specialized-arrays ;
+arrays literals windows.types specialized-arrays
+math.parser ;
SPECIALIZED-ARRAY: TCHAR
IN: windows.errors
: make-lang-id ( lang1 lang2 -- n )
10 shift bitor ; inline
-ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
flags{
FORMAT_MESSAGE_FROM_SYSTEM
id
LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
32768 [ TCHAR <c-array> ] [ ] bi
- f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip
- utf16n alien>string [ blank? ] trim ;
+ f pick [ FormatMessage ] dip
+ swap zero?
+ [ drop "Unknown error 0x" id HEX: ffff,ffff bitand >hex append ]
+ [ utf16n alien>string [ blank? ] trim ] if ;
: win32-error-string ( -- str )
GetLastError n>win32-error-string ;
CONSTANT: THREAD_PRIORITY_NORMAL 0
CONSTANT: THREAD_PRIORITY_TIME_CRITICAL 15
-C-ENUM: COMPUTER_NAME_FORMAT
+ENUM: COMPUTER_NAME_FORMAT
ComputerNameNetBIOS
ComputerNameDnsHostname
ComputerNameDnsDomain
int* piLogicalToVisual
) ;
-C-ENUM: f
- SCRIPT_JUSTIFY_NONE
- SCRIPT_JUSTIFY_ARABIC_BLANK
- SCRIPT_JUSTIFY_CHARACTER
- SCRIPT_JUSTIFY_RESERVED1
- SCRIPT_JUSTIFY_BLANK
- SCRIPT_JUSTIFY_RESERVED2
- SCRIPT_JUSTIFY_RESERVED3
- SCRIPT_JUSTIFY_ARABIC_NORMAL
- SCRIPT_JUSTIFY_ARABIC_KASHIDA
- SCRIPT_JUSTIFY_ALEF
- SCRIPT_JUSTIFY_HA
- SCRIPT_JUSTIFY_RA
- SCRIPT_JUSTIFY_BA
- SCRIPT_JUSTIFY_BARA
- SCRIPT_JUSTIFY_SEEN
- SCRIPT_JUSTIFFY_RESERVED4 ;
+CONSTANT: SCRIPT_JUSTIFY_NONE 0
+CONSTANT: SCRIPT_JUSTIFY_ARABIC_BLANK 1
+CONSTANT: SCRIPT_JUSTIFY_CHARACTER 2
+CONSTANT: SCRIPT_JUSTIFY_RESERVED1 3
+CONSTANT: SCRIPT_JUSTIFY_BLANK 4
+CONSTANT: SCRIPT_JUSTIFY_RESERVED2 5
+CONSTANT: SCRIPT_JUSTIFY_RESERVED3 6
+CONSTANT: SCRIPT_JUSTIFY_ARABIC_NORMAL 7
+CONSTANT: SCRIPT_JUSTIFY_ARABIC_KASHIDA 8
+CONSTANT: SCRIPT_JUSTIFY_ALEF 9
+CONSTANT: SCRIPT_JUSTIFY_HA 10
+CONSTANT: SCRIPT_JUSTIFY_RA 11
+CONSTANT: SCRIPT_JUSTIFY_BA 12
+CONSTANT: SCRIPT_JUSTIFY_BARA 13
+CONSTANT: SCRIPT_JUSTIFY_SEEN 14
+CONSTANT: SCRIPT_JUSTIFFY_RESERVED4 15
STRUCT: SCRIPT_VISATTR
{ flags WORD } ;
! * EXTENDED WINDOW MANAGER HINTS
! *****************************************************************
-C-ENUM: f _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ;
+CONSTANT: _NET_WM_STATE_REMOVE 0
+CONSTANT: _NET_WM_STATE_ADD 1
+CONSTANT: _NET_WM_STATE_TOGGLE 2
GENERIC: leave-event ( event window -- )
-GENERIC: wheel-event ( event window -- )
+GENERIC: scroll-event ( event window -- )
GENERIC: motion-event ( event window -- )
: events-queued ( mode -- n ) [ dpy get ] dip XEventsQueued ;
-: wheel? ( event -- ? ) button>> 4 7 between? ;
+: mouse-scroll? ( event -- ? ) button>> 4 7 between? ;
: button-down-event$ ( event window -- )
- over wheel? [ wheel-event ] [ button-down-event ] if ;
+ over mouse-scroll? [ scroll-event ] [ button-down-event ] if ;
: button-up-event$ ( event window -- )
- over wheel? [ 2drop ] [ button-up-event ] if ;
+ over mouse-scroll? [ 2drop ] [ button-up-event ] if ;
: handle-event ( event window -- )
swap dup XAnyEvent>> type>> {
: with-x ( display-string quot -- )
[ init-x ] dip [ close-x ] [ ] cleanup ; inline
-"io.backend.unix" "x11.io.unix" require-when
+{ "x11" "io.backend.unix" } "x11.io.unix" require-when
USE: vocabs.loader
-"inverse" "xml.syntax.inverse" require-when
+{ "xml.syntax" "inverse" } "xml.syntax.inverse" require-when
exit_script() {
if [[ $FIND_MAKE_TARGET -eq true ]] ; then
+ # Must be echo not $ECHO
echo $MAKE_TARGET;
fi
exit $1
$ECHO -n "Checking for $i..."
test_program_installed $i
if [[ $? -eq 0 ]]; then
- echo -n "not "
+ $ECHO -n "not "
else
installed=$(( $installed + 1 ))
fi
}
write_test_program() {
+ #! Must be 'echo'
echo "#include <stdio.h>" > $C_WORD.c
echo "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c
}
set_factor_image() {
FACTOR_IMAGE=factor.image
+ FACTOR_IMAGE_FRESH=factor.image.fresh
}
echo_build_info() {
$ECHO "WORD: $WORD"
$ECHO "OS, ARCH, or WORD is empty. Please report this."
- echo $MAKE_TARGET
+ $ECHO $MAKE_TARGET
exit_script 5
fi
}
}
git_clone() {
- echo "Downloading the git repository from factorcode.org..."
+ $ECHO "Downloading the git repository from factorcode.org..."
invoke_git clone $GIT_URL
}
update_script_name() {
- echo `dirname $0`/_update.sh
+ $ECHO `dirname $0`/_update.sh
}
update_script() {
update_script=`update_script_name`
bash_path=`which bash`
- echo "#!$bash_path" >"$update_script"
- echo "git pull \"$GIT_URL\" master" >>"$update_script"
- echo "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \
+ $ECHO "#!$bash_path" >"$update_script"
+ $ECHO "git pull \"$GIT_URL\" master" >>"$update_script"
+ $ECHO "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \
>>"$update_script"
- echo "exit 0" >>"$update_script"
+ $ECHO "exit 0" >>"$update_script"
chmod 755 "$update_script"
exec "$update_script"
}
git_fetch_factorcode() {
- echo "Fetching the git repository from factorcode.org..."
+ $ECHO "Fetching the git repository from factorcode.org..."
rm -f `update_script_name`
invoke_git fetch "$GIT_URL" master
if update_script_changed; then
- echo "Updating and restarting the factor.sh script..."
+ $ECHO "Updating and restarting the factor.sh script..."
update_script
else
- echo "Updating the working tree..."
+ $ECHO "Updating the working tree..."
invoke_git pull "$GIT_URL" master
fi
}
check_makefile_exists() {
if [[ ! -e "GNUmakefile" ]] ; then
- echo ""
- echo "***GNUmakefile not found***"
- echo "You are likely in the wrong directory."
- echo "Run this script from your factor directory:"
- echo " ./build-support/factor.sh"
+ $ECHO ""
+ $ECHO "***GNUmakefile not found***"
+ $ECHO "You are likely in the wrong directory."
+ $ECHO "Run this script from your factor directory:"
+ $ECHO " ./build-support/factor.sh"
exit_script 6
fi
}
}
update_boot_images() {
- echo "Deleting old images..."
+ $ECHO "Deleting old images..."
$DELETE checksums.txt* > /dev/null 2>&1
# delete boot images with one or two characters after the dot
$DELETE $BOOT_IMAGE.{?,??} > /dev/null 2>&1
netbsd) disk_md5=`md5 $BOOT_IMAGE | cut -f4 -d' '`;;
*) disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '` ;;
esac
- echo "Factorcode md5: $factorcode_md5";
- echo "Disk md5: $disk_md5";
+ $ECHO "Factorcode md5: $factorcode_md5";
+ $ECHO "Disk md5: $disk_md5";
if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
- echo "Your disk boot image matches the one on factorcode.org."
+ $ECHO "Your disk boot image matches the one on factorcode.org."
else
$DELETE $BOOT_IMAGE > /dev/null 2>&1
get_boot_image;
}
get_boot_image() {
- echo "Downloading boot image $BOOT_IMAGE."
+ $ECHO "Downloading boot image $BOOT_IMAGE."
get_url http://factorcode.org/images/latest/$BOOT_IMAGE
}
if [[ $DOWNLOADER -eq "" ]] ; then
set_downloader;
fi
- echo $DOWNLOADER $1 ;
+ $ECHO $DOWNLOADER $1 ;
$DOWNLOADER $1
check_ret $DOWNLOADER
}
check_libraries
}
+copy_fresh_image() {
+ $ECHO "Copying $FACTOR_IMAGE to $FACTOR_IMAGE_FRESH..."
+ $COPY $FACTOR_IMAGE $FACTOR_IMAGE_FRESH
+}
+
bootstrap() {
./$FACTOR_BINARY -i=$BOOT_IMAGE
+ copy_fresh_image
}
install() {
test_program_installed git
if [[ $? -ne 1 ]] ; then
ensure_program_installed yes
- echo "git not found."
- echo "This script requires either git-core or port."
- echo "If it fails, install git-core or port and try again."
+ $ECHO "git not found."
+ $ECHO "This script requires either git-core or port."
+ $ECHO "If it fails, install git-core or port and try again."
ensure_program_installed port
- echo "Installing git-core with port...this will take awhile."
+ $ECHO "Installing git-core with port...this will take awhile."
yes | sudo port install git-core
fi
}
usage() {
- echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target|report [optional-target]"
- echo "If you are behind a firewall, invoke as:"
- echo "env GIT_PROTOCOL=http $0 <command>"
- echo ""
- echo "Example for overriding the default target:"
- echo " $0 update macosx-x86-32"
+ $ECHO "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target|report [optional-target]"
+ $ECHO "If you are behind a firewall, invoke as:"
+ $ECHO "env GIT_PROTOCOL=http $0 <command>"
+ $ECHO ""
+ $ECHO "Example for overriding the default target:"
+ $ECHO " $0 update macosx-x86-32"
}
MAKE_TARGET=unknown
[ 1 1 <displaced-alien> ] must-fail
-[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
+[ f ] [ 1 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
-[ f ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
+[ f ] [ 2 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
[ t ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> underlying>> byte-array? ] unit-test
-[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
+[ "( displaced alien )" ] [ 1 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
SYMBOL: initialize-test
{ "fixnum<=" "math.private" (( x y -- z )) }
{ "fixnum>" "math.private" (( x y -- ? )) }
{ "fixnum>=" "math.private" (( x y -- ? )) }
+ { "string-nth-fast" "strings.private" (( n string -- ch )) }
{ "(set-context)" "threads.private" (( obj context -- obj' )) }
{ "(set-context-and-delete)" "threads.private" (( obj context -- * )) }
{ "(start-context)" "threads.private" (( obj quot -- obj' )) }
{ "retainstack" "kernel" "primitive_retainstack" (( -- array )) }
{ "(identity-hashcode)" "kernel.private" "primitive_identity_hashcode" (( obj -- code )) }
{ "become" "kernel.private" "primitive_become" (( old new -- )) }
+ { "callstack-bounds" "kernel.private" "primitive_callstack_bounds" (( -- start end )) }
{ "check-datastack" "kernel.private" "primitive_check_datastack" (( array in# out# -- ? )) }
{ "compute-identity-hashcode" "kernel.private" "primitive_compute_identity_hashcode" (( obj -- )) }
{ "context-object" "kernel.private" "primitive_context_object" (( n -- obj )) }
{ "<string>" "strings" "primitive_string" (( n ch -- string )) }
{ "resize-string" "strings" "primitive_resize_string" (( n str -- newstr )) }
{ "set-string-nth-fast" "strings.private" "primitive_set_string_nth_fast" (( ch n string -- )) }
- { "set-string-nth-slow" "strings.private" "primitive_set_string_nth_slow" (( ch n string -- )) }
- { "string-nth" "strings.private" "primitive_string_nth" (( n string -- ch )) }
{ "(exit)" "system" "primitive_exit" (( n -- * )) }
{ "nano-count" "system" "primitive_nano_count" (( -- ns )) }
{ "system-micros" "system" "primitive_system_micros" (( -- us )) }
swap [ set-datastack ] dip
] (( stack quot -- new-stack )) call-effect-unsafe ;
+SYMBOL: original-error
SYMBOL: error
SYMBOL: error-continuation
SYMBOL: error-thread
<PRIVATE
: save-error ( error -- )
- dup error set-global
- compute-restarts restarts set-global ;
+ [ error set-global ]
+ [ compute-restarts restarts set-global ] bi ;
PRIVATE>
dup save-error
catchstack* empty? [
thread-error-hook get-global
- [ (( error -- * )) call-effect-unsafe ] [ die ] if*
+ [ original-error get-global die ] or
+ (( error -- * )) call-effect-unsafe
] when
c> continue-with ;
! 63 = self
63 special-object error-thread set-global
continuation error-continuation set-global
- rethrow
+ [ original-error set-global ] [ rethrow ] bi
] 5 set-special-object
! VM adds this to kernel errors, so that user-space
! can identify them
[ f ] [ HS{ 1 2 3 } HS{ 2 3 } set= ] unit-test
[ HS{ 1 2 } HS{ 1 2 3 } ] [ HS{ 1 2 } clone dup clone [ 3 swap adjoin ] keep ] unit-test
+
+[ t ] [ HS{ } null? ] unit-test
+[ f ] [ HS{ 1 } null? ] unit-test
M: hash-set members table>> keys ; inline
M: hash-set set-like drop dup hash-set? [ members <hash-set> ] unless ;
M: hash-set clone table>> clone hash-set boa ;
+M: hash-set null? table>> assoc-empty? ;
M: sequence fast-set <hash-set> ;
M: f fast-set drop H{ } clone hash-set boa ;
-! Copyright (C) 2008 Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Daniel Ehrenberg, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces growable
strings io classes continuations destructors combinators
GENERIC: encode-char ( char stream encoding -- )
+GENERIC: encode-string ( string stream encoding -- )
+
+M: object encode-string [ encode-char ] 2curry each ; inline
+
GENERIC: <decoder> ( stream encoding -- newstream )
CONSTANT: replacement-char HEX: fffd
M: encoder stream-write1
>encoder< encode-char ;
-GENERIC# encoder-write 2 ( string stream encoding -- )
-
-M: string encoder-write
- [ encode-char ] 2curry each ;
-
M: encoder stream-write
- >encoder< encoder-write ;
+ >encoder< encode-string ;
M: encoder dispose stream>> dispose ;
! Copyright (C) 2006, 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math math.order kernel sequences sbufs vectors growable io
-continuations namespaces io.encodings combinators strings ;
+USING: accessors byte-arrays math math.order kernel sequences
+sbufs vectors growable io continuations namespaces io.encodings
+combinators strings ;
IN: io.encodings.utf8
! Decoding UTF-8
! Encoding UTF-8
: encoded ( stream char -- )
- BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ;
+ BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ; inline
-: char>utf8 ( stream char -- )
- {
+: char>utf8 ( char stream -- )
+ swap {
{ [ dup -7 shift zero? ] [ swap stream-write1 ] }
{ [ dup -11 shift zero? ] [
2dup -6 shift BIN: 11000000 bitor swap stream-write1
2dup -6 shift encoded
encoded
]
- } cond ;
+ } cond ; inline
M: utf8 encode-char
- drop swap char>utf8 ;
+ drop char>utf8 ;
+
+M: utf8 encode-string
+ drop
+ over aux>>
+ [ [ char>utf8 ] curry each ]
+ [ [ >byte-array ] dip stream-write ] if ;
PRIVATE>
HELP: dip
{ $values { "x" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
+{ $description "Removes " { $snippet "x" } " from the datastack, calls " { $snippet "quot" } ", and restores " { $snippet "x" } " to the top of the datastack when " { $snippet "quot" } " is finished." }
{ $examples
{ $example "USING: arrays kernel math prettyprint ;" "10 20 30 [ / ] dip 2array ." "{ 1/2 30 }" }
} ;
HELP: 2dip
{ $values { "x" object } { "y" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "x" } " and " { $snippet "y" } " hidden on the retain stack." }
+{ $description "Removes " { $snippet "x" } " and " { $snippet "y" } " from the datastack, calls " { $snippet "quot" } ", and restores the removed objects to the top of the datastack when " { $snippet "quot" } " is finished." }
{ $notes "The following are equivalent:"
{ $code "[ [ foo bar ] dip ] dip" }
{ $code "[ foo bar ] 2dip" }
HELP: 3dip
{ $values { "x" object } { "y" object } { "z" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." }
+{ $description "Removes " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } " from the datastack, calls " { $snippet "quot" } ", and restores the removed objects to the top of the datastack when " { $snippet "quot" } " is finished." }
{ $notes "The following are equivalent:"
{ $code "[ [ [ foo bar ] dip ] dip ] dip" }
{ $code "[ foo bar ] 3dip" }
HELP: 4dip
{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "w" } ", " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." }
+{ $description "Removes " { $snippet "w" } ", " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } " from the datastack, calls " { $snippet "quot" } ", and restores the removed objects to the top of the datastack when " { $snippet "quot" } " is finished." }
{ $notes "The following are equivalent:"
{ $code "[ [ [ [ foo bar ] dip ] dip ] dip ] dip" }
{ $code "[ foo bar ] 4dip" }
adjoin
delete
}
+"To test if a set is the empty set:"
+{ $subsections null? }
"Basic mathematical operations, which any type of set may override for efficiency:"
{ $subsections
diff
HELP: without
{ $values { "seq" sequence } { "set" set } { "subseq" sequence } }
{ $description "Returns the subsequence of the given sequence consisting of things that are not members of the set. This may contain duplicates, if the sequence has duplicates." } ;
+
+HELP: null?
+{ $values { "set" set } { "?" "a boolean" } }
+{ $description "Tests whether the given set is empty. This outputs " { $snippet "t" } " when given a null set of any type." } ;
[ f ] [ HS{ 1 2 3 1 2 1 } duplicates ] unit-test
[ H{ { 3 HS{ 1 2 } } } ] [ H{ } clone 1 3 pick adjoin-at 2 3 pick adjoin-at ] unit-test
+
+[ t ] [ f null? ] unit-test
+[ f ] [ { 4 } null? ] unit-test
GENERIC: set= ( set1 set2 -- ? )
GENERIC: duplicates ( set -- seq )
GENERIC: all-unique? ( set -- ? )
+GENERIC: null? ( set -- ? )
! Defaults for some methods.
! Override them for efficiency
+M: set null? members null? ; inline
+
M: set set-like drop ; inline
M: set union
M: sequence members
[ pruned ] keep like ;
+
+M: sequence null?
+ empty? ; inline
: combine ( sets -- set )
[ f ]
"s" get >array
] unit-test
+! Make sure string initialization works
+[ HEX: 123456 ] [ 100 HEX: 123456 <string> first ] unit-test
+
! Make sure we clear aux vector when storing octets
[ "\u123456hi" ] [ "ih\u123456" clone reverse! ] unit-test
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.private sequences kernel.private
-math sequences.private slots.private byte-arrays
-alien.accessors ;
+USING: accessors alien.accessors byte-arrays kernel math.private
+sequences kernel.private math sequences.private slots.private ;
IN: strings
<PRIVATE
: rehash-string ( str -- )
1 over sequence-hashcode swap set-string-hashcode ; inline
+: (aux) ( n string -- byte-array m )
+ aux>> { byte-array } declare swap 1 fixnum-shift-fast ; inline
+
+: small-char? ( ch -- ? ) HEX: 7f fixnum<= ; inline
+
+: string-nth ( n string -- ch )
+ 2dup string-nth-fast dup small-char?
+ [ 2nip ] [
+ [ (aux) alien-unsigned-2 7 fixnum-shift-fast ] dip
+ fixnum-bitxor
+ ] if ; inline
+
+: ensure-aux ( string -- string )
+ dup aux>> [ dup length 2 * (byte-array) >>aux ] unless ; inline
+
+: set-string-nth-slow ( ch n string -- )
+ [ [ HEX: 80 fixnum-bitor ] 2dip set-string-nth-fast ]
+ [
+ ensure-aux
+ [ -7 fixnum-shift-fast 1 fixnum-bitxor ] 2dip
+ (aux) set-alien-unsigned-2
+ ] 3bi ;
+
: set-string-nth ( ch n string -- )
- pick HEX: 7f fixnum<=
+ pick small-char?
[ set-string-nth-fast ] [ set-string-nth-slow ] if ; inline
PRIVATE>
{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "vocabs.refresh" } "." } ;
HELP: require-when
-{ $values { "if" "a vocabulary specifier" } { "then" "a vocabulary specifier" } }
-{ $description "Loads the " { $snippet "then" } " vocabulary if it is not loaded and the " { $snippet "if" } " vocabulary is. If the " { $snippet "if" } " vocabulary is not loaded now, but it is later, then the " { $snippet "then" } " vocabulary will be loaded along with it at that time." }
-{ $notes "This is used to express a joint dependency of vocabularies. If vocabularies " { $snippet "a" } " and " { $snippet "b" } " use code in vocabulary " { $snippet "c" } " to interact, then the following line can be placed in " { $snippet "a" } " in order express the dependency."
-{ $code "\"b\" \"c\" require-when" } } ;
+{ $values { "if" "a sequence of vocabulary specifiers" } { "then" "a vocabulary specifier" } }
+{ $description "Loads the " { $snippet "then" } " vocabulary if it is not loaded and all of the " { $snippet "if" } " vocabulary is. If some of the " { $snippet "if" } " vocabularies are not loaded now, but they are later, then the " { $snippet "then" } " vocabulary will be loaded along with the final one." }
+{ $notes "This is used to express a joint dependency of vocabularies. If vocabularies " { $snippet "a" } " and " { $snippet "b" } " use code in vocabulary " { $snippet "c" } " to interact, then the following line, which can be placed in " { $snippet "a" } " or " { $snippet "b" } ", expresses the dependency."
+{ $code "{ \"a\" \"b\" } \"c\" require-when" } } ;
HELP: run
{ $values { "vocab" "a vocabulary specifier" } }
<PRIVATE
-: load-conditional-requires ( vocab-name -- )
- conditional-requires get
- [ at [ require ] each ]
- [ delete-at ] 2bi ;
+SYMBOL: require-when-vocabs
+require-when-vocabs [ HS{ } clone ] initialize
+
+SYMBOL: require-when-table
+require-when-table [ V{ } clone ] initialize
+
+: load-conditional-requires ( vocab -- )
+ vocab-name require-when-vocabs get in? [
+ require-when-table get [
+ [ [ vocab dup [ source-loaded?>> +done+ = ] when ] all? ] dip
+ [ require ] curry when
+ ] assoc-each
+ ] when ;
: load-source ( vocab -- )
dup check-vocab-hook get call( vocab -- )
[ +parsing+ >>source-loaded? ] dip
[ % ] [ call( -- ) ] if-bootstrapping
+done+ >>source-loaded?
- vocab-name load-conditional-requires
+ load-conditional-requires
] [ ] [ f >>source-loaded? ] cleanup ;
: load-docs ( vocab -- )
load-vocab drop ;
: require-when ( if then -- )
- over vocab
- [ nip require ]
- [ swap conditional-requires get [ swap suffix ] change-at ]
- if ;
+ over [ vocab ] all? [
+ require drop
+ ] [
+ [ drop [ require-when-vocabs get adjoin ] each ]
+ [ 2array require-when-table get push ] 2bi
+ ] if ;
: reload ( name -- )
dup vocab
USE: vocabs.loader
IN: vocabs.loader.test.m
-"vocabs.loader.test.o" "vocabs.loader.test.n" require-when
+{ "vocabs.loader.test.o" "vocabs.loader.test.m" }
+"vocabs.loader.test.n" require-when
}
"Removing a vocabulary:"
{ $subsections forget-vocab }
-{ $see-also "words" "vocabs.loader" } ;
+{ $see-also "words" "vocabs.loader" "word-search" } ;
ABOUT: "vocabularies"
! Copyright (C) 2007, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs strings kernel sorting namespaces
-sequences definitions sets ;
+sequences definitions sets combinators ;
IN: vocabs
SYMBOL: dictionary
: check-vocab-name ( name -- name )
dup string? [ bad-vocab-name ] unless ;
-SYMBOL: conditional-requires
-conditional-requires [ H{ } clone ] initialize
-
: create-vocab ( name -- vocab )
check-vocab-name
dictionary get [ <vocab> ] cache
n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
initial-seed
+
n 3 * homo-sapiens-chars homo-sapiens-floats
"IUB ambiguity codes" "TWO" write-random-fasta
+
n 5 * IUB-chars IUB-floats
"Homo sapiens frequency" "THREE" write-random-fasta
+
drop
] with-file-writer
] ;
! Copyright (C) Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.accessors alien.c-types alien.syntax byte-arrays
-destructors generalizations hints kernel libc locals math math.order
-sequences sequences.private classes.struct accessors alien.data ;
+destructors generalizations kernel libc locals math math.order
+sequences sequences.private classes.struct accessors alien.data
+typed ;
IN: benchmark.yuv-to-rgb
-STRUCT: yuv_buffer
+STRUCT: yuv-buffer
{ y_width int }
{ y_height int }
{ y_stride int }
:: fake-data ( -- rgb yuv )
1600 :> w
1200 :> h
- yuv_buffer <struct> :> buffer
+ yuv-buffer <struct> :> buffer
w h * 3 * <byte-array> :> rgb
rgb buffer
w >>y_width
pick y_width>> iota
[ yuv>rgb-pixel ] with with with with each ; inline
-: yuv>rgb ( rgb yuv -- )
+TYPED: yuv>rgb ( rgb: byte-array yuv: yuv-buffer -- )
[ 0 ] 2dip
dup y_height>> iota
[ yuv>rgb-row ] with with each
drop ;
-HINTS: yuv>rgb byte-array yuv_buffer ;
-
: yuv>rgb-benchmark ( -- )
[ fake-data yuv>rgb ] with-destructors ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: build-support sequences tools.test ;
+IN: build-support.tests
+
+[ f ] [ factor.sh-make-target empty? ] unit-test
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays io io.backend io.encodings.utf8 io.launcher ;
+IN: build-support
+
+CONSTANT: factor.sh-path "resource:build-support/factor.sh"
+
+: factor.sh-make-target ( -- string )
+ factor.sh-path normalize-path "make-target" 2array
+ utf8 [ readln ] with-process-reader ;
{ t cpFloat }
{ n cpVect } ;
-C-ENUM: cpShapeType
+ENUM: cpShapeType
CP_CIRCLE_SHAPE
CP_SEGMENT_SHAPE
CP_POLY_SHAPE
FUNCTION: cpContact* cpContactInit ( cpContact* con, cpVect p, cpVect n, cpFloat dist, cpHashValue hash ) ;
-C-ENUM: cpArbiterState
+ENUM: cpArbiterState
cpArbiterStateNormal
cpArbiterStateFirstColl
cpArbiterStateIgnore ;
: optimized-cfg ( quot -- cfgs )
{
{ [ dup cfg? ] [ 1array ] }
- { [ dup quotation? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
- { [ dup word? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
+ { [ dup quotation? ] [ test-optimizer ] }
+ { [ dup word? ] [ test-optimizer ] }
[ ]
} cond ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit initializers math ;
+USING: accessors calendar combinators.short-circuit
+constructors eval initializers kernel math tools.test ;
IN: constructors.tests
TUPLE: stock-spread stock spread timestamp ;
[ 2 ] [ 0 0 <ct2> a>> ] unit-test
[ 3 ] [ 0 0 0 <ct3> a>> ] unit-test
[ 4 ] [ 0 0 0 0 <ct4> a>> ] unit-test
+
+[
+ """USE: constructors
+IN: constructors.tests
+TUPLE: foo a b ;
+CONSTRUCTOR: foo ( a a -- obj ) ;""" eval( -- )
+] [
+ error>> repeated-constructor-parameters?
+] must-fail-with
+
+[
+ """USE: constructors
+IN: constructors.tests
+TUPLE: foo a b ;
+CONSTRUCTOR: foo ( a c -- obj ) ;""" eval( -- )
+] [
+ error>> unknown-constructor-parameters?
+] must-fail-with
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs classes classes.tuple effects.parser
-fry generalizations generic.standard kernel lexer locals macros
-parser sequences slots vocabs words arrays ;
+USING: accessors arrays assocs classes classes.tuple
+effects.parser fry generalizations generic.standard kernel
+lexer locals macros parser sequences sets slots vocabs words ;
IN: constructors
! An experiment
default-params swap assoc-union values _ firstn class boa
] ;
+ERROR: repeated-constructor-parameters class effect ;
+
+ERROR: unknown-constructor-parameters class effect unknown ;
+
+: ensure-constructor-parameters ( class effect -- class effect )
+ dup in>> all-unique? [ repeated-constructor-parameters ] unless
+ 2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
+ [ unknown-constructor-parameters ] unless-empty ;
+
:: (define-constructor) ( constructor-word class effect def -- word quot )
constructor-word
class def define-initializer
scan-word [ name>> "<" ">" surround create-in dup reset-generic ] keep ;
: parse-constructor ( -- class word effect def )
- scan-constructor complete-effect parse-definition ;
+ scan-constructor complete-effect ensure-constructor-parameters
+ parse-definition ;
SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.data alien.parser alien.strings
alien.syntax arrays assocs byte-arrays classes.struct
-combinators continuations cuda.ffi destructors fry io
-io.backend io.encodings.string io.encodings.utf8 kernel lexer
-locals macros math math.parser namespaces nested-comments
-opengl.gl.extensions parser prettyprint quotations sequences
-words ;
+combinators continuations cuda.ffi cuda.memory cuda.utils
+destructors fry init io io.backend io.encodings.string
+io.encodings.utf8 kernel lexer locals macros math math.parser
+namespaces nested-comments opengl.gl.extensions parser
+prettyprint quotations sequences words cuda.libraries ;
QUALIFIED-WITH: alien.c-types a
IN: cuda
-SYMBOL: cuda-device
-SYMBOL: cuda-context
-SYMBOL: cuda-module
-SYMBOL: cuda-function
-SYMBOL: cuda-launcher
-SYMBOL: cuda-memory-hashtable
-
-SYMBOL: cuda-libraries
-cuda-libraries [ H{ } clone ] initialize
-
-SYMBOL: cuda-functions
-
-TUPLE: cuda-library name path ;
-
-: <cuda-library> ( name path -- obj )
- \ cuda-library new
- swap >>path
- swap >>name ;
-
-: add-cuda-library ( name path -- )
- normalize-path <cuda-library>
- dup name>> cuda-libraries get set-at ;
-
-: cuda-library ( name -- cuda-library )
- cuda-libraries get at ;
-
-ERROR: throw-cuda-error n ;
-
-: cuda-error ( n -- )
- dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error ] if ;
-
-: cuda-version ( -- n )
- a:int <c-object> [ cuDriverGetVersion cuda-error ] keep a:*int ;
-
-: init-cuda ( -- )
- 0 cuInit cuda-error ;
-
TUPLE: launcher
{ device integer initial: 0 }
-{ device-flags initial: 0 }
-path ;
+{ device-flags initial: 0 } ;
+
+: <launcher> ( device-id -- launcher )
+ launcher new
+ swap >>device ; inline
TUPLE: function-launcher
-dim-block
-dim-grid
-shared-size
-stream ;
+dim-block dim-grid shared-size stream ;
: with-cuda-context ( flags device quot -- )
+ H{ } clone cuda-modules set-global
H{ } clone cuda-functions set
- [
- [ CUcontext <c-object> ] 2dip
- [ cuCtxCreate cuda-error ] 3keep 2drop a:*void*
- ] dip
- [ '[ _ @ ] ]
- [ drop '[ _ cuCtxDestroy cuda-error ] ] 2bi
- [ ] cleanup ; inline
-
-: with-cuda-module ( path quot -- )
- [
- normalize-path
- [ CUmodule <c-object> ] dip
- [ cuModuleLoad cuda-error ] 2keep drop a:*void*
- ] dip
+ [ create-context ] dip
[ '[ _ @ ] ]
- [ drop '[ _ cuModuleUnload cuda-error ] ] 2bi
+ [ drop '[ _ destroy-context ] ] 2bi
[ ] cleanup ; inline
-: with-cuda-program ( flags device path quot -- )
+: with-cuda-program ( flags device quot -- )
[ dup cuda-device set ] 2dip
- '[
- cuda-context set
- _ [
- cuda-module set
- _ call
- ] with-cuda-module
- ] with-cuda-context ; inline
+ '[ cuda-context set _ call ] with-cuda-context ; inline
: with-cuda ( launcher quot -- )
- [
- init-cuda
- H{ } clone cuda-memory-hashtable
- ] 2dip '[
+ init-cuda
+ [ H{ } clone cuda-memory-hashtable ] 2dip '[
_
[ cuda-launcher set ]
- [ [ device>> ] [ device-flags>> ] [ path>> ] tri ] bi
+ [ [ device>> ] [ device-flags>> ] bi ] bi
_ with-cuda-program
] with-variable ; inline
-<PRIVATE
-
-: #cuda-devices ( -- n )
- a:int <c-object> [ cuDeviceGetCount cuda-error ] keep a:*int ;
-
-: n>cuda-device ( n -- device )
- [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop a:*int ;
-
-: enumerate-cuda-devices ( -- devices )
- #cuda-devices iota [ n>cuda-device ] map ;
-
-: cuda-device-properties ( device -- properties )
- [ CUdevprop <c-object> ] dip
- [ cuDeviceGetProperties cuda-error ] 2keep drop
- CUdevprop memory>struct ;
-
-PRIVATE>
-
-: cuda-devices ( -- assoc )
- enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
-
-: cuda-device-name ( n -- string )
- [ 256 [ <byte-array> ] keep ] dip
- [ cuDeviceGetName cuda-error ]
- [ 2drop utf8 alien>string ] 3bi ;
-
-: cuda-device-capability ( n -- pair )
- [ a:int <c-object> a:int <c-object> ] dip
- [ cuDeviceComputeCapability cuda-error ]
- [ drop [ a:*int ] bi@ ] 3bi 2array ;
-
-: cuda-device-memory ( n -- bytes )
- [ a:uint <c-object> ] dip
- [ cuDeviceTotalMem cuda-error ]
- [ drop a:*uint ] 2bi ;
-
-: get-function-ptr* ( module string -- function )
- [ CUfunction <c-object> ] 2dip
- [ cuModuleGetFunction cuda-error ] 3keep 2drop a:*void* ;
-
-: get-function-ptr ( string -- function )
- [ cuda-module get ] dip get-function-ptr* ;
-
-: with-cuda-function ( string quot -- )
- [
- get-function-ptr* cuda-function set
- ] dip call ; inline
-
-: cached-cuda-function ( string -- alien )
- cuda-functions get [ get-function-ptr ] cache ;
-
-: launch-function* ( function -- ) cuLaunch cuda-error ;
-
-: launch-function ( -- ) cuda-function get cuLaunch cuda-error ;
-
-: launch-function-grid* ( function width height -- )
- cuLaunchGrid cuda-error ;
-
-: launch-function-grid ( width height -- )
- [ cuda-function get ] 2dip
- cuLaunchGrid cuda-error ;
-
-TUPLE: cuda-memory < disposable ptr length ;
-
-: <cuda-memory> ( ptr length -- obj )
- cuda-memory new-disposable
- swap >>length
- swap >>ptr ;
-
-: add-cuda-memory ( obj -- obj )
- dup dup ptr>> cuda-memory-hashtable get set-at ;
-
-: delete-cuda-memory ( obj -- )
- cuda-memory-hashtable delete-at ;
-
-ERROR: invalid-cuda-memory ptr ;
-
-: cuda-memory-length ( cuda-memory -- n )
- ptr>> cuda-memory-hashtable get ?at [
- length>>
- ] [
- invalid-cuda-memory
- ] if ;
-
-M: cuda-memory byte-length length>> ;
-
-: cuda-malloc ( n -- ptr )
- [ CUdeviceptr <c-object> ] dip
- [ cuMemAlloc cuda-error ] 2keep
- [ a:*int ] dip <cuda-memory> add-cuda-memory ;
-
-: cuda-free* ( ptr -- )
- cuMemFree cuda-error ;
-
-M: cuda-memory dispose ( ptr -- )
- ptr>> cuda-free* ;
-
-: host>device ( dest-ptr src-ptr -- )
- [ ptr>> ] dip dup length cuMemcpyHtoD cuda-error ;
-
-:: device>host ( ptr -- seq )
- ptr byte-length <byte-array>
- [ ptr [ ptr>> ] [ byte-length ] bi cuMemcpyDtoH cuda-error ] keep ;
-
-: memcpy-device>device ( dest-ptr src-ptr count -- )
- cuMemcpyDtoD cuda-error ;
-
-: memcpy-device>array ( dest-array dest-index src-ptr count -- )
- cuMemcpyDtoA cuda-error ;
-
-: memcpy-array>device ( dest-ptr src-array src-index count -- )
- cuMemcpyAtoD cuda-error ;
-
-: memcpy-array>host ( dest-ptr src-array src-index count -- )
- cuMemcpyAtoH cuda-error ;
-
-: memcpy-host>array ( dest-array dest-index src-ptr count -- )
- cuMemcpyHtoA cuda-error ;
-
-: memcpy-array>array ( dest-array dest-index src-array src-ptr count -- )
- cuMemcpyAtoA cuda-error ;
-
-: cuda-int* ( function offset value -- )
- cuParamSeti cuda-error ;
-
-: cuda-int ( offset value -- )
- [ cuda-function get ] 2dip cuda-int* ;
-
-: cuda-float* ( function offset value -- )
- cuParamSetf cuda-error ;
-
-: cuda-float ( offset value -- )
- [ cuda-function get ] 2dip cuda-float* ;
-
-: cuda-vector* ( function offset ptr n -- )
- cuParamSetv cuda-error ;
-
-: cuda-vector ( offset ptr n -- )
- [ cuda-function get ] 3dip cuda-vector* ;
-
-: param-size* ( function n -- )
- cuParamSetSize cuda-error ;
-
-: param-size ( n -- )
- [ cuda-function get ] dip param-size* ;
-
-: malloc-device-string ( string -- n )
- utf8 encode
- [ length cuda-malloc ] keep
- [ host>device ] [ drop ] 2bi ;
-
-ERROR: bad-cuda-parameter parameter ;
-
-:: set-parameters ( seq -- )
- cuda-function get :> function
- 0 :> offset!
- seq [
- [ offset ] dip
- {
- { [ dup cuda-memory? ] [ ptr>> cuda-int ] }
- { [ dup float? ] [ cuda-float ] }
- { [ dup integer? ] [ cuda-int ] }
- [ bad-cuda-parameter ]
- } cond
- offset 4 + offset!
- ] each
- offset param-size ;
-
-: cuda-device-attribute ( attribute dev -- n )
- [ a:int <c-object> ] 2dip
- [ cuDeviceGetAttribute cuda-error ]
- [ 2drop a:*int ] 3bi ;
-
-: function-block-shape* ( function x y z -- )
- cuFuncSetBlockShape cuda-error ;
-
-: function-block-shape ( x y z -- )
- [ cuda-function get ] 3dip
- cuFuncSetBlockShape cuda-error ;
-
-: function-shared-size* ( function n -- )
- cuFuncSetSharedSize cuda-error ;
-
-: function-shared-size ( n -- )
- [ cuda-function get ] dip
- cuFuncSetSharedSize cuda-error ;
-
-: launch ( -- )
- cuda-launcher get {
- [ block-shape>> first3 function-block-shape ]
- [ shared-size>> function-shared-size ]
- [
- grid>> [
- launch-function
- ] [
- first2 launch-function-grid
- ] if-empty
- ]
- } cleave ;
-
-: cuda-device. ( n -- )
- {
- [ "Device: " write number>string print ]
- [ "Name: " write cuda-device-name print ]
- [ "Memory: " write cuda-device-memory number>string print ]
- [
- "Capability: " write
- cuda-device-capability [ number>string ] map " " join print
- ]
- [ "Properties: " write cuda-device-properties . ]
- [
- "CU_DEVICE_ATTRIBUTE_GPU_OVERLAP: " write
- CU_DEVICE_ATTRIBUTE_GPU_OVERLAP swap
- cuda-device-attribute number>string print
- ]
- } cleave ;
-
-: cuda. ( -- )
- "CUDA Version: " write cuda-version number>string print nl
- #cuda-devices iota [ nl ] [ cuda-device. ] interleave ;
-
: c-type>cuda-setter ( c-type -- n cuda-type )
{
{ [ dup a:int = ] [ drop 4 [ cuda-int* ] ] }
swap '[ _ param-size* ] suffix
'[ _ cleave ] ;
-: define-cuda-word ( word string arguments -- )
+: define-cuda-word ( word module-name function-name arguments -- )
[
'[
- _ get-function-ptr
+ _ _ cached-function
[ nip _ cuda-arguments ]
[ run-function-launcher ] 2bi
]
]
- [ nip \ function-launcher suffix a:void function-effect ]
- 2bi define-declared ;
+ [ 2nip \ function-launcher suffix a:void function-effect ]
+ 3bi define-declared ;
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.strings cuda cuda.syntax destructors
-io.encodings.utf8 kernel locals math prettyprint sequences ;
-IN: cuda.hello-world
+USING: accessors alien.c-types alien.strings cuda cuda.devices
+cuda.memory cuda.syntax cuda.utils destructors io
+io.encodings.string io.encodings.utf8 kernel locals math
+math.parser namespaces sequences ;
+IN: cuda.demos.hello-world
-CUDA-LIBRARY: hello vocab:cuda/hello.ptx
+CUDA-LIBRARY: hello vocab:cuda/demos/hello-world/hello.ptx
CUDA-FUNCTION: helloWorld ( char* string-ptr ) ;
-:: cuda-hello-world ( -- )
- T{ launcher
- { device 0 }
- { path "vocab:cuda/hello.ptx" }
- } [
- "Hello World!" [ - ] map-index malloc-device-string &dispose dup :> str
+: cuda-hello-world ( -- )
+ [
+ cuda-launcher get device>> number>string
+ "CUDA device " ": " surround write
+ "Hello World!" [ - ] map-index host>device
- T{ function-launcher
- { dim-block { 6 1 1 } }
- { dim-grid { 2 1 } }
- { shared-size 0 }
- }
- helloWorld
-
- ! <<< { 6 1 1 } { 2 1 } 1 >>> helloWorld
-
- str device>host utf8 alien>string .
- ] with-cuda ;
+ [ { 6 1 1 } { 2 1 } 2<<< helloWorld ]
+ [ device>host utf8 decode print ] bi
+ ] with-each-cuda-device ;
MAIN: cuda-hello-world
CUDA-FUNCTION: prefix_sum_block ( uint* in, uint* out, uint n ) ;
:: cuda-prefix-sum ( -- )
- T{ launcher
- { device 0 }
- { path "vocab:cuda/demos/prefix-sum/prefix-sum.ptx" }
- } [
-
-
+ T{ launcher { device 0 } }
+ [
! { 1 1 1 } { 2 1 } 0 3<<< prefix_sum_block
-
] with-cuda ;
MAIN: cuda-prefix-sum
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.data alien.strings arrays assocs
+byte-arrays classes.struct combinators cuda cuda.ffi cuda.utils
+fry io io.encodings.utf8 kernel math.parser prettyprint
+sequences ;
+IN: cuda.devices
+
+: #cuda-devices ( -- n )
+ init-cuda
+ int <c-object> [ cuDeviceGetCount cuda-error ] keep *int ;
+
+: n>cuda-device ( n -- device )
+ init-cuda
+ [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ;
+
+: enumerate-cuda-devices ( -- devices )
+ #cuda-devices iota [ n>cuda-device ] map ;
+
+: with-each-cuda-device ( quot -- )
+ [ enumerate-cuda-devices ] dip '[ <launcher> _ with-cuda ] each ; inline
+
+: cuda-device-properties ( n -- properties )
+ init-cuda
+ [ CUdevprop <c-object> ] dip
+ [ cuDeviceGetProperties cuda-error ] 2keep drop
+ CUdevprop memory>struct ;
+
+: cuda-devices ( -- assoc )
+ enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
+
+: cuda-device-name ( n -- string )
+ init-cuda
+ [ 256 [ <byte-array> ] keep ] dip
+ [ cuDeviceGetName cuda-error ]
+ [ 2drop utf8 alien>string ] 3bi ;
+
+: cuda-device-capability ( n -- pair )
+ init-cuda
+ [ int <c-object> int <c-object> ] dip
+ [ cuDeviceComputeCapability cuda-error ]
+ [ drop [ *int ] bi@ ] 3bi 2array ;
+
+: cuda-device-memory ( n -- bytes )
+ init-cuda
+ [ uint <c-object> ] dip
+ [ cuDeviceTotalMem cuda-error ]
+ [ drop *uint ] 2bi ;
+
+: cuda-device-attribute ( attribute n -- n )
+ init-cuda
+ [ int <c-object> ] 2dip
+ [ cuDeviceGetAttribute cuda-error ]
+ [ 2drop *int ] 3bi ;
+
+: cuda-device. ( n -- )
+ init-cuda
+ {
+ [ "Device: " write number>string print ]
+ [ "Name: " write cuda-device-name print ]
+ [ "Memory: " write cuda-device-memory number>string print ]
+ [
+ "Capability: " write
+ cuda-device-capability [ number>string ] map " " join print
+ ]
+ [ "Properties: " write cuda-device-properties . ]
+ [
+ "CU_DEVICE_ATTRIBUTE_GPU_OVERLAP: " write
+ CU_DEVICE_ATTRIBUTE_GPU_OVERLAP swap
+ cuda-device-attribute number>string print
+ ]
+ } cleave ;
+
+: cuda. ( -- )
+ init-cuda
+ "CUDA Version: " write cuda-version number>string print nl
+ #cuda-devices iota [ nl ] [ cuda-device. ] interleave ;
+
STRUCT: CUuuid
{ bytes char[16] } ;
-C-ENUM: CUctx_flags
+ENUM: CUctx_flags
{ CU_CTX_SCHED_AUTO 0 }
{ CU_CTX_SCHED_SPIN 1 }
{ CU_CTX_SCHED_YIELD 2 }
{ CU_CTX_LMEM_RESIZE_TO_MAX 16 }
{ CU_CTX_FLAGS_MASK HEX: 1f } ;
-C-ENUM: CUevent_flags
+ENUM: CUevent_flags
{ CU_EVENT_DEFAULT 0 }
{ CU_EVENT_BLOCKING_SYNC 1 } ;
-C-ENUM: CUarray_format
+ENUM: CUarray_format
{ CU_AD_FORMAT_UNSIGNED_INT8 HEX: 01 }
{ CU_AD_FORMAT_UNSIGNED_INT16 HEX: 02 }
{ CU_AD_FORMAT_UNSIGNED_INT32 HEX: 03 }
{ CU_AD_FORMAT_HALF HEX: 10 }
{ CU_AD_FORMAT_FLOAT HEX: 20 } ;
-C-ENUM: CUaddress_mode
+ENUM: CUaddress_mode
{ CU_TR_ADDRESS_MODE_WRAP 0 }
{ CU_TR_ADDRESS_MODE_CLAMP 1 }
{ CU_TR_ADDRESS_MODE_MIRROR 2 } ;
-C-ENUM: CUfilter_mode
+ENUM: CUfilter_mode
{ CU_TR_FILTER_MODE_POINT 0 }
{ CU_TR_FILTER_MODE_LINEAR 1 } ;
-C-ENUM: CUdevice_attribute
+ENUM: CUdevice_attribute
{ CU_DEVICE_ATTRIBUTE_MAX_THREADS_PER_BLOCK 1 }
{ CU_DEVICE_ATTRIBUTE_MAX_BLOCK_DIM_X 2 }
{ CU_DEVICE_ATTRIBUTE_MAX_BLOCK_DIM_Y 3 }
{ clockRate int }
{ textureAlign int } ;
-C-ENUM: CUfunction_attribute
+ENUM: CUfunction_attribute
{ CU_FUNC_ATTRIBUTE_MAX_THREADS_PER_BLOCK 0 }
{ CU_FUNC_ATTRIBUTE_SHARED_SIZE_BYTES 1 }
{ CU_FUNC_ATTRIBUTE_CONST_SIZE_BYTES 2 }
{ CU_FUNC_ATTRIBUTE_BINARY_VERSION 6 }
CU_FUNC_ATTRIBUTE_MAX ;
-C-ENUM: CUfunc_cache
+ENUM: CUfunc_cache
{ CU_FUNC_CACHE_PREFER_NONE HEX: 00 }
{ CU_FUNC_CACHE_PREFER_SHARED HEX: 01 }
{ CU_FUNC_CACHE_PREFER_L1 HEX: 02 } ;
-C-ENUM: CUmemorytype
+ENUM: CUmemorytype
{ CU_MEMORYTYPE_HOST HEX: 01 }
{ CU_MEMORYTYPE_DEVICE HEX: 02 }
{ CU_MEMORYTYPE_ARRAY HEX: 03 } ;
-C-ENUM: CUcomputemode
+ENUM: CUcomputemode
{ CU_COMPUTEMODE_DEFAULT 0 }
{ CU_COMPUTEMODE_EXCLUSIVE 1 }
{ CU_COMPUTEMODE_PROHIBITED 2 } ;
-C-ENUM: CUjit_option
+ENUM: CUjit_option
{ CU_JIT_MAX_REGISTERS 0 }
CU_JIT_THREADS_PER_BLOCK
CU_JIT_WALL_TIME
CU_JIT_TARGET
CU_JIT_FALLBACK_STRATEGY ;
-C-ENUM: CUjit_target
+ENUM: CUjit_target
{ CU_TARGET_COMPUTE_10 0 }
CU_TARGET_COMPUTE_11
CU_TARGET_COMPUTE_12
CU_TARGET_COMPUTE_13
CU_TARGET_COMPUTE_20 ;
-C-ENUM: CUjit_fallback
+ENUM: CUjit_fallback
{ CU_PREFER_PTX 0 }
CU_PREFER_BINARY ;
-C-ENUM: CUgraphicsRegisterFlags
+ENUM: CUgraphicsRegisterFlags
{ CU_GRAPHICS_REGISTER_FLAGS_NONE 0 } ;
-C-ENUM: CUgraphicsMapResourceFlags
+ENUM: CUgraphicsMapResourceFlags
{ CU_GRAPHICS_MAP_RESOURCE_FLAGS_NONE HEX: 00 }
{ CU_GRAPHICS_MAP_RESOURCE_FLAGS_READ_ONLY HEX: 01 }
{ CU_GRAPHICS_MAP_RESOURCE_FLAGS_WRITE_DISCARD HEX: 02 } ;
-C-ENUM: CUarray_cubemap_face
+ENUM: CUarray_cubemap_face
{ CU_CUBEMAP_FACE_POSITIVE_X HEX: 00 }
{ CU_CUBEMAP_FACE_NEGATIVE_X HEX: 01 }
{ CU_CUBEMAP_FACE_POSITIVE_Y HEX: 02 }
{ CU_CUBEMAP_FACE_POSITIVE_Z HEX: 04 }
{ CU_CUBEMAP_FACE_NEGATIVE_Z HEX: 05 } ;
-C-ENUM: CUresult
+ENUM: CUresult
{ CUDA_SUCCESS 0 }
{ CUDA_ERROR_INVALID_VALUE 1 }
{ CUDA_ERROR_OUT_OF_MEMORY 2 }
FUNCTION: CUresult cuGraphicsUnmapResources ( uint count, CUgraphicsResource* resources, CUstream hStream ) ;
FUNCTION: CUresult cuGetExportTable ( void** ppExportTable, CUuuid* pExportTableId ) ;
-
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data arrays assocs
+cuda.ffi cuda.utils io.backend kernel namespaces sequences ;
+IN: cuda.libraries
+
+SYMBOL: cuda-libraries
+cuda-libraries [ H{ } clone ] initialize
+
+SYMBOL: current-cuda-library
+
+TUPLE: cuda-library name path handle ;
+
+: <cuda-library> ( name path -- obj )
+ \ cuda-library new
+ swap >>path
+ swap >>name ;
+
+: add-cuda-library ( name path -- )
+ normalize-path <cuda-library>
+ dup name>> cuda-libraries get-global set-at ;
+
+: ?delete-at ( key assoc -- old/key ? )
+ 2dup delete-at* [ 2nip t ] [ 2drop f ] if ; inline
+
+ERROR: no-cuda-library name ;
+
+: load-module ( path -- module )
+ [ CUmodule <c-object> ] dip
+ [ cuModuleLoad cuda-error ] 2keep drop *void* ;
+
+: unload-module ( module -- )
+ cuModuleUnload cuda-error ;
+
+: load-cuda-library ( library -- handle )
+ path>> load-module ;
+
+: lookup-cuda-library ( name -- cuda-library )
+ cuda-libraries get ?at [ no-cuda-library ] unless ;
+
+: remove-cuda-library ( name -- library )
+ cuda-libraries get ?delete-at [ no-cuda-library ] unless ;
+
+: unload-cuda-library ( name -- )
+ remove-cuda-library handle>> unload-module ;
+
+: cached-module ( module-name -- alien )
+ lookup-cuda-library
+ cuda-modules get-global [ load-cuda-library ] cache ;
+
+: cached-function ( module-name function-name -- alien )
+ [ cached-module ] dip
+ 2array cuda-functions get [ first2 get-function-ptr* ] cache ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.data assocs byte-arrays cuda.ffi
+cuda.utils destructors io.encodings.string io.encodings.utf8
+kernel locals namespaces sequences strings ;
+QUALIFIED-WITH: alien.c-types a
+IN: cuda.memory
+
+SYMBOL: cuda-memory-hashtable
+
+TUPLE: cuda-memory < disposable ptr length ;
+
+: <cuda-memory> ( ptr length -- obj )
+ cuda-memory new-disposable
+ swap >>length
+ swap >>ptr ;
+
+: add-cuda-memory ( obj -- obj )
+ dup dup ptr>> cuda-memory-hashtable get set-at ;
+
+: delete-cuda-memory ( obj -- )
+ cuda-memory-hashtable delete-at ;
+
+ERROR: invalid-cuda-memory ptr ;
+
+: cuda-memory-length ( cuda-memory -- n )
+ ptr>> cuda-memory-hashtable get ?at [
+ length>>
+ ] [
+ invalid-cuda-memory
+ ] if ;
+
+M: cuda-memory byte-length length>> ;
+
+: cuda-malloc ( n -- ptr )
+ [ CUdeviceptr <c-object> ] dip
+ [ cuMemAlloc cuda-error ] 2keep
+ [ a:*int ] dip <cuda-memory> add-cuda-memory ;
+
+: cuda-free* ( ptr -- )
+ cuMemFree cuda-error ;
+
+M: cuda-memory dispose ( ptr -- )
+ ptr>> cuda-free* ;
+
+: memcpy-device>device ( dest-ptr src-ptr count -- )
+ cuMemcpyDtoD cuda-error ;
+
+: memcpy-device>array ( dest-array dest-index src-ptr count -- )
+ cuMemcpyDtoA cuda-error ;
+
+: memcpy-array>device ( dest-ptr src-array src-index count -- )
+ cuMemcpyAtoD cuda-error ;
+
+: memcpy-array>host ( dest-ptr src-array src-index count -- )
+ cuMemcpyAtoH cuda-error ;
+
+: memcpy-host>array ( dest-array dest-index src-ptr count -- )
+ cuMemcpyHtoA cuda-error ;
+
+: memcpy-array>array ( dest-array dest-index src-array src-ptr count -- )
+ cuMemcpyAtoA cuda-error ;
+
+GENERIC: host>device ( obj -- ptr )
+
+M: string host>device utf8 encode host>device ;
+
+M: byte-array host>device ( byte-array -- ptr )
+ [ length cuda-malloc ] keep
+ [ [ ptr>> ] dip dup length cuMemcpyHtoD cuda-error ]
+ [ drop ] 2bi ;
+
+:: device>host ( ptr -- seq )
+ ptr byte-length <byte-array>
+ [ ptr [ ptr>> ] [ byte-length ] bi cuMemcpyDtoH cuda-error ] keep ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators.smart io.backend io.directories
+io.launcher io.pathnames kernel locals math sequences splitting
+system ;
+IN: cuda.nvcc
+
+HOOK: nvcc-path os ( -- path )
+
+M: object nvcc-path "nvcc" ;
+
+M: macosx nvcc-path "/usr/local/cuda/bin/nvcc" ;
+
+: cu>ptx ( path -- path' )
+ ".cu" ?tail drop ".ptx" append ;
+
+: nvcc-command ( path -- seq )
+ [
+ [ nvcc-path "--ptx" "-o" ] dip
+ [ cu>ptx ] [ file-name ] bi
+ ] output>array ;
+
+ERROR: nvcc-failed n path ;
+
+:: compile-cu ( path -- path' )
+ path normalize-path :> path2
+ path2 parent-directory [
+ path2 nvcc-command
+ run-process wait-for-process [ path2 nvcc-failed ] unless-zero
+ path2 cu>ptx
+ ] with-directory ;
--- /dev/null
+USING: cuda.ptx io.streams.string tools.test ;
+IN: cuda.ptx.tests
+
+[ """ .version 2.0
+ .target sm_20
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20, .texmode_independent
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } { texmode .texmode_independent } } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_11, map_f64_to_f32
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target
+ { arch sm_11 }
+ { map_f64_to_f32? t }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_11, map_f64_to_f32, .texmode_independent
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target
+ { arch sm_11 }
+ { map_f64_to_f32? t }
+ { texmode .texmode_independent }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ .global .f32 foo[9000];
+ .extern .align 16 .shared .v4.f32 bar[];
+ .func (.reg .f32 sum) zap (.reg .f32 a, .reg .f32 b)
+ {
+ add.rn.f32 sum, a, b;
+ ret;
+ }
+ .func frob (.align 8 .param .u64 in, .align 8 .param .u64 out, .align 8 .param .u64 len)
+ {
+ ret;
+ }
+ .func twib
+ {
+ ret;
+ }
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ ptx-variable
+ { storage-space .global }
+ { type .f32 }
+ { name "foo" }
+ { dim 9000 }
+ }
+ T{ ptx-variable
+ { extern? t }
+ { align 16 }
+ { storage-space .shared }
+ { type T{ .v4 f .f32 } }
+ { name "bar" }
+ { dim 0 }
+ }
+ T{ ptx-func
+ { return T{ ptx-variable { storage-space .reg } { type .f32 } { name "sum" } } }
+ { name "zap" }
+ { params {
+ T{ ptx-variable { storage-space .reg } { type .f32 } { name "a" } }
+ T{ ptx-variable { storage-space .reg } { type .f32 } { name "b" } }
+ } }
+ { body {
+ T{ add { round .rn } { type .f32 } { dest "sum" } { a "a" } { b "b" } }
+ T{ ret }
+ } }
+ }
+ T{ ptx-func
+ { name "frob" }
+ { params {
+ T{ ptx-variable { align 8 } { storage-space .param } { type .u64 } { name "in" } }
+ T{ ptx-variable { align 8 } { storage-space .param } { type .u64 } { name "out" } }
+ T{ ptx-variable { align 8 } { storage-space .param } { type .u64 } { name "len" } }
+ } }
+ { body {
+ T{ ret }
+ } }
+ }
+ T{ ptx-func
+ { name "twib" }
+ { body {
+ T{ ret }
+ } }
+ }
+ } }
+ } ptx>string
+] unit-test
+
+[ "a" ] [ [ "a" write-ptx-operand ] with-string-writer ] unit-test
+[ "2" ] [ [ 2 write-ptx-operand ] with-string-writer ] unit-test
+[ "0d4000000000000000" ] [ [ 2.0 write-ptx-operand ] with-string-writer ] unit-test
+[ "!a" ] [ [ T{ ptx-negation f "a" } write-ptx-operand ] with-string-writer ] unit-test
+[ "{a, b, c, d}" ] [ [ T{ ptx-vector f { "a" "b" "c" "d" } } write-ptx-operand ] with-string-writer ] unit-test
+[ "[a]" ] [ [ T{ ptx-indirect f "a" 0 } write-ptx-operand ] with-string-writer ] unit-test
+[ "[a+1]" ] [ [ T{ ptx-indirect f "a" 1 } write-ptx-operand ] with-string-writer ] unit-test
+[ "[a-1]" ] [ [ T{ ptx-indirect f "a" -1 } write-ptx-operand ] with-string-writer ] unit-test
+[ "a[1]" ] [ [ T{ ptx-element f "a" 1 } write-ptx-operand ] with-string-writer ] unit-test
+[ "{a, b[2], 3, 0d4000000000000000}" ] [ [ T{ ptx-vector f { "a" T{ ptx-element f "b" 2 } 3 2.0 } } write-ptx-operand ] with-string-writer ] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ abs.s32 a, b;
+ @p abs.s32 a, b;
+ @!p abs.s32 a, b;
+foo: abs.s32 a, b;
+ abs.ftz.f32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ abs { type .s32 } { dest "a" } { a "b" } }
+ T{ abs
+ { predicate "p" }
+ { type .s32 } { dest "a" } { a "b" }
+ }
+ T{ abs
+ { predicate T{ ptx-negation f "p" } }
+ { type .s32 } { dest "a" } { a "b" }
+ }
+ T{ abs
+ { label "foo" }
+ { type .s32 } { dest "a" } { a "b" }
+ }
+ T{ abs { type .f32 } { dest "a" } { a "b" } { ftz? t } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ add.s32 a, b, c;
+ add.cc.s32 a, b, c;
+ add.sat.s32 a, b, c;
+ add.ftz.f32 a, b, c;
+ add.ftz.sat.f32 a, b, c;
+ add.rz.sat.f32 a, b, c;
+ add.rz.ftz.sat.f32 a, b, c;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ add { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ T{ add { cc? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ T{ add { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ T{ add { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ add { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ add { round .rz } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ add { round .rz } { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ addc.s32 a, b, c;
+ addc.cc.s32 a, b, c;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ addc { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ T{ addc { cc? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ and.b32 a, b, c;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ and { type .b32 } { dest "a" } { a "b" } { b "c" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ atom.and.u32 a, [b], c;
+ atom.global.or.u32 a, [b], c;
+ atom.shared.cas.u32 a, [b], c, d;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ atom { op .and } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } { b "c" } }
+ T{ atom { storage-space .global } { op .or } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } { b "c" } }
+ T{ atom { storage-space .shared } { op .cas } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } { b "c" } { c "d" } }
+
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ bar.arrive a, b;
+ bar.red.popc.u32 a, b, d;
+ bar.red.popc.u32 a, b, !d;
+ bar.red.popc.u32 a, b, c, !d;
+ bar.sync a;
+ bar.sync a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ bar.arrive { a "a" } { b "b" } }
+ T{ bar.red { op .popc } { type .u32 } { dest "a" } { a "b" } { c "d" } }
+ T{ bar.red { op .popc } { type .u32 } { dest "a" } { a "b" } { c T{ ptx-negation f "d" } } }
+ T{ bar.red { op .popc } { type .u32 } { dest "a" } { a "b" } { b "c" } { c T{ ptx-negation f "d" } } }
+ T{ bar.sync { a "a" } }
+ T{ bar.sync { a "a" } { b "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ bfe.u32 a, b, c, d;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ bfe { type .u32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ bfi.u32 a, b, c, d, e;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ bfi { type .u32 } { dest "a" } { a "b" } { b "c" } { c "d" } { d "e" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ bfind.u32 a, b;
+ bfind.shiftamt.u32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ bfind { type .u32 } { dest "a" } { a "b" } }
+ T{ bfind { type .u32 } { shiftamt? t } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ bra foo;
+ bra.uni bar;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ bra { target "foo" } }
+ T{ bra { uni? t } { target "bar" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ brev.b32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ brev { type .b32 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ brkpt;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ brkpt }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ call foo;
+ call.uni foo;
+ call (a), foo;
+ call (a), foo, (b);
+ call (a), foo, (b, c);
+ call (a), foo, (b, c, d);
+ call (a[2]), foo, (b, c, d[3]);
+ call foo, (b, c, d);
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ call { target "foo" } }
+ T{ call { uni? t } { target "foo" } }
+ T{ call { return "a" } { target "foo" } }
+ T{ call { return "a" } { target "foo" } { params { "b" } } }
+ T{ call { return "a" } { target "foo" } { params { "b" "c" } } }
+ T{ call { return "a" } { target "foo" } { params { "b" "c" "d" } } }
+ T{ call { return T{ ptx-element f "a" 2 } } { target "foo" } { params { "b" "c" T{ ptx-element f "d" 3 } } } }
+ T{ call { target "foo" } { params { "b" "c" "d" } } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ clz.b32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ clz { type .b32 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ cnot.b32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ cnot { type .b32 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ copysign.f64 a, b, c;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ copysign { type .f64 } { dest "a" } { a "b" } { b "c" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ cos.approx.f32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ cos { round .approx } { type .f32 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ cvt.f32.s32 a, b;
+ cvt.s32.f32 a, b;
+ cvt.rp.f32.f64 a, b;
+ cvt.rpi.s32.f32 a, b;
+ cvt.ftz.f32.f64 a, b;
+ cvt.sat.f32.f64 a, b;
+ cvt.ftz.sat.f32.f64 a, b;
+ cvt.rp.ftz.sat.f32.f64 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ cvt { dest-type .f32 } { type .s32 } { dest "a" } { a "b" } }
+ T{ cvt { dest-type .s32 } { type .f32 } { dest "a" } { a "b" } }
+ T{ cvt { round .rp } { dest-type .f32 } { type .f64 } { dest "a" } { a "b" } }
+ T{ cvt { round .rpi } { dest-type .s32 } { type .f32 } { dest "a" } { a "b" } }
+ T{ cvt { ftz? t } { dest-type .f32 } { type .f64 } { dest "a" } { a "b" } }
+ T{ cvt { sat? t } { dest-type .f32 } { type .f64 } { dest "a" } { a "b" } }
+ T{ cvt { ftz? t } { sat? t } { dest-type .f32 } { type .f64 } { dest "a" } { a "b" } }
+ T{ cvt { round .rp } { ftz? t } { sat? t } { dest-type .f32 } { type .f64 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ cvta.global.u64 a, b;
+ cvta.shared.u64 a, b;
+ cvta.to.shared.u64 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ cvta { storage-space .global } { type .u64 } { dest "a" } { a "b" } }
+ T{ cvta { storage-space .shared } { type .u64 } { dest "a" } { a "b" } }
+ T{ cvta { to? t } { storage-space .shared } { type .u64 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ div.u32 a, b, c;
+ div.approx.f32 a, b, c;
+ div.approx.ftz.f32 a, b, c;
+ div.full.f32 a, b, c;
+ div.full.ftz.f32 a, b, c;
+ div.f32 a, b, c;
+ div.rz.f32 a, b, c;
+ div.ftz.f32 a, b, c;
+ div.rz.ftz.f32 a, b, c;
+ div.f64 a, b, c;
+ div.rz.f64 a, b, c;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ div { type .u32 } { dest "a" } { a "b" } { b "c" } }
+ T{ div { round .approx } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ div { round .approx } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ div { round .full } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ div { round .full } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ div { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ div { round .rz } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ div { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ div { round .rz } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ div { type .f64 } { dest "a" } { a "b" } { b "c" } }
+ T{ div { round .rz } { type .f64 } { dest "a" } { a "b" } { b "c" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ ex2.approx.f32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ ex2 { round .approx } { type .f32 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ exit;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ exit }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ fma.f32 a, b, c, d;
+ fma.sat.f32 a, b, c, d;
+ fma.ftz.f32 a, b, c, d;
+ fma.ftz.sat.f32 a, b, c, d;
+ fma.rz.sat.f32 a, b, c, d;
+ fma.rz.ftz.sat.f32 a, b, c, d;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ fma { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ fma { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ fma { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ fma { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ fma { round .rz } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ fma { round .rz } { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ isspacep.shared a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ isspacep { storage-space .shared } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ ld.u32 a, [b];
+ ld.v2.u32 a, [b];
+ ld.v4.u32 a, [b];
+ ld.v4.u32 {a, b, c, d}, [e];
+ ld.lu.u32 a, [b];
+ ld.const.lu.u32 a, [b];
+ ld.volatile.const[5].u32 a, [b];
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ ld { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
+ T{ ld { type T{ .v2 { of .u32 } } } { dest "a" } { a T{ ptx-indirect f "b" } } }
+ T{ ld { type T{ .v4 { of .u32 } } } { dest "a" } { a T{ ptx-indirect f "b" } } }
+ T{ ld { type T{ .v4 { of .u32 } } } { dest T{ ptx-vector f { "a" "b" "c" "d" } } } { a "[e]" } }
+ T{ ld { cache-op .lu } { type .u32 } { dest "a" } { a "[b]" } }
+ T{ ld { storage-space T{ .const } } { cache-op .lu } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
+ T{ ld { volatile? t } { storage-space T{ .const { bank 5 } } } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ ldu.u32 a, [b];
+ ldu.v2.u32 a, [b];
+ ldu.v4.u32 a, [b];
+ ldu.v4.u32 {a, b, c, d}, [e];
+ ldu.lu.u32 a, [b];
+ ldu.const.lu.u32 a, [b];
+ ldu.volatile.const[5].u32 a, [b];
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ ldu { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
+ T{ ldu { type T{ .v2 { of .u32 } } } { dest "a" } { a T{ ptx-indirect f "b" } } }
+ T{ ldu { type T{ .v4 { of .u32 } } } { dest "a" } { a T{ ptx-indirect f "b" } } }
+ T{ ldu { type T{ .v4 { of .u32 } } } { dest T{ ptx-vector f { "a" "b" "c" "d" } } } { a "[e]" } }
+ T{ ldu { cache-op .lu } { type .u32 } { dest "a" } { a "[b]" } }
+ T{ ldu { storage-space T{ .const } } { cache-op .lu } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
+ T{ ldu { volatile? t } { storage-space T{ .const { bank 5 } } } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ lg2.approx.f32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ lg2 { round .approx } { type .f32 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ mad.s32 a, b, c, d;
+ mad.lo.s32 a, b, c, d;
+ mad.sat.s32 a, b, c, d;
+ mad.hi.sat.s32 a, b, c, d;
+ mad.ftz.f32 a, b, c, d;
+ mad.ftz.sat.f32 a, b, c, d;
+ mad.rz.sat.f32 a, b, c, d;
+ mad.rz.ftz.sat.f32 a, b, c, d;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ mad { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ mad { mode .lo } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ mad { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ mad { mode .hi } { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ mad { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ mad { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ mad { round .rz } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ mad { round .rz } { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ mad24.s32 a, b, c, d;
+ mad24.lo.s32 a, b, c, d;
+ mad24.sat.s32 a, b, c, d;
+ mad24.hi.sat.s32 a, b, c, d;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ mad24 { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ mad24 { mode .lo } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ mad24 { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ mad24 { mode .hi } { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ neg.s32 a, b;
+ neg.f32 a, b;
+ neg.ftz.f32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ neg { type .s32 } { dest "a" } { a "b" } }
+ T{ neg { type .f32 } { dest "a" } { a "b" } }
+ T{ neg { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ not.b32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ not { type .b32 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ or.b32 a, b, c;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ or { type .b32 } { dest "a" } { a "b" } { b "c" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ pmevent a;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ pmevent { a "a" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ popc.b64 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ popc { type .b64 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ prefetch.L1 [a];
+ prefetch.local.L2 [a];
+ prefetchu.L1 [a];
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ prefetch { level .L1 } { a T{ ptx-indirect f "a" } } }
+ T{ prefetch { storage-space .local } { level .L2 } { a T{ ptx-indirect f "a" } } }
+ T{ prefetchu { level .L1 } { a T{ ptx-indirect f "a" } } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ prmt.b32 a, b, c, d;
+ prmt.b32.f4e a, b, c, d;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ prmt { type .b32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ prmt { type .b32 } { mode .f4e } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ rcp.approx.f32 a, b;
+ rcp.approx.ftz.f32 a, b;
+ rcp.f32 a, b;
+ rcp.rz.f32 a, b;
+ rcp.ftz.f32 a, b;
+ rcp.rz.ftz.f32 a, b;
+ rcp.f64 a, b;
+ rcp.rz.f64 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ rcp { round .approx } { type .f32 } { dest "a" } { a "b" } }
+ T{ rcp { round .approx } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+ T{ rcp { type .f32 } { dest "a" } { a "b" } }
+ T{ rcp { round .rz } { type .f32 } { dest "a" } { a "b" } }
+ T{ rcp { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+ T{ rcp { round .rz } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+ T{ rcp { type .f64 } { dest "a" } { a "b" } }
+ T{ rcp { round .rz } { type .f64 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ red.and.u32 [a], b;
+ red.global.and.u32 [a], b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ red { op .and } { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
+ T{ red { storage-space .global } { op .and } { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ rsqrt.approx.f32 a, b;
+ rsqrt.approx.ftz.f32 a, b;
+ rsqrt.approx.f64 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ rsqrt { round .approx } { type .f32 } { dest "a" } { a "b" } }
+ T{ rsqrt { round .approx } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+ T{ rsqrt { round .approx } { type .f64 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ rsqrt.approx.f32 a, b;
+ rsqrt.approx.ftz.f32 a, b;
+ rsqrt.approx.f64 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ rsqrt { round .approx } { type .f32 } { dest "a" } { a "b" } }
+ T{ rsqrt { round .approx } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+ T{ rsqrt { round .approx } { type .f64 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ sad.u32 a, b, c, d;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ sad { type .u32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ selp.u32 a, b, c, d;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ selp { type .u32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ set.gt.u32.s32 a, b, c;
+ set.gt.ftz.u32.f32 a, b, c;
+ set.gt.and.ftz.u32.f32 a, b, c, d;
+ set.gt.and.ftz.u32.f32 a, b, c, !d;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ set { cmp-op .gt } { dest-type .u32 } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ T{ set { cmp-op .gt } { ftz? t } { dest-type .u32 } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ set { cmp-op .gt } { bool-op .and } { ftz? t } { dest-type .u32 } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ set { cmp-op .gt } { bool-op .and } { ftz? t } { dest-type .u32 } { type .f32 } { dest "a" } { a "b" } { b "c" } { c T{ ptx-negation f "d" } } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ setp.gt.s32 a, b, c;
+ setp.gt.s32 a|z, b, c;
+ setp.gt.ftz.f32 a, b, c;
+ setp.gt.and.ftz.f32 a, b, c, d;
+ setp.gt.and.ftz.f32 a, b, c, !d;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ setp { cmp-op .gt } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ T{ setp { cmp-op .gt } { type .s32 } { dest "a" } { |dest "z" } { a "b" } { b "c" } }
+ T{ setp { cmp-op .gt } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ setp { cmp-op .gt } { bool-op .and } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ setp { cmp-op .gt } { bool-op .and } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "!d" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ shl.b32 a, b, c;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ shl { type .b32 } { dest "a" } { a "b" } { b "c" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ shr.b32 a, b, c;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ shr { type .b32 } { dest "a" } { a "b" } { b "c" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ sin.approx.f32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ sin { round .approx } { type .f32 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ slct.f32.s32 a, b, c, d;
+ slct.ftz.f32.s32 a, b, c, d;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ slct { dest-type .f32 } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ T{ slct { ftz? t } { dest-type .f32 } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ sqrt.approx.f32 a, b;
+ sqrt.approx.ftz.f32 a, b;
+ sqrt.f32 a, b;
+ sqrt.rz.f32 a, b;
+ sqrt.ftz.f32 a, b;
+ sqrt.rz.ftz.f32 a, b;
+ sqrt.f64 a, b;
+ sqrt.rz.f64 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ sqrt { round .approx } { type .f32 } { dest "a" } { a "b" } }
+ T{ sqrt { round .approx } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+ T{ sqrt { type .f32 } { dest "a" } { a "b" } }
+ T{ sqrt { round .rz } { type .f32 } { dest "a" } { a "b" } }
+ T{ sqrt { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+ T{ sqrt { round .rz } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+ T{ sqrt { type .f64 } { dest "a" } { a "b" } }
+ T{ sqrt { round .rz } { type .f64 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ st.u32 [a], b;
+ st.v2.u32 [a], b;
+ st.v4.u32 [a], b;
+ st.v4.u32 [a], {b, c, d, e};
+ st.lu.u32 [a], b;
+ st.local.lu.u32 [a], b;
+ st.volatile.local.u32 [a], b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ st { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
+ T{ st { type T{ .v2 { of .u32 } } } { dest T{ ptx-indirect f "a" } } { a "b" } }
+ T{ st { type T{ .v4 { of .u32 } } } { dest T{ ptx-indirect f "a" } } { a "b" } }
+ T{ st { type T{ .v4 { of .u32 } } } { dest T{ ptx-indirect f "a" } } { a T{ ptx-vector f { "b" "c" "d" "e" } } } }
+ T{ st { cache-op .lu } { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
+ T{ st { storage-space .local } { cache-op .lu } { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
+ T{ st { volatile? t } { storage-space .local } { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ sub.s32 a, b, c;
+ sub.cc.s32 a, b, c;
+ sub.sat.s32 a, b, c;
+ sub.ftz.f32 a, b, c;
+ sub.ftz.sat.f32 a, b, c;
+ sub.rz.sat.f32 a, b, c;
+ sub.rz.ftz.sat.f32 a, b, c;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ sub { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ T{ sub { cc? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ T{ sub { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ T{ sub { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ sub { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ sub { round .rz } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ T{ sub { round .rz } { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ subc.s32 a, b, c;
+ subc.cc.s32 a, b, c;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ subc { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ T{ subc { cc? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ testp.finite.f32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ testp { op .finite } { type .f32 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ trap;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ trap }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ vote.all.pred a, b;
+ vote.all.pred a, !b;
+ vote.ballot.b32 a, b;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ vote { mode .all } { type .pred } { dest "a" } { a "b" } }
+ T{ vote { mode .all } { type .pred } { dest "a" } { a "!b" } }
+ T{ vote { mode .ballot } { type .b32 } { dest "a" } { a "b" } }
+ } }
+ } ptx>string
+] unit-test
+
+[ """ .version 2.0
+ .target sm_20
+ xor.b32 a, b, c;
+""" ] [
+ T{ ptx
+ { version "2.0" }
+ { target T{ ptx-target { arch sm_20 } } }
+ { body {
+ T{ xor { type .b32 } { dest "a" } { a "b" } { b "c" } }
+ } }
+ } ptx>string
+] unit-test
+
! (c)2010 Joe Groff bsd license
-USING: accessors arrays combinators io kernel math math.parser
-roles sequences strings variants words ;
+USING: accessors arrays combinators io io.streams.string kernel
+math math.parser roles sequences strings variants words ;
FROM: roles => TUPLE: ;
IN: cuda.ptx
{ parameter ?integer }
{ dim dim }
{ initializer ?string } ;
+UNION: ?ptx-variable POSTPONE: f ptx-variable ;
-TUPLE: ptx-predicate
- { negated? boolean }
- { variable string } ;
-UNION: ?ptx-predicate POSTPONE: f ptx-predicate ;
+TUPLE: ptx-negation
+ { var string } ;
+
+TUPLE: ptx-vector
+ elements ;
+
+TUPLE: ptx-element
+ { var string }
+ { index integer } ;
+
+UNION: ptx-var
+ string ptx-element ;
+
+TUPLE: ptx-indirect
+ { base ptx-var }
+ { offset integer } ;
+
+UNION: ptx-operand
+ integer float ptx-var ptx-negation ptx-vector ptx-indirect ;
+UNION: ?ptx-operand POSTPONE: f ptx-operand ;
TUPLE: ptx-instruction
{ label ?string }
- { predicate ?ptx-predicate } ;
+ { predicate ?ptx-operand } ;
TUPLE: ptx-entry
{ name string }
body ;
TUPLE: ptx-func < ptx-entry
- { return ptx-variable } ;
+ { return ?ptx-variable } ;
TUPLE: ptx-directive ;
TUPLE: ptx-typed-instruction < ptx-instruction
{ type ptx-type }
- { dest string } ;
+ { dest ptx-operand } ;
TUPLE: ptx-2op-instruction < ptx-typed-instruction
- { a string } ;
+ { a ptx-operand } ;
TUPLE: ptx-3op-instruction < ptx-typed-instruction
- { a string }
- { b string } ;
+ { a ptx-operand }
+ { b ptx-operand } ;
TUPLE: ptx-4op-instruction < ptx-typed-instruction
- { a string }
- { b string }
- { c string } ;
+ { a ptx-operand }
+ { b ptx-operand }
+ { c ptx-operand } ;
TUPLE: ptx-5op-instruction < ptx-typed-instruction
- { a string }
- { b string }
- { c string }
- { d string } ;
+ { a ptx-operand }
+ { b ptx-operand }
+ { c ptx-operand }
+ { d ptx-operand } ;
TUPLE: ptx-addsub-instruction < ptx-3op-instruction
{ sat? boolean }
TUPLE: ptx-set-instruction < ptx-3op-instruction
{ cmp-op ptx-cmp-op }
{ bool-op ?ptx-op }
- { c ?string }
+ { c ?ptx-operand }
{ ftz? boolean } ;
VARIANT: ptx-cache-op
TUPLE: atom < ptx-3op-instruction
{ storage-space ?ptx-storage-space }
{ op ptx-op }
- { c ?string } ;
+ { c ?ptx-operand } ;
TUPLE: bar.arrive < ptx-instruction
- { a string }
- { b string } ;
+ { a ptx-operand }
+ { b ptx-operand } ;
TUPLE: bar.red < ptx-2op-instruction
{ op ptx-op }
- { b ?string }
- { c string } ;
+ { b ?ptx-operand }
+ { c ptx-operand } ;
TUPLE: bar.sync < ptx-instruction
- { a string }
- { b ?string } ;
+ { a ptx-operand }
+ { b ?ptx-operand } ;
TUPLE: bfe < ptx-4op-instruction ;
TUPLE: bfi < ptx-5op-instruction ;
TUPLE: bfind < ptx-2op-instruction
TUPLE: brev < ptx-2op-instruction ;
TUPLE: brkpt < ptx-instruction ;
TUPLE: call < ptx-branch-instruction
- { return ?string }
+ { return ?ptx-operand }
params ;
TUPLE: clz < ptx-2op-instruction ;
TUPLE: cnot < ptx-2op-instruction ;
TUPLE: copysign < ptx-3op-instruction ;
TUPLE: cos <{ ptx-2op-instruction ptx-float-env } ;
TUPLE: cvt < ptx-2op-instruction
- { rounding-mode ?ptx-rounding-mode }
+ { round ?ptx-rounding-mode }
{ ftz? boolean }
{ sat? boolean }
{ dest-type ptx-type } ;
TUPLE: exit < ptx-instruction ;
TUPLE: fma <{ ptx-mad-instruction ptx-float-env } ;
TUPLE: isspacep < ptx-instruction
- { storage-space ?ptx-storage-space }
- { dest string }
- { a string } ;
+ { storage-space ptx-storage-space }
+ { dest ptx-operand }
+ { a ptx-operand } ;
TUPLE: ld < ptx-ldst-instruction ;
TUPLE: ldu < ptx-ldst-instruction ;
TUPLE: lg2 <{ ptx-2op-instruction ptx-float-env } ;
TUPLE: not < ptx-2op-instruction ;
TUPLE: or < ptx-3op-instruction ;
TUPLE: pmevent < ptx-instruction
- { a string } ;
+ { a ptx-operand } ;
TUPLE: popc < ptx-2op-instruction ;
TUPLE: prefetch < ptx-instruction
- { a string }
+ { a ptx-operand }
{ storage-space ?ptx-storage-space }
{ level ptx-cache-level } ;
TUPLE: prefetchu < ptx-instruction
- { a string }
+ { a ptx-operand }
{ level ptx-cache-level } ;
TUPLE: prmt < ptx-4op-instruction
{ mode ?ptx-prmt-mode } ;
TUPLE: set < ptx-set-instruction
{ dest-type ptx-type } ;
TUPLE: setp < ptx-set-instruction
- { |dest ?string } ;
+ { |dest ?ptx-operand } ;
TUPLE: shl < ptx-3op-instruction ;
TUPLE: shr < ptx-3op-instruction ;
TUPLE: sin <{ ptx-2op-instruction ptx-float-env } ;
GENERIC: ptx-element-label ( elt -- label )
M: object ptx-element-label drop f ;
+GENERIC: ptx-semicolon? ( elt -- ? )
+M: object ptx-semicolon? drop t ;
+M: ptx-target ptx-semicolon? drop f ;
+M: ptx-entry ptx-semicolon? drop f ;
+M: ptx-func ptx-semicolon? drop f ;
+M: .file ptx-semicolon? drop f ;
+M: .loc ptx-semicolon? drop f ;
+
+GENERIC: write-ptx-operand ( operand -- )
+
+M: string write-ptx-operand write ;
+M: integer write-ptx-operand number>string write ;
+M: float write-ptx-operand "0d" write double>bits >hex 16 CHAR: 0 pad-head write ;
+M: ptx-negation write-ptx-operand "!" write var>> write ;
+M: ptx-vector write-ptx-operand
+ "{" write
+ elements>> [ ", " write ] [ write-ptx-operand ] interleave
+ "}" write ;
+M: ptx-element write-ptx-operand dup var>> write "[" write index>> number>string write "]" write ;
+M: ptx-indirect write-ptx-operand
+ "[" write
+ dup base>> write-ptx-operand
+ offset>> {
+ { [ dup zero? ] [ drop ] }
+ { [ dup 0 < ] [ number>string write ] }
+ [ "+" write number>string write ]
+ } cond
+ "]" write ;
+
GENERIC: (write-ptx-element) ( elt -- )
: write-ptx-element ( elt -- )
dup ptx-element-label [ write ":" write ] when*
- "\t" write (write-ptx-element)
- ";" print ;
+ "\t" write dup (write-ptx-element)
+ ptx-semicolon? [ ";" print ] [ nl ] if ;
: write-ptx ( ptx -- )
- "\t.version " write dup version>> write ";" print
+ "\t.version " write dup version>> print
dup target>> write-ptx-element
body>> [ write-ptx-element ] each ;
[ arch>> [ name>> ] [ f ] if* ]
[ map_f64_to_f32?>> [ "map_f64_to_f32" ] [ f ] if ]
[ texmode>> [ name>> ] [ f ] if* ] tri
- 3array sift ", " join write ;
+ 3array sift [ ", " write ] [ write ] interleave ;
: write-ptx-dim ( dim -- )
{
"\t}" write ;
: write-entry ( entry -- )
- dup name>> write " " write
- dup params>> [ write-params ] when* nl
- dup directives>> [ (write-ptx-element) ] each nl
+ dup name>> write
+ dup params>> [ " " write write-params ] when* nl
+ dup directives>> [ (write-ptx-element) nl ] each
dup body>> write-body
drop ;
".maxnreg " write n>> number>string write ;
M: .maxntid (write-ptx-element)
".maxntid " write
- dup sequence? [ [ number>string ] map ", " join write ] [ number>string write ] if ;
+ dup sequence? [ [ ", " write ] [ number>string write ] interleave ] [ number>string write ] if ;
M: .pragma (write-ptx-element)
".pragma \"" write pragma>> write "\"" write ;
: write-insn ( insn name -- insn )
over predicate>>
- [ "@" write dup negated?>> [ "!" write ] when variable>> write " " write ] when*
+ [ "@" write write-ptx-operand " " write ] when*
write ;
: write-2op ( insn -- )
dup type>> (write-ptx-element) " " write
- dup dest>> write ", " write
- dup a>> write
+ dup dest>> write-ptx-operand ", " write
+ dup a>> write-ptx-operand
drop ;
: write-3op ( insn -- )
dup write-2op ", " write
- dup b>> write
+ dup b>> write-ptx-operand
drop ;
: write-4op ( insn -- )
dup write-3op ", " write
- dup c>> write
+ dup c>> write-ptx-operand
drop ;
: write-5op ( insn -- )
dup write-4op ", " write
- dup d>> write
+ dup d>> write-ptx-operand
drop ;
: write-ftz ( insn -- )
dup storage-space>> (write-ptx-element)
dup op>> (write-ptx-element)
dup write-3op
- c>> [ ", " write write ] when* ;
+ c>> [ ", " write write-ptx-operand ] when* ;
M: bar.arrive (write-ptx-element)
"bar.arrive " write-insn
- dup a>> write ", " write
- dup b>> write
+ dup a>> write-ptx-operand ", " write
+ dup b>> write-ptx-operand
drop ;
M: bar.red (write-ptx-element)
"bar.red" write-insn
dup op>> (write-ptx-element)
dup write-2op
- dup b>> [ ", " write write ] when*
- ", " write c>> write ;
+ dup b>> [ ", " write write-ptx-operand ] when*
+ ", " write c>> write-ptx-operand ;
M: bar.sync (write-ptx-element)
- "bar.arrive " write-insn
- dup a>> write
- dup b>> [ ", " write write ] when*
+ "bar.sync " write-insn
+ dup a>> write-ptx-operand
+ dup b>> [ ", " write write-ptx-operand ] when*
drop ;
M: bfe (write-ptx-element)
"bfe" write-insn
write-2op ;
M: bra (write-ptx-element)
"bra" write-insn
- dup write-uni
- " " write target>> write ;
+ dup write-uni " " write
+ target>> write ;
M: brev (write-ptx-element)
"brev" write-insn
write-2op ;
M: brkpt (write-ptx-element)
"brkpt" write-insn drop ;
M: call (write-ptx-element)
- "call" write-insn " " write
- dup return>> [ "(" write write "), " write ] when*
+ "call" write-insn
+ dup write-uni " " write
+ dup return>> [ "(" write write-ptx-operand "), " write ] when*
dup target>> write
- dup params>> [ ", (" write ", " join write ")" write ] unless-empty
+ dup params>> [ ", (" write [ ", " write ] [ write-ptx-operand ] interleave ")" write ] unless-empty
drop ;
M: clz (write-ptx-element)
"clz" write-insn
write-2op ;
M: cvt (write-ptx-element)
"cvt" write-insn
- dup rounding-mode>> (write-ptx-element)
+ dup round>> (write-ptx-element)
dup write-ftz
dup write-sat
dup dest-type>> (write-ptx-element)
"isspacep" write-insn
dup storage-space>> (write-ptx-element)
" " write
- dup dest>> write ", " write a>> write ;
+ dup dest>> write-ptx-operand ", " write a>> write-ptx-operand ;
M: ld (write-ptx-element)
"ld" write-insn
write-ldst ;
"prefetch" write-insn
dup storage-space>> (write-ptx-element)
dup level>> (write-ptx-element)
- " " write a>> write ;
+ " " write a>> write-ptx-operand ;
M: prefetchu (write-ptx-element)
"prefetchu" write-insn
dup level>> (write-ptx-element)
- " " write a>> write ;
+ " " write a>> write-ptx-operand ;
M: prmt (write-ptx-element)
"prmt" write-insn
- dup mode>> (write-ptx-element)
- write-4op ;
+ dup type>> (write-ptx-element)
+ dup mode>> (write-ptx-element) " " write
+ dup dest>> write-ptx-operand ", " write
+ dup a>> write-ptx-operand ", " write
+ dup b>> write-ptx-operand ", " write
+ dup c>> write-ptx-operand
+ drop ;
M: rcp (write-ptx-element)
"rcp" write-insn
dup write-float-env
- write-3op ;
+ write-2op ;
M: red (write-ptx-element)
"red" write-insn
dup storage-space>> (write-ptx-element)
dup write-set
dup dest-type>> (write-ptx-element)
dup write-3op
- c>> [ ", " write write ] when* ;
+ c>> [ ", " write write-ptx-operand ] when* ;
M: setp (write-ptx-element)
"setp" write-insn
dup write-set
dup type>> (write-ptx-element) " " write
- dup dest>> write
- dup |dest>> [ "|" write write ] when* ", " write
- dup a>> write ", " write
- dup b>> write
- c>> [ ", " write write ] when* ;
+ dup dest>> write-ptx-operand
+ dup |dest>> [ "|" write write-ptx-operand ] when* ", " write
+ dup a>> write-ptx-operand ", " write
+ dup b>> write-ptx-operand
+ c>> [ ", " write write-ptx-operand ] when* ;
M: shl (write-ptx-element)
"shl" write-insn
write-3op ;
"testp" write-insn
dup op>> (write-ptx-element)
write-2op ;
+M: trap (write-ptx-element)
+ "trap" write-insn drop ;
M: vote (write-ptx-element)
"vote" write-insn
dup mode>> (write-ptx-element)
write-2op ;
M: xor (write-ptx-element)
- "or" write-insn
+ "xor" write-insn
write-3op ;
+
+: ptx>string ( ptx -- string )
+ [ write-ptx ] with-string-writer ;
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.parser cuda kernel lexer parser ;
+USING: alien.parser cuda cuda.libraries cuda.utils io.backend
+kernel lexer namespaces parser ;
IN: cuda.syntax
-SYNTAX: CUDA-LIBRARY: scan scan add-cuda-library ;
+SYNTAX: CUDA-LIBRARY:
+ scan scan normalize-path
+ [ add-cuda-library ]
+ [ drop current-cuda-library set-global ] 2bi ;
SYNTAX: CUDA-FUNCTION:
- scan [ create-in ] [ ] bi ";" scan-c-args drop define-cuda-word ;
+ scan [ create-in current-cuda-library get ] [ ] bi
+ ";" scan-c-args drop define-cuda-word ;
+
+: 2<<< ( dim-block dim-grid -- function-launcher )
+ 0 f function-launcher boa ;
: 3<<< ( dim-block dim-grid shared-size -- function-launcher )
f function-launcher boa ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data alien.strings arrays
+assocs byte-arrays classes.struct combinators cuda.ffi io
+io.backend io.encodings.utf8 kernel math.parser namespaces
+prettyprint sequences ;
+IN: cuda.utils
+
+SYMBOL: cuda-device
+SYMBOL: cuda-context
+SYMBOL: cuda-module
+SYMBOL: cuda-function
+SYMBOL: cuda-launcher
+
+SYMBOL: cuda-modules
+SYMBOL: cuda-functions
+
+ERROR: throw-cuda-error n ;
+
+: cuda-error ( n -- )
+ dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error ] if ;
+
+: init-cuda ( -- )
+ 0 cuInit cuda-error ;
+
+: cuda-version ( -- n )
+ int <c-object> [ cuDriverGetVersion cuda-error ] keep *int ;
+
+: get-function-ptr* ( module string -- function )
+ [ CUfunction <c-object> ] 2dip
+ [ cuModuleGetFunction cuda-error ] 3keep 2drop *void* ;
+
+: get-function-ptr ( string -- function )
+ [ cuda-module get ] dip get-function-ptr* ;
+
+: with-cuda-function ( string quot -- )
+ [
+ get-function-ptr* cuda-function set
+ ] dip call ; inline
+
+: create-context ( flags device -- context )
+ [ CUcontext <c-object> ] 2dip
+ [ cuCtxCreate cuda-error ] 3keep 2drop *void* ;
+
+: destroy-context ( context -- ) cuCtxDestroy cuda-error ;
+
+: launch-function* ( function -- ) cuLaunch cuda-error ;
+
+: launch-function ( -- ) cuda-function get cuLaunch cuda-error ;
+
+: cuda-int* ( function offset value -- )
+ cuParamSeti cuda-error ;
+
+: cuda-int ( offset value -- )
+ [ cuda-function get ] 2dip cuda-int* ;
+
+: cuda-float* ( function offset value -- )
+ cuParamSetf cuda-error ;
+
+: cuda-float ( offset value -- )
+ [ cuda-function get ] 2dip cuda-float* ;
+
+: cuda-vector* ( function offset ptr n -- )
+ cuParamSetv cuda-error ;
+
+: cuda-vector ( offset ptr n -- )
+ [ cuda-function get ] 3dip cuda-vector* ;
+
+: param-size* ( function n -- )
+ cuParamSetSize cuda-error ;
+
+: param-size ( n -- )
+ [ cuda-function get ] dip param-size* ;
+
+: launch-function-grid* ( function width height -- )
+ cuLaunchGrid cuda-error ;
+
+: launch-function-grid ( width height -- )
+ [ cuda-function get ] 2dip
+ cuLaunchGrid cuda-error ;
+
+: function-block-shape* ( function x y z -- )
+ cuFuncSetBlockShape cuda-error ;
+
+: function-block-shape ( x y z -- )
+ [ cuda-function get ] 3dip
+ cuFuncSetBlockShape cuda-error ;
+
+: function-shared-size* ( function n -- )
+ cuFuncSetSharedSize cuda-error ;
+
+: function-shared-size ( n -- )
+ [ cuda-function get ] dip
+ cuFuncSetSharedSize cuda-error ;
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: dwarf
+
+CONSTANT: DW_TAG_array_type HEX: 01
+CONSTANT: DW_TAG_class_type HEX: 02
+CONSTANT: DW_TAG_entry_point HEX: 03
+CONSTANT: DW_TAG_enumeration_type HEX: 04
+CONSTANT: DW_TAG_formal_parameter HEX: 05
+CONSTANT: DW_TAG_imported_declaration HEX: 08
+CONSTANT: DW_TAG_label HEX: 0a
+CONSTANT: DW_TAG_lexical_block HEX: 0b
+CONSTANT: DW_TAG_member HEX: 0d
+CONSTANT: DW_TAG_pointer_type HEX: 0f
+CONSTANT: DW_TAG_reference_type HEX: 10
+CONSTANT: DW_TAG_compile_unit HEX: 11
+CONSTANT: DW_TAG_string_type HEX: 12
+CONSTANT: DW_TAG_structure_type HEX: 13
+CONSTANT: DW_TAG_subroutine_type HEX: 15
+CONSTANT: DW_TAG_typedef HEX: 16
+CONSTANT: DW_TAG_union_type HEX: 17
+CONSTANT: DW_TAG_unspecified_parameters HEX: 18
+CONSTANT: DW_TAG_variant HEX: 19
+CONSTANT: DW_TAG_common_block HEX: 1a
+CONSTANT: DW_TAG_common_inclusion HEX: 1b
+CONSTANT: DW_TAG_inheritance HEX: 1c
+CONSTANT: DW_TAG_inlined_subroutine HEX: 1d
+CONSTANT: DW_TAG_module HEX: 1e
+CONSTANT: DW_TAG_ptr_to_member_type HEX: 1f
+CONSTANT: DW_TAG_set_type HEX: 20
+CONSTANT: DW_TAG_subrange_type HEX: 21
+CONSTANT: DW_TAG_with_stmt HEX: 22
+CONSTANT: DW_TAG_access_declaration HEX: 23
+CONSTANT: DW_TAG_base_type HEX: 24
+CONSTANT: DW_TAG_catch_block HEX: 25
+CONSTANT: DW_TAG_const_type HEX: 26
+CONSTANT: DW_TAG_constant HEX: 27
+CONSTANT: DW_TAG_enumerator HEX: 28
+CONSTANT: DW_TAG_file_type HEX: 29
+CONSTANT: DW_TAG_friend HEX: 2a
+CONSTANT: DW_TAG_namelist HEX: 2b
+CONSTANT: DW_TAG_namelist_item HEX: 2c
+CONSTANT: DW_TAG_packed_type HEX: 2d
+CONSTANT: DW_TAG_subprogram HEX: 2e
+CONSTANT: DW_TAG_template_type_parameter HEX: 2f
+CONSTANT: DW_TAG_template_value_parameter HEX: 30
+CONSTANT: DW_TAG_thrown_type HEX: 31
+CONSTANT: DW_TAG_try_block HEX: 32
+CONSTANT: DW_TAG_variant_part HEX: 33
+CONSTANT: DW_TAG_variable HEX: 34
+CONSTANT: DW_TAG_volatile_type HEX: 35
+CONSTANT: DW_TAG_dwarf_procedure HEX: 36
+CONSTANT: DW_TAG_restrict_type HEX: 37
+CONSTANT: DW_TAG_interface_type HEX: 38
+CONSTANT: DW_TAG_namespace HEX: 39
+CONSTANT: DW_TAG_imported_module HEX: 3a
+CONSTANT: DW_TAG_unspecified_type HEX: 3b
+CONSTANT: DW_TAG_partial_unit HEX: 3c
+CONSTANT: DW_TAG_imported_unit HEX: 3d
+CONSTANT: DW_TAG_condition HEX: 3f
+CONSTANT: DW_TAG_shared_type HEX: 40
+CONSTANT: DW_TAG_type_unit HEX: 41
+CONSTANT: DW_TAG_rvalue_reference_type HEX: 42
+CONSTANT: DW_TAG_template_alias HEX: 43
+
+CONSTANT: DW_TAG_lo_user HEX: 4080
+
+CONSTANT: DW_TAG_MIPS_loop HEX: 4081
+CONSTANT: DW_TAG_HP_array_descriptor HEX: 4090
+CONSTANT: DW_TAG_format_label HEX: 4101
+CONSTANT: DW_TAG_function_template HEX: 4102
+CONSTANT: DW_TAG_class_template HEX: 4103
+CONSTANT: DW_TAG_GNU_BINCL HEX: 4104
+CONSTANT: DW_TAG_GNU_EINCL HEX: 4105
+CONSTANT: DW_TAG_GNU_template_template_parameter HEX: 4106
+CONSTANT: DW_TAG_GNU_template_parameter_pack HEX: 4107
+CONSTANT: DW_TAG_GNU_formal_parameter_pack HEX: 4108
+CONSTANT: DW_TAG_ALTIUM_circ_type HEX: 5101
+CONSTANT: DW_TAG_ALTIUM_mwa_circ_type HEX: 5102
+CONSTANT: DW_TAG_ALTIUM_rev_carry_type HEX: 5103
+CONSTANT: DW_TAG_ALTIUM_rom HEX: 5111
+CONSTANT: DW_TAG_upc_shared_type HEX: 8765
+CONSTANT: DW_TAG_upc_strict_type HEX: 8766
+CONSTANT: DW_TAG_upc_relaxed_type HEX: 8767
+CONSTANT: DW_TAG_PGI_kanji_type HEX: a000
+CONSTANT: DW_TAG_PGI_interface_block HEX: a020
+CONSTANT: DW_TAG_SUN_function_template HEX: 4201
+CONSTANT: DW_TAG_SUN_class_template HEX: 4202
+CONSTANT: DW_TAG_SUN_struct_template HEX: 4203
+CONSTANT: DW_TAG_SUN_union_template HEX: 4204
+CONSTANT: DW_TAG_SUN_indirect_inheritance HEX: 4205
+CONSTANT: DW_TAG_SUN_codeflags HEX: 4206
+CONSTANT: DW_TAG_SUN_memop_info HEX: 4207
+CONSTANT: DW_TAG_SUN_omp_child_func HEX: 4208
+CONSTANT: DW_TAG_SUN_rtti_descriptor HEX: 4209
+CONSTANT: DW_TAG_SUN_dtor_info HEX: 420a
+CONSTANT: DW_TAG_SUN_dtor HEX: 420b
+CONSTANT: DW_TAG_SUN_f90_interface HEX: 420c
+CONSTANT: DW_TAG_SUN_fortran_vax_structure HEX: 420d
+CONSTANT: DW_TAG_SUN_hi HEX: 42ff
+
+CONSTANT: DW_TAG_hi_user HEX: ffff
+
+CONSTANT: DW_children_no 0
+CONSTANT: DW_children_yes 1
+
+CONSTANT: DW_FORM_addr HEX: 01
+CONSTANT: DW_FORM_block2 HEX: 03
+CONSTANT: DW_FORM_block4 HEX: 04
+CONSTANT: DW_FORM_data2 HEX: 05
+CONSTANT: DW_FORM_data4 HEX: 06
+CONSTANT: DW_FORM_data8 HEX: 07
+CONSTANT: DW_FORM_string HEX: 08
+CONSTANT: DW_FORM_block HEX: 09
+CONSTANT: DW_FORM_block1 HEX: 0a
+CONSTANT: DW_FORM_data1 HEX: 0b
+CONSTANT: DW_FORM_flag HEX: 0c
+CONSTANT: DW_FORM_sdata HEX: 0d
+CONSTANT: DW_FORM_strp HEX: 0e
+CONSTANT: DW_FORM_udata HEX: 0f
+CONSTANT: DW_FORM_ref_addr HEX: 10
+CONSTANT: DW_FORM_ref1 HEX: 11
+CONSTANT: DW_FORM_ref2 HEX: 12
+CONSTANT: DW_FORM_ref4 HEX: 13
+CONSTANT: DW_FORM_ref8 HEX: 14
+CONSTANT: DW_FORM_ref_udata HEX: 15
+CONSTANT: DW_FORM_indirect HEX: 16
+CONSTANT: DW_FORM_sec_offset HEX: 17
+CONSTANT: DW_FORM_exprloc HEX: 18
+CONSTANT: DW_FORM_flag_present HEX: 19
+CONSTANT: DW_FORM_ref_sig8 HEX: 20
+
+CONSTANT: DW_AT_sibling HEX: 01
+CONSTANT: DW_AT_location HEX: 02
+CONSTANT: DW_AT_name HEX: 03
+CONSTANT: DW_AT_ordering HEX: 09
+CONSTANT: DW_AT_subscr_data HEX: 0a
+CONSTANT: DW_AT_byte_size HEX: 0b
+CONSTANT: DW_AT_bit_offset HEX: 0c
+CONSTANT: DW_AT_bit_size HEX: 0d
+CONSTANT: DW_AT_element_list HEX: 0f
+CONSTANT: DW_AT_stmt_list HEX: 10
+CONSTANT: DW_AT_low_pc HEX: 11
+CONSTANT: DW_AT_high_pc HEX: 12
+CONSTANT: DW_AT_language HEX: 13
+CONSTANT: DW_AT_member HEX: 14
+CONSTANT: DW_AT_discr HEX: 15
+CONSTANT: DW_AT_discr_value HEX: 16
+CONSTANT: DW_AT_visibility HEX: 17
+CONSTANT: DW_AT_import HEX: 18
+CONSTANT: DW_AT_string_length HEX: 19
+CONSTANT: DW_AT_common_reference HEX: 1a
+CONSTANT: DW_AT_comp_dir HEX: 1b
+CONSTANT: DW_AT_const_value HEX: 1c
+CONSTANT: DW_AT_containing_type HEX: 1d
+CONSTANT: DW_AT_default_value HEX: 1e
+CONSTANT: DW_AT_inline HEX: 20
+CONSTANT: DW_AT_is_optional HEX: 21
+CONSTANT: DW_AT_lower_bound HEX: 22
+CONSTANT: DW_AT_producer HEX: 25
+CONSTANT: DW_AT_prototyped HEX: 27
+CONSTANT: DW_AT_return_addr HEX: 2a
+CONSTANT: DW_AT_start_scope HEX: 2c
+CONSTANT: DW_AT_bit_stride HEX: 2e
+CONSTANT: DW_AT_upper_bound HEX: 2f
+CONSTANT: DW_AT_abstract_origin HEX: 31
+CONSTANT: DW_AT_accessibility HEX: 32
+CONSTANT: DW_AT_address_class HEX: 33
+CONSTANT: DW_AT_artificial HEX: 34
+CONSTANT: DW_AT_base_types HEX: 35
+CONSTANT: DW_AT_calling_convention HEX: 36
+CONSTANT: DW_AT_count HEX: 37
+CONSTANT: DW_AT_data_member_location HEX: 38
+CONSTANT: DW_AT_decl_column HEX: 39
+CONSTANT: DW_AT_decl_file HEX: 3a
+CONSTANT: DW_AT_decl_line HEX: 3b
+CONSTANT: DW_AT_declaration HEX: 3c
+CONSTANT: DW_AT_discr_list HEX: 3d
+CONSTANT: DW_AT_encoding HEX: 3e
+CONSTANT: DW_AT_external HEX: 3f
+CONSTANT: DW_AT_frame_base HEX: 40
+CONSTANT: DW_AT_friend HEX: 41
+CONSTANT: DW_AT_identifier_case HEX: 42
+CONSTANT: DW_AT_macro_info HEX: 43
+CONSTANT: DW_AT_namelist_item HEX: 44
+CONSTANT: DW_AT_priority HEX: 45
+CONSTANT: DW_AT_segment HEX: 46
+CONSTANT: DW_AT_specification HEX: 47
+CONSTANT: DW_AT_static_link HEX: 48
+CONSTANT: DW_AT_type HEX: 49
+CONSTANT: DW_AT_use_location HEX: 4a
+CONSTANT: DW_AT_variable_parameter HEX: 4b
+CONSTANT: DW_AT_virtuality HEX: 4c
+CONSTANT: DW_AT_vtable_elem_location HEX: 4d
+CONSTANT: DW_AT_allocated HEX: 4e
+CONSTANT: DW_AT_associated HEX: 4f
+CONSTANT: DW_AT_data_location HEX: 50
+CONSTANT: DW_AT_byte_stride HEX: 51
+CONSTANT: DW_AT_entry_pc HEX: 52
+CONSTANT: DW_AT_use_UTF8 HEX: 53
+CONSTANT: DW_AT_extension HEX: 54
+CONSTANT: DW_AT_ranges HEX: 55
+CONSTANT: DW_AT_trampoline HEX: 56
+CONSTANT: DW_AT_call_column HEX: 57
+CONSTANT: DW_AT_call_file HEX: 58
+CONSTANT: DW_AT_call_line HEX: 59
+CONSTANT: DW_AT_description HEX: 5a
+CONSTANT: DW_AT_binary_scale HEX: 5b
+CONSTANT: DW_AT_decimal_scale HEX: 5c
+CONSTANT: DW_AT_small HEX: 5d
+CONSTANT: DW_AT_decimal_sign HEX: 5e
+CONSTANT: DW_AT_digit_count HEX: 5f
+CONSTANT: DW_AT_picture_string HEX: 60
+CONSTANT: DW_AT_mutable HEX: 61
+CONSTANT: DW_AT_threads_scaled HEX: 62
+CONSTANT: DW_AT_explicit HEX: 63
+CONSTANT: DW_AT_object_pointer HEX: 64
+CONSTANT: DW_AT_endianity HEX: 65
+CONSTANT: DW_AT_elemental HEX: 66
+CONSTANT: DW_AT_pure HEX: 67
+CONSTANT: DW_AT_recursive HEX: 68
+CONSTANT: DW_AT_signature HEX: 69
+CONSTANT: DW_AT_main_subprogram HEX: 6a
+CONSTANT: DW_AT_data_bit_offset HEX: 6b
+CONSTANT: DW_AT_const_expr HEX: 6c
+CONSTANT: DW_AT_enum_class HEX: 6d
+CONSTANT: DW_AT_linkage_name HEX: 6e
+
+CONSTANT: DW_AT_HP_block_index HEX: 2000
+
+CONSTANT: DW_AT_lo_user HEX: 2000
+
+CONSTANT: DW_AT_MIPS_fde HEX: 2001
+CONSTANT: DW_AT_MIPS_loop_begin HEX: 2002
+CONSTANT: DW_AT_MIPS_tail_loop_begin HEX: 2003
+CONSTANT: DW_AT_MIPS_epilog_begin HEX: 2004
+CONSTANT: DW_AT_MIPS_loop_unroll_factor HEX: 2005
+CONSTANT: DW_AT_MIPS_software_pipeline_depth HEX: 2006
+CONSTANT: DW_AT_MIPS_linkage_name HEX: 2007
+CONSTANT: DW_AT_MIPS_stride HEX: 2008
+CONSTANT: DW_AT_MIPS_abstract_name HEX: 2009
+CONSTANT: DW_AT_MIPS_clone_origin HEX: 200a
+CONSTANT: DW_AT_MIPS_has_inlines HEX: 200b
+CONSTANT: DW_AT_MIPS_stride_byte HEX: 200c
+CONSTANT: DW_AT_MIPS_stride_elem HEX: 200d
+CONSTANT: DW_AT_MIPS_ptr_dopetype HEX: 200e
+CONSTANT: DW_AT_MIPS_allocatable_dopetype HEX: 200f
+CONSTANT: DW_AT_MIPS_assumed_shape_dopetype HEX: 2010
+CONSTANT: DW_AT_MIPS_assumed_size HEX: 2011
+
+CONSTANT: DW_AT_HP_unmodifiable HEX: 2001
+CONSTANT: DW_AT_HP_actuals_stmt_list HEX: 2010
+CONSTANT: DW_AT_HP_proc_per_section HEX: 2011
+CONSTANT: DW_AT_HP_raw_data_ptr HEX: 2012
+CONSTANT: DW_AT_HP_pass_by_reference HEX: 2013
+CONSTANT: DW_AT_HP_opt_level HEX: 2014
+CONSTANT: DW_AT_HP_prof_version_id HEX: 2015
+CONSTANT: DW_AT_HP_opt_flags HEX: 2016
+CONSTANT: DW_AT_HP_cold_region_low_pc HEX: 2017
+CONSTANT: DW_AT_HP_cold_region_high_pc HEX: 2018
+CONSTANT: DW_AT_HP_all_variables_modifiable HEX: 2019
+CONSTANT: DW_AT_HP_linkage_name HEX: 201a
+CONSTANT: DW_AT_HP_prof_flags HEX: 201b
+
+CONSTANT: DW_AT_CPQ_discontig_ranges HEX: 2001
+CONSTANT: DW_AT_CPQ_semantic_events HEX: 2002
+CONSTANT: DW_AT_CPQ_split_lifetimes_var HEX: 2003
+CONSTANT: DW_AT_CPQ_split_lifetimes_rtn HEX: 2004
+CONSTANT: DW_AT_CPQ_prologue_length HEX: 2005
+
+CONSTANT: DW_AT_INTEL_other_endian HEX: 2026
+
+CONSTANT: DW_AT_sf_names HEX: 2101
+CONSTANT: DW_AT_src_info HEX: 2102
+CONSTANT: DW_AT_mac_info HEX: 2103
+CONSTANT: DW_AT_src_coords HEX: 2104
+CONSTANT: DW_AT_body_begin HEX: 2105
+CONSTANT: DW_AT_body_end HEX: 2106
+CONSTANT: DW_AT_GNU_vector HEX: 2107
+CONSTANT: DW_AT_GNU_template_name HEX: 2108
+
+CONSTANT: DW_AT_ALTIUM_loclist HEX: 2300
+
+CONSTANT: DW_AT_SUN_template HEX: 2201
+CONSTANT: DW_AT_VMS_rtnbeg_pd_address HEX: 2201
+CONSTANT: DW_AT_SUN_alignment HEX: 2202
+CONSTANT: DW_AT_SUN_vtable HEX: 2203
+CONSTANT: DW_AT_SUN_count_guarantee HEX: 2204
+CONSTANT: DW_AT_SUN_command_line HEX: 2205
+CONSTANT: DW_AT_SUN_vbase HEX: 2206
+CONSTANT: DW_AT_SUN_compile_options HEX: 2207
+CONSTANT: DW_AT_SUN_language HEX: 2208
+CONSTANT: DW_AT_SUN_browser_file HEX: 2209
+CONSTANT: DW_AT_SUN_vtable_abi HEX: 2210
+CONSTANT: DW_AT_SUN_func_offsets HEX: 2211
+CONSTANT: DW_AT_SUN_cf_kind HEX: 2212
+CONSTANT: DW_AT_SUN_vtable_index HEX: 2213
+CONSTANT: DW_AT_SUN_omp_tpriv_addr HEX: 2214
+CONSTANT: DW_AT_SUN_omp_child_func HEX: 2215
+CONSTANT: DW_AT_SUN_func_offset HEX: 2216
+CONSTANT: DW_AT_SUN_memop_type_ref HEX: 2217
+CONSTANT: DW_AT_SUN_profile_id HEX: 2218
+CONSTANT: DW_AT_SUN_memop_signature HEX: 2219
+CONSTANT: DW_AT_SUN_obj_dir HEX: 2220
+CONSTANT: DW_AT_SUN_obj_file HEX: 2221
+CONSTANT: DW_AT_SUN_original_name HEX: 2222
+CONSTANT: DW_AT_SUN_hwcprof_signature HEX: 2223
+CONSTANT: DW_AT_SUN_amd64_parmdump HEX: 2224
+CONSTANT: DW_AT_SUN_part_link_name HEX: 2225
+CONSTANT: DW_AT_SUN_link_name HEX: 2226
+CONSTANT: DW_AT_SUN_pass_with_const HEX: 2227
+CONSTANT: DW_AT_SUN_return_with_const HEX: 2228
+CONSTANT: DW_AT_SUN_import_by_name HEX: 2229
+CONSTANT: DW_AT_SUN_f90_pointer HEX: 222a
+CONSTANT: DW_AT_SUN_pass_by_ref HEX: 222b
+CONSTANT: DW_AT_SUN_f90_allocatable HEX: 222c
+CONSTANT: DW_AT_SUN_f90_assumed_shape_array HEX: 222d
+CONSTANT: DW_AT_SUN_c_vla HEX: 222e
+CONSTANT: DW_AT_SUN_return_value_ptr HEX: 2230
+CONSTANT: DW_AT_SUN_dtor_start HEX: 2231
+CONSTANT: DW_AT_SUN_dtor_length HEX: 2232
+CONSTANT: DW_AT_SUN_dtor_state_initial HEX: 2233
+CONSTANT: DW_AT_SUN_dtor_state_final HEX: 2234
+CONSTANT: DW_AT_SUN_dtor_state_deltas HEX: 2235
+CONSTANT: DW_AT_SUN_import_by_lname HEX: 2236
+CONSTANT: DW_AT_SUN_f90_use_only HEX: 2237
+CONSTANT: DW_AT_SUN_namelist_spec HEX: 2238
+CONSTANT: DW_AT_SUN_is_omp_child_func HEX: 2239
+CONSTANT: DW_AT_SUN_fortran_main_alias HEX: 223a
+CONSTANT: DW_AT_SUN_fortran_based HEX: 223b
+
+CONSTANT: DW_AT_upc_threads_scaled HEX: 3210
+
+CONSTANT: DW_AT_PGI_lbase HEX: 3a00
+CONSTANT: DW_AT_PGI_soffset HEX: 3a01
+CONSTANT: DW_AT_PGI_lstride HEX: 3a02
+
+CONSTANT: DW_AT_APPLE_closure HEX: 3fe4
+CONSTANT: DW_AT_APPLE_major_runtime_vers HEX: 3fe5
+CONSTANT: DW_AT_APPLE_runtime_class HEX: 3fe6
+
+CONSTANT: DW_AT_hi_user HEX: 3fff
+
+CONSTANT: DW_OP_addr HEX: 03
+CONSTANT: DW_OP_deref HEX: 06
+CONSTANT: DW_OP_const1u HEX: 08
+CONSTANT: DW_OP_const1s HEX: 09
+CONSTANT: DW_OP_const2u HEX: 0a
+CONSTANT: DW_OP_const2s HEX: 0b
+CONSTANT: DW_OP_const4u HEX: 0c
+CONSTANT: DW_OP_const4s HEX: 0d
+CONSTANT: DW_OP_const8u HEX: 0e
+CONSTANT: DW_OP_const8s HEX: 0f
+CONSTANT: DW_OP_constu HEX: 10
+CONSTANT: DW_OP_consts HEX: 11
+CONSTANT: DW_OP_dup HEX: 12
+CONSTANT: DW_OP_drop HEX: 13
+CONSTANT: DW_OP_over HEX: 14
+CONSTANT: DW_OP_pick HEX: 15
+CONSTANT: DW_OP_swap HEX: 16
+CONSTANT: DW_OP_rot HEX: 17
+CONSTANT: DW_OP_xderef HEX: 18
+CONSTANT: DW_OP_abs HEX: 19
+CONSTANT: DW_OP_and HEX: 1a
+CONSTANT: DW_OP_div HEX: 1b
+CONSTANT: DW_OP_minus HEX: 1c
+CONSTANT: DW_OP_mod HEX: 1d
+CONSTANT: DW_OP_mul HEX: 1e
+CONSTANT: DW_OP_neg HEX: 1f
+CONSTANT: DW_OP_not HEX: 20
+CONSTANT: DW_OP_or HEX: 21
+CONSTANT: DW_OP_plus HEX: 22
+CONSTANT: DW_OP_plus_uconst HEX: 23
+CONSTANT: DW_OP_shl HEX: 24
+CONSTANT: DW_OP_shr HEX: 25
+CONSTANT: DW_OP_shra HEX: 26
+CONSTANT: DW_OP_xor HEX: 27
+CONSTANT: DW_OP_bra HEX: 28
+CONSTANT: DW_OP_eq HEX: 29
+CONSTANT: DW_OP_ge HEX: 2a
+CONSTANT: DW_OP_gt HEX: 2b
+CONSTANT: DW_OP_le HEX: 2c
+CONSTANT: DW_OP_lt HEX: 2d
+CONSTANT: DW_OP_ne HEX: 2e
+CONSTANT: DW_OP_skip HEX: 2f
+CONSTANT: DW_OP_lit0 HEX: 30
+CONSTANT: DW_OP_lit1 HEX: 31
+CONSTANT: DW_OP_lit2 HEX: 32
+CONSTANT: DW_OP_lit3 HEX: 33
+CONSTANT: DW_OP_lit4 HEX: 34
+CONSTANT: DW_OP_lit5 HEX: 35
+CONSTANT: DW_OP_lit6 HEX: 36
+CONSTANT: DW_OP_lit7 HEX: 37
+CONSTANT: DW_OP_lit8 HEX: 38
+CONSTANT: DW_OP_lit9 HEX: 39
+CONSTANT: DW_OP_lit10 HEX: 3a
+CONSTANT: DW_OP_lit11 HEX: 3b
+CONSTANT: DW_OP_lit12 HEX: 3c
+CONSTANT: DW_OP_lit13 HEX: 3d
+CONSTANT: DW_OP_lit14 HEX: 3e
+CONSTANT: DW_OP_lit15 HEX: 3f
+CONSTANT: DW_OP_lit16 HEX: 40
+CONSTANT: DW_OP_lit17 HEX: 41
+CONSTANT: DW_OP_lit18 HEX: 42
+CONSTANT: DW_OP_lit19 HEX: 43
+CONSTANT: DW_OP_lit20 HEX: 44
+CONSTANT: DW_OP_lit21 HEX: 45
+CONSTANT: DW_OP_lit22 HEX: 46
+CONSTANT: DW_OP_lit23 HEX: 47
+CONSTANT: DW_OP_lit24 HEX: 48
+CONSTANT: DW_OP_lit25 HEX: 49
+CONSTANT: DW_OP_lit26 HEX: 4a
+CONSTANT: DW_OP_lit27 HEX: 4b
+CONSTANT: DW_OP_lit28 HEX: 4c
+CONSTANT: DW_OP_lit29 HEX: 4d
+CONSTANT: DW_OP_lit30 HEX: 4e
+CONSTANT: DW_OP_lit31 HEX: 4f
+CONSTANT: DW_OP_reg0 HEX: 50
+CONSTANT: DW_OP_reg1 HEX: 51
+CONSTANT: DW_OP_reg2 HEX: 52
+CONSTANT: DW_OP_reg3 HEX: 53
+CONSTANT: DW_OP_reg4 HEX: 54
+CONSTANT: DW_OP_reg5 HEX: 55
+CONSTANT: DW_OP_reg6 HEX: 56
+CONSTANT: DW_OP_reg7 HEX: 57
+CONSTANT: DW_OP_reg8 HEX: 58
+CONSTANT: DW_OP_reg9 HEX: 59
+CONSTANT: DW_OP_reg10 HEX: 5a
+CONSTANT: DW_OP_reg11 HEX: 5b
+CONSTANT: DW_OP_reg12 HEX: 5c
+CONSTANT: DW_OP_reg13 HEX: 5d
+CONSTANT: DW_OP_reg14 HEX: 5e
+CONSTANT: DW_OP_reg15 HEX: 5f
+CONSTANT: DW_OP_reg16 HEX: 60
+CONSTANT: DW_OP_reg17 HEX: 61
+CONSTANT: DW_OP_reg18 HEX: 62
+CONSTANT: DW_OP_reg19 HEX: 63
+CONSTANT: DW_OP_reg20 HEX: 64
+CONSTANT: DW_OP_reg21 HEX: 65
+CONSTANT: DW_OP_reg22 HEX: 66
+CONSTANT: DW_OP_reg23 HEX: 67
+CONSTANT: DW_OP_reg24 HEX: 68
+CONSTANT: DW_OP_reg25 HEX: 69
+CONSTANT: DW_OP_reg26 HEX: 6a
+CONSTANT: DW_OP_reg27 HEX: 6b
+CONSTANT: DW_OP_reg28 HEX: 6c
+CONSTANT: DW_OP_reg29 HEX: 6d
+CONSTANT: DW_OP_reg30 HEX: 6e
+CONSTANT: DW_OP_reg31 HEX: 6f
+CONSTANT: DW_OP_breg0 HEX: 70
+CONSTANT: DW_OP_breg1 HEX: 71
+CONSTANT: DW_OP_breg2 HEX: 72
+CONSTANT: DW_OP_breg3 HEX: 73
+CONSTANT: DW_OP_breg4 HEX: 74
+CONSTANT: DW_OP_breg5 HEX: 75
+CONSTANT: DW_OP_breg6 HEX: 76
+CONSTANT: DW_OP_breg7 HEX: 77
+CONSTANT: DW_OP_breg8 HEX: 78
+CONSTANT: DW_OP_breg9 HEX: 79
+CONSTANT: DW_OP_breg10 HEX: 7a
+CONSTANT: DW_OP_breg11 HEX: 7b
+CONSTANT: DW_OP_breg12 HEX: 7c
+CONSTANT: DW_OP_breg13 HEX: 7d
+CONSTANT: DW_OP_breg14 HEX: 7e
+CONSTANT: DW_OP_breg15 HEX: 7f
+CONSTANT: DW_OP_breg16 HEX: 80
+CONSTANT: DW_OP_breg17 HEX: 81
+CONSTANT: DW_OP_breg18 HEX: 82
+CONSTANT: DW_OP_breg19 HEX: 83
+CONSTANT: DW_OP_breg20 HEX: 84
+CONSTANT: DW_OP_breg21 HEX: 85
+CONSTANT: DW_OP_breg22 HEX: 86
+CONSTANT: DW_OP_breg23 HEX: 87
+CONSTANT: DW_OP_breg24 HEX: 88
+CONSTANT: DW_OP_breg25 HEX: 89
+CONSTANT: DW_OP_breg26 HEX: 8a
+CONSTANT: DW_OP_breg27 HEX: 8b
+CONSTANT: DW_OP_breg28 HEX: 8c
+CONSTANT: DW_OP_breg29 HEX: 8d
+CONSTANT: DW_OP_breg30 HEX: 8e
+CONSTANT: DW_OP_breg31 HEX: 8f
+CONSTANT: DW_OP_regx HEX: 90
+CONSTANT: DW_OP_fbreg HEX: 91
+CONSTANT: DW_OP_bregx HEX: 92
+CONSTANT: DW_OP_piece HEX: 93
+CONSTANT: DW_OP_deref_size HEX: 94
+CONSTANT: DW_OP_xderef_size HEX: 95
+CONSTANT: DW_OP_nop HEX: 96
+CONSTANT: DW_OP_push_object_address HEX: 97
+CONSTANT: DW_OP_call2 HEX: 98
+CONSTANT: DW_OP_call4 HEX: 99
+CONSTANT: DW_OP_call_ref HEX: 9a
+CONSTANT: DW_OP_form_tls_address HEX: 9b
+CONSTANT: DW_OP_call_frame_cfa HEX: 9c
+CONSTANT: DW_OP_bit_piece HEX: 9d
+CONSTANT: DW_OP_implicit_value HEX: 9e
+CONSTANT: DW_OP_stack_value HEX: 9f
+
+
+CONSTANT: DW_OP_lo_user HEX: e0
+CONSTANT: DW_OP_GNU_push_tls_address HEX: e0
+CONSTANT: DW_OP_HP_unknown HEX: e0
+CONSTANT: DW_OP_HP_is_value HEX: e1
+CONSTANT: DW_OP_HP_fltconst4 HEX: e2
+CONSTANT: DW_OP_HP_fltconst8 HEX: e3
+CONSTANT: DW_OP_HP_mod_range HEX: e4
+CONSTANT: DW_OP_HP_unmod_range HEX: e5
+CONSTANT: DW_OP_HP_tls HEX: e6
+CONSTANT: DW_OP_INTEL_bit_piece HEX: e8
+CONSTANT: DW_OP_APPLE_uninit HEX: f0
+CONSTANT: DW_OP_hi_user HEX: ff
+
+CONSTANT: DW_ATE_address HEX: 1
+CONSTANT: DW_ATE_boolean HEX: 2
+CONSTANT: DW_ATE_complex_float HEX: 3
+CONSTANT: DW_ATE_float HEX: 4
+CONSTANT: DW_ATE_signed HEX: 5
+CONSTANT: DW_ATE_signed_char HEX: 6
+CONSTANT: DW_ATE_unsigned HEX: 7
+CONSTANT: DW_ATE_unsigned_char HEX: 8
+CONSTANT: DW_ATE_imaginary_float HEX: 9
+CONSTANT: DW_ATE_packed_decimal HEX: a
+CONSTANT: DW_ATE_numeric_string HEX: b
+CONSTANT: DW_ATE_edited HEX: c
+CONSTANT: DW_ATE_signed_fixed HEX: d
+CONSTANT: DW_ATE_unsigned_fixed HEX: e
+CONSTANT: DW_ATE_decimal_float HEX: f
+
+CONSTANT: DW_ATE_lo_user HEX: 80
+CONSTANT: DW_ATE_ALTIUM_fract HEX: 80
+CONSTANT: DW_ATE_ALTIUM_accum HEX: 81
+CONSTANT: DW_ATE_HP_float80 HEX: 80
+CONSTANT: DW_ATE_HP_complex_float80 HEX: 81
+CONSTANT: DW_ATE_HP_float128 HEX: 82
+CONSTANT: DW_ATE_HP_complex_float128 HEX: 83
+CONSTANT: DW_ATE_HP_floathpintel HEX: 84
+CONSTANT: DW_ATE_HP_imaginary_float80 HEX: 85
+CONSTANT: DW_ATE_HP_imaginary_float128 HEX: 86
+CONSTANT: DW_ATE_SUN_interval_float HEX: 91
+CONSTANT: DW_ATE_SUN_imaginary_float HEX: 92
+CONSTANT: DW_ATE_hi_user HEX: ff
+
+CONSTANT: DW_DS_unsigned HEX: 01
+CONSTANT: DW_DS_leading_overpunch HEX: 02
+CONSTANT: DW_DS_trailing_overpunch HEX: 03
+CONSTANT: DW_DS_leading_separate HEX: 04
+CONSTANT: DW_DS_trailing_separate HEX: 05
+
+CONSTANT: DW_END_default HEX: 00
+CONSTANT: DW_END_big HEX: 01
+CONSTANT: DW_END_little HEX: 02
+CONSTANT: DW_END_lo_user HEX: 40
+CONSTANT: DW_END_hi_user HEX: ff
+
+CONSTANT: DW_ATCF_lo_user HEX: 40
+CONSTANT: DW_ATCF_SUN_mop_bitfield HEX: 41
+CONSTANT: DW_ATCF_SUN_mop_spill HEX: 42
+CONSTANT: DW_ATCF_SUN_mop_scopy HEX: 43
+CONSTANT: DW_ATCF_SUN_func_start HEX: 44
+CONSTANT: DW_ATCF_SUN_end_ctors HEX: 45
+CONSTANT: DW_ATCF_SUN_branch_target HEX: 46
+CONSTANT: DW_ATCF_SUN_mop_stack_probe HEX: 47
+CONSTANT: DW_ATCF_SUN_func_epilog HEX: 48
+CONSTANT: DW_ATCF_hi_user HEX: ff
+
+CONSTANT: DW_ACCESS_public HEX: 01
+CONSTANT: DW_ACCESS_protected HEX: 02
+CONSTANT: DW_ACCESS_private HEX: 03
+
+CONSTANT: DW_VIS_local HEX: 01
+CONSTANT: DW_VIS_exported HEX: 02
+CONSTANT: DW_VIS_qualified HEX: 03
+
+CONSTANT: DW_VIRTUALITY_none HEX: 00
+CONSTANT: DW_VIRTUALITY_virtual HEX: 01
+CONSTANT: DW_VIRTUALITY_pure_virtual HEX: 02
+
+CONSTANT: DW_LANG_C89 HEX: 0001
+CONSTANT: DW_LANG_C HEX: 0002
+CONSTANT: DW_LANG_Ada83 HEX: 0003
+CONSTANT: DW_LANG_C_plus_plus HEX: 0004
+CONSTANT: DW_LANG_Cobol74 HEX: 0005
+CONSTANT: DW_LANG_Cobol85 HEX: 0006
+CONSTANT: DW_LANG_Fortran77 HEX: 0007
+CONSTANT: DW_LANG_Fortran90 HEX: 0008
+CONSTANT: DW_LANG_Pascal83 HEX: 0009
+CONSTANT: DW_LANG_Modula2 HEX: 000a
+CONSTANT: DW_LANG_Java HEX: 000b
+CONSTANT: DW_LANG_C99 HEX: 000c
+CONSTANT: DW_LANG_Ada95 HEX: 000d
+CONSTANT: DW_LANG_Fortran95 HEX: 000e
+CONSTANT: DW_LANG_PLI HEX: 000f
+CONSTANT: DW_LANG_ObjC HEX: 0010
+CONSTANT: DW_LANG_ObjC_plus_plus HEX: 0011
+CONSTANT: DW_LANG_UPC HEX: 0012
+CONSTANT: DW_LANG_D HEX: 0013
+CONSTANT: DW_LANG_Python HEX: 0014
+CONSTANT: DW_LANG_lo_user HEX: 8000
+CONSTANT: DW_LANG_Mips_Assembler HEX: 8001
+CONSTANT: DW_LANG_Upc HEX: 8765
+CONSTANT: DW_LANG_ALTIUM_Assembler HEX: 9101
+CONSTANT: DW_LANG_SUN_Assembler HEX: 9001
+CONSTANT: DW_LANG_hi_user HEX: ffff
+
+CONSTANT: DW_ID_case_sensitive HEX: 00
+CONSTANT: DW_ID_up_case HEX: 01
+CONSTANT: DW_ID_down_case HEX: 02
+CONSTANT: DW_ID_case_insensitive HEX: 03
+
+CONSTANT: DW_CC_normal HEX: 01
+CONSTANT: DW_CC_program HEX: 02
+CONSTANT: DW_CC_nocall HEX: 03
+
+CONSTANT: DW_CC_lo_user HEX: 40
+CONSTANT: DW_CC_ALTIUM_interrupt HEX: 65
+CONSTANT: DW_CC_ALTIUM_near_system_stack HEX: 66
+CONSTANT: DW_CC_ALTIUM_near_user_stack HEX: 67
+CONSTANT: DW_CC_ALTIUM_huge_user_stack HEX: 68
+CONSTANT: DW_CC_hi_user HEX: ff
+
+CONSTANT: DW_INL_not_inlined HEX: 00
+CONSTANT: DW_INL_inlined HEX: 01
+CONSTANT: DW_INL_declared_not_inlined HEX: 02
+CONSTANT: DW_INL_declared_inlined HEX: 03
+
+CONSTANT: DW_ORD_row_major HEX: 00
+CONSTANT: DW_ORD_col_major HEX: 01
+
+CONSTANT: DW_DSC_label HEX: 00
+CONSTANT: DW_DSC_range HEX: 01
+
+CONSTANT: DW_LNS_copy HEX: 01
+CONSTANT: DW_LNS_advance_pc HEX: 02
+CONSTANT: DW_LNS_advance_line HEX: 03
+CONSTANT: DW_LNS_set_file HEX: 04
+CONSTANT: DW_LNS_set_column HEX: 05
+CONSTANT: DW_LNS_negate_stmt HEX: 06
+CONSTANT: DW_LNS_set_basic_block HEX: 07
+CONSTANT: DW_LNS_const_add_pc HEX: 08
+CONSTANT: DW_LNS_fixed_advance_pc HEX: 09
+CONSTANT: DW_LNS_set_prologue_end HEX: 0a
+CONSTANT: DW_LNS_set_epilogue_begin HEX: 0b
+CONSTANT: DW_LNS_set_isa HEX: 0c
+
+CONSTANT: DW_LNE_end_sequence HEX: 01
+CONSTANT: DW_LNE_set_address HEX: 02
+CONSTANT: DW_LNE_define_file HEX: 03
+CONSTANT: DW_LNE_set_discriminator HEX: 04
+
+CONSTANT: DW_LNE_HP_negate_is_UV_update HEX: 11
+CONSTANT: DW_LNE_HP_push_context HEX: 12
+CONSTANT: DW_LNE_HP_pop_context HEX: 13
+CONSTANT: DW_LNE_HP_set_file_line_column HEX: 14
+CONSTANT: DW_LNE_HP_set_routine_name HEX: 15
+CONSTANT: DW_LNE_HP_set_sequence HEX: 16
+CONSTANT: DW_LNE_HP_negate_post_semantics HEX: 17
+CONSTANT: DW_LNE_HP_negate_function_exit HEX: 18
+CONSTANT: DW_LNE_HP_negate_front_end_logical HEX: 19
+CONSTANT: DW_LNE_HP_define_proc HEX: 20
+
+CONSTANT: DW_LNE_lo_user HEX: 80
+CONSTANT: DW_LNE_hi_user HEX: ff
+
+CONSTANT: DW_MACINFO_define HEX: 01
+CONSTANT: DW_MACINFO_undef HEX: 02
+CONSTANT: DW_MACINFO_start_file HEX: 03
+CONSTANT: DW_MACINFO_end_file HEX: 04
+CONSTANT: DW_MACINFO_vendor_ext HEX: ff
+
+CONSTANT: DW_CFA_advance_loc HEX: 40
+CONSTANT: DW_CFA_offset HEX: 80
+CONSTANT: DW_CFA_restore HEX: c0
+CONSTANT: DW_CFA_extended HEX: 00
+
+CONSTANT: DW_CFA_nop HEX: 00
+CONSTANT: DW_CFA_set_loc HEX: 01
+CONSTANT: DW_CFA_advance_loc1 HEX: 02
+CONSTANT: DW_CFA_advance_loc2 HEX: 03
+CONSTANT: DW_CFA_advance_loc4 HEX: 04
+CONSTANT: DW_CFA_offset_extended HEX: 05
+CONSTANT: DW_CFA_restore_extended HEX: 06
+CONSTANT: DW_CFA_undefined HEX: 07
+CONSTANT: DW_CFA_same_value HEX: 08
+CONSTANT: DW_CFA_register HEX: 09
+CONSTANT: DW_CFA_remember_state HEX: 0a
+CONSTANT: DW_CFA_restore_state HEX: 0b
+CONSTANT: DW_CFA_def_cfa HEX: 0c
+CONSTANT: DW_CFA_def_cfa_register HEX: 0d
+CONSTANT: DW_CFA_def_cfa_offset HEX: 0e
+CONSTANT: DW_CFA_def_cfa_expression HEX: 0f
+CONSTANT: DW_CFA_expression HEX: 10
+CONSTANT: DW_CFA_offset_extended_sf HEX: 11
+CONSTANT: DW_CFA_def_cfa_sf HEX: 12
+CONSTANT: DW_CFA_def_cfa_offset_sf HEX: 13
+CONSTANT: DW_CFA_val_offset HEX: 14
+CONSTANT: DW_CFA_val_offset_sf HEX: 15
+CONSTANT: DW_CFA_val_expression HEX: 16
+
+CONSTANT: DW_CFA_lo_user HEX: 1c
+CONSTANT: DW_CFA_MIPS_advance_loc8 HEX: 1d
+CONSTANT: DW_CFA_GNU_window_save HEX: 2d
+CONSTANT: DW_CFA_GNU_args_size HEX: 2e
+CONSTANT: DW_CFA_GNU_negative_offset_extended HEX: 2f
+CONSTANT: DW_CFA_high_user HEX: 3f
+
+CONSTANT: DW_EH_PE_absptr HEX: 00
+CONSTANT: DW_EH_PE_uleb128 HEX: 01
+CONSTANT: DW_EH_PE_udata2 HEX: 02
+CONSTANT: DW_EH_PE_udata4 HEX: 03
+CONSTANT: DW_EH_PE_udata8 HEX: 04
+CONSTANT: DW_EH_PE_sleb128 HEX: 09
+CONSTANT: DW_EH_PE_sdata2 HEX: 0A
+CONSTANT: DW_EH_PE_sdata4 HEX: 0B
+CONSTANT: DW_EH_PE_sdata8 HEX: 0C
+CONSTANT: DW_EH_PE_pcrel HEX: 10
+CONSTANT: DW_EH_PE_textrel HEX: 20
+CONSTANT: DW_EH_PE_datarel HEX: 30
+CONSTANT: DW_EH_PE_funcrel HEX: 40
+CONSTANT: DW_EH_PE_aligned HEX: 50
+CONSTANT: DW_EH_PE_omit HEX: ff
+
+CONSTANT: DW_FRAME_CFA_COL 0
+
+CONSTANT: DW_FRAME_REG1 1
+CONSTANT: DW_FRAME_REG2 2
+CONSTANT: DW_FRAME_REG3 3
+CONSTANT: DW_FRAME_REG4 4
+CONSTANT: DW_FRAME_REG5 5
+CONSTANT: DW_FRAME_REG6 6
+CONSTANT: DW_FRAME_REG7 7
+CONSTANT: DW_FRAME_REG8 8
+CONSTANT: DW_FRAME_REG9 9
+CONSTANT: DW_FRAME_REG10 10
+CONSTANT: DW_FRAME_REG11 11
+CONSTANT: DW_FRAME_REG12 12
+CONSTANT: DW_FRAME_REG13 13
+CONSTANT: DW_FRAME_REG14 14
+CONSTANT: DW_FRAME_REG15 15
+CONSTANT: DW_FRAME_REG16 16
+CONSTANT: DW_FRAME_REG17 17
+CONSTANT: DW_FRAME_REG18 18
+CONSTANT: DW_FRAME_REG19 19
+CONSTANT: DW_FRAME_REG20 20
+CONSTANT: DW_FRAME_REG21 21
+CONSTANT: DW_FRAME_REG22 22
+CONSTANT: DW_FRAME_REG23 23
+CONSTANT: DW_FRAME_REG24 24
+CONSTANT: DW_FRAME_REG25 25
+CONSTANT: DW_FRAME_REG26 26
+CONSTANT: DW_FRAME_REG27 27
+CONSTANT: DW_FRAME_REG28 28
+CONSTANT: DW_FRAME_REG29 29
+CONSTANT: DW_FRAME_REG30 30
+CONSTANT: DW_FRAME_REG31 31
+CONSTANT: DW_FRAME_FREG0 32
+CONSTANT: DW_FRAME_FREG1 33
+CONSTANT: DW_FRAME_FREG2 34
+CONSTANT: DW_FRAME_FREG3 35
+CONSTANT: DW_FRAME_FREG4 36
+CONSTANT: DW_FRAME_FREG5 37
+CONSTANT: DW_FRAME_FREG6 38
+CONSTANT: DW_FRAME_FREG7 39
+CONSTANT: DW_FRAME_FREG8 40
+CONSTANT: DW_FRAME_FREG9 41
+CONSTANT: DW_FRAME_FREG10 42
+CONSTANT: DW_FRAME_FREG11 43
+CONSTANT: DW_FRAME_FREG12 44
+CONSTANT: DW_FRAME_FREG13 45
+CONSTANT: DW_FRAME_FREG14 46
+CONSTANT: DW_FRAME_FREG15 47
+CONSTANT: DW_FRAME_FREG16 48
+CONSTANT: DW_FRAME_FREG17 49
+CONSTANT: DW_FRAME_FREG18 50
+CONSTANT: DW_FRAME_FREG19 51
+CONSTANT: DW_FRAME_FREG20 52
+CONSTANT: DW_FRAME_FREG21 53
+CONSTANT: DW_FRAME_FREG22 54
+CONSTANT: DW_FRAME_FREG23 55
+CONSTANT: DW_FRAME_FREG24 56
+CONSTANT: DW_FRAME_FREG25 57
+CONSTANT: DW_FRAME_FREG26 58
+CONSTANT: DW_FRAME_FREG27 59
+CONSTANT: DW_FRAME_FREG28 60
+CONSTANT: DW_FRAME_FREG29 61
+CONSTANT: DW_FRAME_FREG30 62
+CONSTANT: DW_FRAME_FREG31 63
+
+CONSTANT: DW_CHILDREN_no HEX: 00
+CONSTANT: DW_CHILDREN_yes HEX: 01
+CONSTANT: DW_ADDR_none HEX: 00
dup fluid set
init-gpu
initial-particles clone >>particles
- "resource:extra/fluids/particle2.pgm" make-texture >>texture
- "resource:extra/fluids/colors.ppm" make-texture >>ramp
+ "vocab:fluids/particle2.pgm" make-texture >>texture
+ "vocab:fluids/colors.ppm" make-texture >>ramp
drop ;
M: fluids-world end-game-world
--- /dev/null
+particle2.pgm
+colors.ppm
FUNCTION: FT_Error FT_Load_Char ( face* face, FT_ULong charcode, FT_Int32 load_flags ) ;
-C-ENUM: f
- FT_RENDER_MODE_NORMAL
- FT_RENDER_MODE_LIGHT
- FT_RENDER_MODE_MONO
- FT_RENDER_MODE_LCD
- FT_RENDER_MODE_LCD_V ;
-
-C-ENUM: f
- FT_PIXEL_MODE_NONE
- FT_PIXEL_MODE_MONO
- FT_PIXEL_MODE_GRAY
- FT_PIXEL_MODE_GRAY2
- FT_PIXEL_MODE_GRAY4
- FT_PIXEL_MODE_LCD
- FT_PIXEL_MODE_LCD_V ;
+CONSTANT: FT_RENDER_MODE_NORMAL 0
+CONSTANT: FT_RENDER_MODE_LIGHT 1
+CONSTANT: FT_RENDER_MODE_MONO 2
+CONSTANT: FT_RENDER_MODE_LCD 3
+CONSTANT: FT_RENDER_MODE_LCD_V 4
+
+CONSTANT: FT_PIXEL_MODE_NONE 0
+CONSTANT: FT_PIXEL_MODE_MONO 1
+CONSTANT: FT_PIXEL_MODE_GRAY 2
+CONSTANT: FT_PIXEL_MODE_GRAY2 3
+CONSTANT: FT_PIXEL_MODE_GRAY4 4
+CONSTANT: FT_PIXEL_MODE_LCD 5
+CONSTANT: FT_PIXEL_MODE_LCD_V 6
FUNCTION: int FT_Render_Glyph ( glyph* slot, int render_mode ) ;
M: game-loop dispose
stop-loop ;
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
-"prettyprint" "game.loop.prettyprint" require-when
+{ "game.loop" "prettyprint" } "game.loop.prettyprint" require-when
--- /dev/null
+USING: accessors game.models.half-edge kernel sequences
+tools.test ;
+IN: game.models.half-edge.tests
+
+CONSTANT: cube-edges
+ {
+ T{ edge { face 0 } { vertex 0 } { opposite-edge 6 } { next-edge 1 } }
+ T{ edge { face 0 } { vertex 1 } { opposite-edge 19 } { next-edge 2 } }
+ T{ edge { face 0 } { vertex 3 } { opposite-edge 12 } { next-edge 3 } }
+ T{ edge { face 0 } { vertex 2 } { opposite-edge 21 } { next-edge 0 } }
+
+ T{ edge { face 1 } { vertex 4 } { opposite-edge 10 } { next-edge 5 } }
+ T{ edge { face 1 } { vertex 5 } { opposite-edge 16 } { next-edge 6 } }
+ T{ edge { face 1 } { vertex 1 } { opposite-edge 0 } { next-edge 7 } }
+ T{ edge { face 1 } { vertex 0 } { opposite-edge 20 } { next-edge 4 } }
+
+ T{ edge { face 2 } { vertex 6 } { opposite-edge 14 } { next-edge 9 } }
+ T{ edge { face 2 } { vertex 7 } { opposite-edge 17 } { next-edge 10 } }
+ T{ edge { face 2 } { vertex 5 } { opposite-edge 4 } { next-edge 11 } }
+ T{ edge { face 2 } { vertex 4 } { opposite-edge 23 } { next-edge 8 } }
+
+ T{ edge { face 3 } { vertex 2 } { opposite-edge 2 } { next-edge 13 } }
+ T{ edge { face 3 } { vertex 3 } { opposite-edge 22 } { next-edge 14 } }
+ T{ edge { face 3 } { vertex 7 } { opposite-edge 8 } { next-edge 15 } }
+ T{ edge { face 3 } { vertex 6 } { opposite-edge 18 } { next-edge 12 } }
+
+ T{ edge { face 4 } { vertex 1 } { opposite-edge 5 } { next-edge 17 } }
+ T{ edge { face 4 } { vertex 5 } { opposite-edge 9 } { next-edge 18 } }
+ T{ edge { face 4 } { vertex 7 } { opposite-edge 13 } { next-edge 19 } }
+ T{ edge { face 4 } { vertex 3 } { opposite-edge 1 } { next-edge 16 } }
+
+ T{ edge { face 5 } { vertex 4 } { opposite-edge 7 } { next-edge 21 } }
+ T{ edge { face 5 } { vertex 0 } { opposite-edge 3 } { next-edge 22 } }
+ T{ edge { face 5 } { vertex 2 } { opposite-edge 15 } { next-edge 23 } }
+ T{ edge { face 5 } { vertex 6 } { opposite-edge 11 } { next-edge 20 } }
+ }
+
+: connect-cube-edges ( -- )
+ cube-edges [
+ [ cube-edges nth ] change-opposite-edge
+ [ cube-edges nth ] change-next-edge
+ drop
+ ] each ;
+
+connect-cube-edges
+
+[ 0 1 ]
+[ cube-edges first edge-vertices ] unit-test
+
+[ { 0 0 0 } ]
+[ cube-edges first vertex-edges [ vertex>> ] map ] unit-test
+
+[ 3 ]
+[ cube-edges first vertex-valence ] unit-test
+
+[ { 0 1 3 2 } ]
+[ cube-edges first face-edges [ vertex>> ] map ] unit-test
+
+[ 4 ]
+[ cube-edges first face-sides ] unit-test
+
+[ { 1 4 2 } ]
+[ cube-edges first vertex-neighbors ] unit-test
+
+[ { 3 5 6 } ]
+[ cube-edges first vertex-diagonals ] unit-test
+
+[ { 1 4 3 5 } ]
+[ cube-edges first face-neighbors ] unit-test
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays fry kernel locals math sequences ;
+IN: game.models.half-edge
+
+TUPLE: edge < identity-tuple face vertex opposite-edge next-edge ;
+
+: edge-vertices ( edge -- start end )
+ [ vertex>> ] [ opposite-edge>> vertex>> ] bi ;
+
+! building blocks for edge loop iteration
+
+: (collect) ( in quot iterator -- out )
+ [ collector ] dip dip >array ; inline
+
+: (reduce) ( in initial quot iterator -- accum )
+ [ swap ] 2dip call ; inline
+
+: (count) ( in iterator -- count )
+ [ 0 [ drop 1 + ] ] dip (reduce) ; inline
+
+: edge-loop ( ..a edge quot: ( ..a edge -- ..b ) next-edge-quot: ( ..b edge -- ..a edge' ) -- ..a )
+ pick '[ _ _ bi dup _ eq? not ] loop drop ; inline
+
+! iterate over related edges
+
+: each-vertex-edge ( ... edge quot: ( ... edge -- ... ) -- ... )
+ [ opposite-edge>> next-edge>> ] edge-loop ; inline
+
+: each-face-edge ( ... edge quot: ( ... edge -- ... ) -- ... )
+ [ next-edge>> ] edge-loop ; inline
+
+!
+
+: vertex-edges ( edge -- edges )
+ [ ] [ each-vertex-edge ] (collect) ;
+
+: vertex-neighbors ( edge -- edges )
+ [ opposite-edge>> vertex>> ] [ each-vertex-edge ] (collect) ;
+
+: vertex-diagonals ( edge -- edges )
+ [ next-edge>> opposite-edge>> vertex>> ] [ each-vertex-edge ] (collect) ;
+
+: vertex-valence ( edge -- count )
+ [ each-vertex-edge ] (count) ;
+
+: face-edges ( edge -- edges )
+ [ ] [ each-face-edge ] (collect) ;
+
+: face-neighbors ( edge -- edges )
+ [ opposite-edge>> face>> ] [ each-face-edge ] (collect) ;
+
+: face-sides ( edge -- count )
+ [ each-face-edge ] (count) ;
+
--- /dev/null
+Iterators for half-edge geometry structures
classes.tuple classes.tuple.private combinators combinators.tuple destructors fry
generic generic.parser gpu gpu.buffers gpu.framebuffers
gpu.framebuffers.private gpu.shaders gpu.shaders.private gpu.state
-gpu.textures gpu.textures.private half-floats images kernel
+gpu.textures gpu.textures.private math.floats.half images kernel
lexer locals math math.order math.parser namespaces opengl
opengl.gl parser quotations sequences slots sorting
specialized-arrays strings ui.gadgets.worlds variants
opengl opengl.gl opengl.shaders parser quotations sequences
specialized-arrays splitting strings tr ui.gadgets.worlds
variants vectors vocabs vocabs.loader vocabs.parser words
-words.constant half-floats typed ;
+words.constant math.floats.half typed ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: void*
[ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
reset-memos ;
-"prettyprint" "gpu.shaders.prettyprint" require-when
+{ "gpu.shaders" "prettyprint" } "gpu.shaders.prettyprint" require-when
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax core-foundation core-foundation.strings
+javascriptcore.ffi ;
+IN: javascriptcore.core-foundation
+
+FUNCTION: JSStringRef JSStringCreateWithCFString ( CFStringRef string ) ;
+
+FUNCTION: CFStringRef JSStringCopyCFString ( CFAllocatorRef alloc, JSStringRef string ) ;
+
+
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+classes.struct combinators io.encodings.utf16n
+io.encodings.utf8 kernel system ;
+IN: javascriptcore.ffi
+
+<<
+"javascriptcore" {
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/JavaScriptCore.framework/Versions/Current/JavaScriptCore" cdecl add-library
+ ] }
+ ! { [ os winnt? ] [ "javascriptcore.dll" ] }
+ ! { [ os unix? ] [ "libsqlite3.so" ] }
+ [ drop ]
+} cond
+>>
+
+LIBRARY: javascriptcore
+
+TYPEDEF: void* JSContextGroupRef
+TYPEDEF: void* JSContextRef
+TYPEDEF: void* JSGlobalContextRef
+TYPEDEF: void* JSStringRef
+TYPEDEF: void* JSClassRef
+TYPEDEF: void* JSPropertyNameArrayRef
+TYPEDEF: void* JSPropertyNameAccumulatorRef
+TYPEDEF: void* JSValueRef
+TYPEDEF: void* JSObjectRef
+TYPEDEF: void* JSObjectInitializeCallback
+TYPEDEF: void* JSObjectFinalizeCallback
+TYPEDEF: void* JSObjectHasPropertyCallback
+TYPEDEF: void* JSObjectGetPropertyCallback
+TYPEDEF: void* JSObjectSetPropertyCallback
+TYPEDEF: void* JSObjectDeletePropertyCallback
+TYPEDEF: void* JSObjectGetPropertyNamesCallback
+TYPEDEF: void* JSObjectCallAsFunctionCallback
+TYPEDEF: void* JSObjectCallAsConstructorCallback
+TYPEDEF: void* JSObjectHasInstanceCallback
+TYPEDEF: void* JSObjectConvertToTypeCallback
+TYPEDEF: uint unsigned
+TYPEDEF: ushort JSChar
+
+ENUM: JSPropertyAttributes
+ { kJSPropertyAttributeNone 0 }
+ { kJSPropertyAttributeReadOnly 2 }
+ { kJSPropertyAttributeDontEnum 4 }
+ { kJSPropertyAttributeDontDelete 8 } ;
+
+ENUM: JSClassAttributes
+ { kJSClassAttributeNone 0 }
+ { kJSClassAttributeNoAutomaticPrototype 2 } ;
+
+ENUM: JSType
+ kJSTypeUndefined,
+ kJSTypeNull,
+ kJSTypeBoolean,
+ kJSTypeNumber,
+ kJSTypeString,
+ kJSTypeObject ;
+
+STRUCT: JSStaticValue
+ { name c-string }
+ { getProperty JSObjectGetPropertyCallback }
+ { setProperty JSObjectSetPropertyCallback }
+ { attributes JSPropertyAttributes } ;
+
+STRUCT: JSStaticFunction
+ { name c-string }
+ { callAsFunction JSObjectCallAsFunctionCallback } ;
+
+STRUCT: JSClassDefinition
+ { version int }
+ { attributes JSClassAttributes }
+ { className c-string }
+ { parentClass JSClassRef }
+ { staticValues JSStaticValue* }
+ { staticFunctions JSStaticFunction* }
+ { initialize JSObjectInitializeCallback }
+ { finalize JSObjectFinalizeCallback }
+ { hasProperty JSObjectHasPropertyCallback }
+ { getProperty JSObjectGetPropertyCallback }
+ { setProperty JSObjectSetPropertyCallback }
+ { deleteProperty JSObjectDeletePropertyCallback }
+ { getPropertyNames JSObjectGetPropertyNamesCallback }
+ { callAsFunction JSObjectCallAsFunctionCallback }
+ { callAsConstructor JSObjectCallAsConstructorCallback }
+ { hasInstance JSObjectHasInstanceCallback }
+ { convertToType JSObjectConvertToTypeCallback } ;
+
+ALIAS: kJSClassDefinitionEmpty JSClassDefinition
+
+FUNCTION: JSValueRef JSEvaluateScript (
+ JSContextRef ctx,
+ JSStringRef script,
+ JSObjectRef thisObject,
+ JSStringRef sourceURL,
+ int startingLineNumber,
+ JSValueRef* exception ) ;
+
+FUNCTION: bool JSCheckScriptSyntax (
+ JSContextRef ctx,
+ JSStringRef script,
+ JSStringRef sourceURL,
+ int startingLineNumber,
+ JSValueRef* exception ) ;
+
+FUNCTION: void JSGarbageCollect
+ ( JSContextRef ctx ) ;
+
+FUNCTION: JSContextGroupRef JSContextGroupCreate
+ ( ) ;
+
+FUNCTION: JSContextGroupRef JSContextGroupRetain
+ ( JSContextGroupRef group ) ;
+
+FUNCTION: void JSContextGroupRelease
+ ( JSContextGroupRef group ) ;
+
+FUNCTION: JSGlobalContextRef JSGlobalContextCreate
+ ( JSClassRef globalObjectClass ) ;
+
+FUNCTION: JSGlobalContextRef JSGlobalContextCreateInGroup (
+ JSContextGroupRef group,
+ JSClassRef globalObjectClass ) ;
+
+FUNCTION: JSGlobalContextRef JSGlobalContextRetain
+ ( JSGlobalContextRef ctx ) ;
+
+FUNCTION: void JSGlobalContextRelease
+ ( JSGlobalContextRef ctx ) ;
+
+FUNCTION: JSObjectRef JSContextGetGlobalObject
+ ( JSContextRef ctx ) ;
+
+FUNCTION: JSContextGroupRef JSContextGetGroup
+ ( JSContextRef ctx ) ;
+
+FUNCTION: JSClassRef JSClassCreate
+ ( JSClassDefinition* definition ) ;
+
+FUNCTION: JSClassRef JSClassRetain
+ ( JSClassRef jsClass ) ;
+
+FUNCTION: void JSClassRelease
+ ( JSClassRef jsClass ) ;
+
+FUNCTION: JSObjectRef JSObjectMake
+ ( JSContextRef ctx,
+ JSClassRef jsClass, void* data ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeFunctionWithCallback ( JSContextRef ctx, JSStringRef name, JSObjectCallAsFunctionCallback callAsFunction ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeConstructor ( JSContextRef ctx, JSClassRef jsClass, JSObjectCallAsConstructorCallback callAsConstructor ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeArray ( JSContextRef ctx, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeDate ( JSContextRef ctx, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeError ( JSContextRef ctx, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeRegExp ( JSContextRef ctx, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeFunction ( JSContextRef ctx, JSStringRef name, unsigned parameterCount, JSStringRef parameterNames[], JSStringRef body, JSStringRef sourceURL, int startingLineNumber, JSValueRef* exception ) ;
+
+FUNCTION: JSValueRef JSObjectGetPrototype ( JSContextRef ctx, JSObjectRef object ) ;
+
+FUNCTION: void JSObjectSetPrototype ( JSContextRef ctx, JSObjectRef object, JSValueRef value ) ;
+
+FUNCTION: bool JSObjectHasProperty ( JSContextRef ctx, JSObjectRef object, JSStringRef propertyName ) ;
+
+FUNCTION: JSValueRef JSObjectGetProperty ( JSContextRef ctx, JSObjectRef object, JSStringRef propertyName, JSValueRef* exception ) ;
+
+FUNCTION: void JSObjectSetProperty ( JSContextRef ctx, JSObjectRef object, JSStringRef propertyName, JSValueRef value, JSPropertyAttributes attributes, JSValueRef* exception ) ;
+
+FUNCTION: bool JSObjectDeleteProperty ( JSContextRef ctx, JSObjectRef object, JSStringRef propertyName, JSValueRef* exception ) ;
+
+FUNCTION: JSValueRef JSObjectGetPropertyAtIndex ( JSContextRef ctx, JSObjectRef object, unsigned propertyIndex, JSValueRef* exception ) ;
+
+FUNCTION: void JSObjectSetPropertyAtIndex ( JSContextRef ctx, JSObjectRef object, unsigned propertyIndex, JSValueRef value, JSValueRef* exception ) ;
+
+FUNCTION: void* JSObjectGetPrivate ( JSObjectRef object ) ;
+
+FUNCTION: bool JSObjectSetPrivate ( JSObjectRef object, void* data ) ;
+
+FUNCTION: bool JSObjectIsFunction ( JSContextRef ctx, JSObjectRef object ) ;
+
+FUNCTION: JSValueRef JSObjectCallAsFunction ( JSContextRef ctx, JSObjectRef object, JSObjectRef thisObject, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: bool JSObjectIsConstructor ( JSContextRef ctx, JSObjectRef object ) ;
+
+FUNCTION: JSObjectRef JSObjectCallAsConstructor ( JSContextRef ctx, JSObjectRef object, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: JSPropertyNameArrayRef JSObjectCopyPropertyNames ( JSContextRef ctx, JSObjectRef object ) ;
+
+FUNCTION: JSPropertyNameArrayRef JSPropertyNameArrayRetain ( JSPropertyNameArrayRef array ) ;
+
+FUNCTION: void JSPropertyNameArrayRelease ( JSPropertyNameArrayRef array ) ;
+
+FUNCTION: size_t JSPropertyNameArrayGetCount ( JSPropertyNameArrayRef array ) ;
+
+FUNCTION: JSStringRef JSPropertyNameArrayGetNameAtIndex ( JSPropertyNameArrayRef array, size_t index ) ;
+
+FUNCTION: void JSPropertyNameAccumulatorAddName ( JSPropertyNameAccumulatorRef accumulator, JSStringRef propertyName ) ;
+
+FUNCTION: JSStringRef JSStringCreateWithCharacters ( JSChar* chars, size_t numChars ) ;
+
+FUNCTION: JSStringRef JSStringCreateWithUTF8CString ( c-string string ) ;
+
+FUNCTION: JSStringRef JSStringRetain ( JSStringRef string ) ;
+
+FUNCTION: void JSStringRelease ( JSStringRef string ) ;
+
+FUNCTION: size_t JSStringGetLength ( JSStringRef string ) ;
+
+FUNCTION: JSChar* JSStringGetCharactersPtr ( JSStringRef string ) ;
+
+FUNCTION: size_t JSStringGetMaximumUTF8CStringSize ( JSStringRef string ) ;
+
+FUNCTION: size_t JSStringGetUTF8CString ( JSStringRef string, char* buffer, size_t bufferSize ) ;
+
+FUNCTION: bool JSStringIsEqual ( JSStringRef a, JSStringRef b ) ;
+
+FUNCTION: bool JSStringIsEqualToUTF8CString ( JSStringRef a, char* b ) ;
+
+FUNCTION: JSType JSValueGetType ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsUndefined ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsNull ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsBoolean ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsNumber ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsString ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsObject ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsObjectOfClass ( JSContextRef ctx, JSValueRef value, JSClassRef jsClass ) ;
+
+FUNCTION: bool JSValueIsEqual ( JSContextRef ctx, JSValueRef a, JSValueRef b, JSValueRef* exception ) ;
+
+FUNCTION: bool JSValueIsStrictEqual ( JSContextRef ctx, JSValueRef a, JSValueRef b ) ;
+
+FUNCTION: bool JSValueIsInstanceOfConstructor ( JSContextRef ctx, JSValueRef value, JSObjectRef constructor, JSValueRef* exception ) ;
+
+FUNCTION: JSValueRef JSValueMakeUndefined ( JSContextRef ctx ) ;
+
+FUNCTION: JSValueRef JSValueMakeNull ( JSContextRef ctx ) ;
+
+FUNCTION: JSValueRef JSValueMakeBoolean ( JSContextRef ctx, bool boolean ) ;
+
+FUNCTION: JSValueRef JSValueMakeNumber ( JSContextRef ctx, double number ) ;
+
+FUNCTION: JSValueRef JSValueMakeString ( JSContextRef ctx, JSStringRef string ) ;
+
+FUNCTION: bool JSValueToBoolean ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: double JSValueToNumber ( JSContextRef ctx, JSValueRef value, JSValueRef* exception ) ;
+
+FUNCTION: JSStringRef JSValueToStringCopy ( JSContextRef ctx, JSValueRef value, JSValueRef* exception ) ;
+
+FUNCTION: JSObjectRef JSValueToObject ( JSContextRef ctx, JSValueRef value, JSValueRef* exception ) ;
+
+FUNCTION: void JSValueProtect ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: void JSValueUnprotect ( JSContextRef ctx, JSValueRef value ) ;
+
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors alien.syntax kernel kernel.private
+math system ;
+IN: javascriptcore.ffi.hack
+
+HOOK: set-callstack-bounds os ( -- )
+
+HOOK: macosx-callstack-start-offset cpu ( -- address )
+HOOK: macosx-callstack-size-offset cpu ( -- address )
+
+M: ppc macosx-callstack-start-offset HEX: 188 ;
+M: ppc macosx-callstack-size-offset HEX: 18c ;
+
+M: x86.32 macosx-callstack-start-offset HEX: c48 ;
+M: x86.32 macosx-callstack-size-offset HEX: c4c ;
+
+M: x86.64 macosx-callstack-start-offset HEX: 1860 ;
+M: x86.64 macosx-callstack-size-offset HEX: 1868 ;
+
+M: object set-callstack-bounds ;
+
+FUNCTION: void* pthread_self ( ) ;
+
+M: macosx set-callstack-bounds
+ callstack-bounds over [ alien-address ] bi@ -
+ pthread_self
+ [ macosx-callstack-size-offset set-alien-unsigned-cell ]
+ [ macosx-callstack-start-offset set-alien-cell ] bi ;
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors javascriptcore kernel tools.test ;
+IN: javascriptcore.tests
+
+[ "2" ] [ "1+1" eval-js-standalone ] unit-test
+
+[ "1+shoes" eval-js-standalone ]
+[ error>> "ReferenceError: Can't find variable: shoes" = ] must-fail-with
+
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.data byte-arrays continuations fry
+io.encodings.string io.encodings.utf8 io.files
+javascriptcore.ffi javascriptcore.ffi.hack kernel namespaces
+sequences ;
+IN: javascriptcore
+
+ERROR: javascriptcore-error error ;
+
+SYMBOL: js-context
+
+: with-global-context ( quot -- )
+ [
+ [ f JSGlobalContextCreate dup js-context set ] dip
+ [ nip '[ @ ] ]
+ [ drop '[ _ JSGlobalContextRelease ] ] 2bi
+ [ ] cleanup
+ ] with-scope ; inline
+
+: with-javascriptcore ( quot -- )
+ set-callstack-bounds
+ with-global-context ; inline
+
+: JSString>string ( JSString -- string )
+ dup JSStringGetMaximumUTF8CStringSize [ <byte-array> ] keep
+ [ JSStringGetUTF8CString drop ] [ drop ] 2bi
+ utf8 decode [ 0 = ] trim-tail ;
+
+: JSValueRef>string ( ctx JSValueRef/f -- string/f )
+ [
+ f JSValueToStringCopy
+ [ JSString>string ] [ JSStringRelease ] bi
+ ] [
+ drop f
+ ] if* ;
+
+: eval-js ( string -- result-string )
+ [ js-context get dup ] dip
+ JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
+ [ JSEvaluateScript ] keep *void*
+ dup [ nip JSValueRef>string javascriptcore-error ] [ drop JSValueRef>string ] if ;
+
+: eval-js-standalone ( string -- result-string )
+ '[ _ eval-js ] with-javascriptcore ;
+
+: eval-js-path-standalone ( path -- result-string ) utf8 file-contents eval-js-standalone ;
+
<axis-gadget> [ >>raxis ] [ add-gadget-with-border ] bi-curry bi* ;
:: (add-button-gadgets) ( gadget shelf -- )
- gadget controller>> read-controller buttons>> length [
+ gadget controller>> read-controller buttons>> length iota [
number>string [ drop ] <border-button>
shelf over add-gadget drop
] map gadget (>>buttons) ;
ALIAS: libusb_le16_to_cpu libusb_cpu_to_le16
-C-ENUM: libusb_class_code
+ENUM: libusb_class_code
{ LIBUSB_CLASS_PER_INTERFACE 0 }
{ LIBUSB_CLASS_AUDIO 1 }
{ LIBUSB_CLASS_COMM 2 }
{ LIBUSB_CLASS_DATA 10 }
{ LIBUSB_CLASS_VENDOR_SPEC HEX: ff } ;
-C-ENUM: libusb_descriptor_type
+ENUM: libusb_descriptor_type
{ LIBUSB_DT_DEVICE HEX: 01 }
{ LIBUSB_DT_CONFIG HEX: 02 }
{ LIBUSB_DT_STRING HEX: 03 }
CONSTANT: LIBUSB_ENDPOINT_ADDRESS_MASK HEX: 0f
CONSTANT: LIBUSB_ENDPOINT_DIR_MASK HEX: 80
-C-ENUM: libusb_endpoint_direction
+ENUM: libusb_endpoint_direction
{ LIBUSB_ENDPOINT_IN HEX: 80 }
{ LIBUSB_ENDPOINT_OUT HEX: 00 } ;
CONSTANT: LIBUSB_TRANSFER_TYPE_MASK HEX: 03
-C-ENUM: libusb_transfer_type
+ENUM: libusb_transfer_type
{ LIBUSB_TRANSFER_TYPE_CONTROL 0 }
{ LIBUSB_TRANSFER_TYPE_ISOCHRONOUS 1 }
{ LIBUSB_TRANSFER_TYPE_BULK 2 }
{ LIBUSB_TRANSFER_TYPE_INTERRUPT 3 } ;
-C-ENUM: libusb_standard_request
+ENUM: libusb_standard_request
{ LIBUSB_REQUEST_GET_STATUS HEX: 00 }
{ LIBUSB_REQUEST_CLEAR_FEATURE HEX: 01 }
{ LIBUSB_REQUEST_SET_FEATURE HEX: 03 }
{ LIBUSB_REQUEST_SET_INTERFACE HEX: 0B }
{ LIBUSB_REQUEST_SYNCH_FRAME HEX: 0C } ;
-C-ENUM: libusb_request_type
+ENUM: libusb_request_type
{ LIBUSB_REQUEST_TYPE_STANDARD HEX: 00 }
{ LIBUSB_REQUEST_TYPE_CLASS HEX: 20 }
{ LIBUSB_REQUEST_TYPE_VENDOR HEX: 40 }
{ LIBUSB_REQUEST_TYPE_RESERVED HEX: 60 } ;
-C-ENUM: libusb_request_recipient
+ENUM: libusb_request_recipient
{ LIBUSB_RECIPIENT_DEVICE HEX: 00 }
{ LIBUSB_RECIPIENT_INTERFACE HEX: 01 }
{ LIBUSB_RECIPIENT_ENDPOINT HEX: 02 }
CONSTANT: LIBUSB_ISO_SYNC_TYPE_MASK HEX: 0C
-C-ENUM: libusb_iso_sync_type
+ENUM: libusb_iso_sync_type
{ LIBUSB_ISO_SYNC_TYPE_NONE 0 }
{ LIBUSB_ISO_SYNC_TYPE_ASYNC 1 }
{ LIBUSB_ISO_SYNC_TYPE_ADAPTIVE 2 }
CONSTANT: LIBUSB_ISO_USAGE_TYPE_MASK HEX: 30
-C-ENUM: libusb_iso_usage_type
+ENUM: libusb_iso_usage_type
{ LIBUSB_ISO_USAGE_TYPE_DATA 0 }
{ LIBUSB_ISO_USAGE_TYPE_FEEDBACK 1 }
{ LIBUSB_ISO_USAGE_TYPE_IMPLICIT 2 } ;
C-TYPE: libusb_device
C-TYPE: libusb_device_handle
-C-ENUM: libusb_error
+ENUM: libusb_error
{ LIBUSB_SUCCESS 0 }
{ LIBUSB_ERROR_IO -1 }
{ LIBUSB_ERROR_INVALID_PARAM -2 }
{ LIBUSB_ERROR_NOT_SUPPORTED -12 }
{ LIBUSB_ERROR_OTHER -99 } ;
-C-ENUM: libusb_transfer_status
+ENUM: libusb_transfer_status
LIBUSB_TRANSFER_COMPLETED
LIBUSB_TRANSFER_ERROR
LIBUSB_TRANSFER_TIMED_OUT
LIBUSB_TRANSFER_NO_DEVICE
LIBUSB_TRANSFER_OVERFLOW ;
-C-ENUM: libusb_transfer_flags
+ENUM: libusb_transfer_flags
{ LIBUSB_TRANSFER_SHORT_NOT_OK 1 }
{ LIBUSB_TRANSFER_FREE_BUFFER 2 }
{ LIBUSB_TRANSFER_FREE_TRANSFER 4 } ;
TYPEDEF: uint unsigned
TYPEDEF: unsigned enum
-C-ENUM: LLVMAttribute
+ENUM: LLVMAttribute
{ LLVMZExtAttribute BIN: 1 }
{ LLVMSExtAttribute BIN: 10 }
{ LLVMNoReturnAttribute BIN: 100 }
{ LLVMReadNoneAttribute BIN: 1000000000 }
{ LLVMReadOnlyAttribute BIN: 10000000000 } ;
-C-ENUM: LLVMTypeKind
+ENUM: LLVMTypeKind
LLVMVoidTypeKind
LLVMFloatTypeKind
LLVMDoubleTypeKind
LLVMOpaqueTypeKind
LLVMVectorTypeKind ;
-C-ENUM: LLVMLinkage
+ENUM: LLVMLinkage
LLVMExternalLinkage
LLVMLinkOnceLinkage
LLVMWeakLinkage
LLVMExternalWeakLinkage
LLVMGhostLinkage ;
-C-ENUM: LLVMVisibility
+ENUM: LLVMVisibility
LLVMDefaultVisibility
LLVMHiddenVisibility
LLVMProtectedVisibility ;
-C-ENUM: LLVMCallConv
+ENUM: LLVMCallConv
{ LLVMCCallConv 0 }
{ LLVMFastCallConv 8 }
{ LLVMColdCallConv 9 }
{ LLVMX86StdcallCallConv 64 }
{ LLVMX86FastcallCallConv 65 } ;
-C-ENUM: LLVMIntPredicate
+ENUM: LLVMIntPredicate
{ LLVMIntEQ 32 }
{ LLVMIntNE 33 }
{ LLVMIntUGT 34 }
{ LLVMIntSLT 40 }
{ LLVMIntSLE 41 } ;
-C-ENUM: LLVMRealPredicate
+ENUM: LLVMRealPredicate
LLVMRealPredicateFalse
LLVMRealOEQ
LLVMRealOGT
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.accessors alien.c-types alien.libraries
+alien.syntax classes.struct combinators io.encodings.ascii kernel
+locals math system ;
+IN: lua
+
+<< "liblua5.1" {
+ { [ os windows? ] [ "lua5.1.dll" ] }
+ { [ os macosx? ] [ "liblua5.1.dylib" ] }
+ { [ os unix? ] [ "liblua5.1.so" ] }
+ } cond cdecl add-library >>
+LIBRARY: liblua5.1
+
+! luaconf.h
+TYPEDEF: double LUA_NUMBER
+TYPEDEF: ptrdiff_t LUA_INTEGER
+
+CONSTANT: LUA_IDSIZE 60
+
+! This is normally the BUFSIZ value of the given platform.
+: LUAL_BUFFERSIZE ( -- x )
+ {
+ { [ os windows? ] [ 512 ] }
+ { [ os macosx? ] [ 1024 ] }
+ { [ os unix? ] [ 8192 ] }
+ } cond ;
+
+! lua.h
+CONSTANT: LUA_SIGNATURE B{ 27 76 117 97 }
+CONSTANT: LUA_MULTRET -1
+
+CONSTANT: LUA_REGISTRYINDEX -10000
+CONSTANT: LUA_ENVIRONINDEX -10001
+CONSTANT: LUA_GLOBALSINDEX -10002
+
+: lua_upvalueindex ( i -- i ) [ LUA_GLOBALSINDEX ] dip - ; inline
+
+CONSTANT: LUA_YIELD 1
+CONSTANT: LUA_ERRRUN 2
+CONSTANT: LUA_ERRSYNTAX 3
+CONSTANT: LUA_ERRMEM 4
+CONSTANT: LUA_ERRERR 5
+
+C-TYPE: lua_State
+
+CALLBACK: int lua_CFunction ( lua_State* L ) ;
+CALLBACK: char* lua_Reader ( lua_State* L, void* ud, size_t* sz ) ;
+CALLBACK: int lua_Writer ( lua_State* L, void* p, size_t sz, void* ud ) ;
+CALLBACK: void* lua_Alloc ( void* ud, void* ptr, size_t osize, size_t nsize ) ;
+
+CONSTANT: LUA_TNONE -1
+CONSTANT: LUA_TNIL 0
+CONSTANT: LUA_TBOOLEAN 1
+CONSTANT: LUA_TLIGHTUSERDATA 2
+CONSTANT: LUA_TNUMBER 3
+CONSTANT: LUA_TSTRING 4
+CONSTANT: LUA_TTABLE 5
+CONSTANT: LUA_TFUNCTION 6
+CONSTANT: LUA_TUSERDATA 7
+CONSTANT: LUA_TTHREAD 8
+
+CONSTANT: LUA_MINSTACK 20
+
+TYPEDEF: LUA_NUMBER lua_Number
+TYPEDEF: LUA_INTEGER lua_Integer
+
+FUNCTION: lua_State* lua_newstate ( lua_Alloc f, void* ud ) ;
+FUNCTION: void lua_close ( lua_State* L ) ;
+FUNCTION: lua_State* lua_newthread ( lua_State* L ) ;
+
+FUNCTION: lua_CFunction lua_atpanic ( lua_State* L, lua_CFunction panicf ) ;
+
+FUNCTION: int lua_gettop ( lua_State* L ) ;
+FUNCTION: void lua_settop ( lua_State* L, int idx ) ;
+FUNCTION: void lua_pushvalue ( lua_State* L, int idx ) ;
+FUNCTION: void lua_remove ( lua_State* L, int idx ) ;
+FUNCTION: void lua_insert ( lua_State* L, int idx ) ;
+FUNCTION: void lua_replace ( lua_State* L, int idx ) ;
+FUNCTION: int lua_checkstack ( lua_State* L, int sz ) ;
+
+FUNCTION: void lua_xmove ( lua_State* from, lua_State* to, int n ) ;
+
+FUNCTION: int lua_isnumber ( lua_State* L, int idx ) ;
+FUNCTION: int lua_isstring ( lua_State* L, int idx ) ;
+FUNCTION: int lua_iscfunction ( lua_State* L, int idx ) ;
+FUNCTION: int lua_isuserdata ( lua_State* L, int idx ) ;
+FUNCTION: int lua_type ( lua_State* L, int idx ) ;
+FUNCTION: c-string[ascii] lua_typename ( lua_State* L, int tp ) ;
+
+FUNCTION: int lua_equal ( lua_State* L, int idx1, int idx2 ) ;
+FUNCTION: int lua_rawequal ( lua_State* L, int idx1, int idx2 ) ;
+FUNCTION: int lua_lessthan ( lua_State* L, int idx1, int idx2 ) ;
+
+FUNCTION: lua_Number lua_tonumber ( lua_State* L, int idx ) ;
+FUNCTION: lua_Integer lua_tointeger ( lua_State* L, int idx ) ;
+FUNCTION: int lua_toboolean ( lua_State* L, int idx ) ;
+FUNCTION: c-string[ascii] lua_tolstring ( lua_State* L, int idx, size_t* len ) ;
+FUNCTION: size_t lua_objlen ( lua_State* L, int idx ) ;
+FUNCTION: lua_CFunction lua_tocfunction ( lua_State* L, int idx ) ;
+FUNCTION: void* lua_touserdata ( lua_State* L, int idx ) ;
+FUNCTION: lua_State* lua_tothread ( lua_State* L, int idx ) ;
+FUNCTION: void* lua_topointer ( lua_State* L, int idx ) ;
+
+FUNCTION: void lua_pushnil ( lua_State* L ) ;
+FUNCTION: void lua_pushnumber ( lua_State* L, lua_Number n ) ;
+FUNCTION: void lua_pushinteger ( lua_State* L, lua_Integer n ) ;
+FUNCTION: void lua_pushlstring ( lua_State* L, char* s, size_t l ) ;
+FUNCTION: void lua_pushstring ( lua_State* L, c-string[ascii] ) ;
+! FUNCTION: c-string[ascii] lua_pushvfstring ( lua_State* L, c-string[ascii] fmt, va_list argp ) ;
+! FUNCTION: c-string[ascii] lua_pushfstring ( lua_State* L, c-string[ascii] fmt, ... ) ;
+FUNCTION: void lua_pushcclosure ( lua_State* L, lua_CFunction fn, int n ) ;
+FUNCTION: void lua_pushboolean ( lua_State* L, int b ) ;
+FUNCTION: void lua_pushlightuserdata ( lua_State* L, void* p ) ;
+FUNCTION: int lua_pushthread ( lua_State* L ) ;
+
+FUNCTION: void lua_gettable ( lua_State* L, int idx ) ;
+FUNCTION: void lua_getfield ( lua_State* L, int idx, c-string[ascii] k ) ;
+FUNCTION: void lua_rawget ( lua_State* L, int idx ) ;
+FUNCTION: void lua_rawgeti ( lua_State* L, int idx, int n ) ;
+FUNCTION: void lua_createtable ( lua_State* L, int narr, int nrec ) ;
+FUNCTION: void* lua_newuserdata ( lua_State* L, size_t sz ) ;
+FUNCTION: int lua_getmetatable ( lua_State* L, int objindex ) ;
+FUNCTION: void lua_getfenv ( lua_State* L, int idx ) ;
+
+FUNCTION: void lua_settable ( lua_State* L, int idx ) ;
+FUNCTION: void lua_setfield ( lua_State* L, int idx, c-string[ascii] k ) ;
+FUNCTION: void lua_rawset ( lua_State* L, int idx ) ;
+FUNCTION: void lua_rawseti ( lua_State* L, int idx, int n ) ;
+FUNCTION: int lua_setmetatable ( lua_State* L, int objindex ) ;
+FUNCTION: int lua_setfenv ( lua_State* L, int idx ) ;
+
+FUNCTION: void lua_call ( lua_State* L, int nargs, int nresults ) ;
+FUNCTION: int lua_pcall ( lua_State* L, int nargs, int nresults, int errfunc ) ;
+FUNCTION: int lua_cpcall ( lua_State* L, lua_CFunction func, void* ud ) ;
+FUNCTION: int lua_load ( lua_State* L, lua_Reader reader, void* dt, c-string[ascii] chunkname ) ;
+
+FUNCTION: int lua_dump ( lua_State* L, lua_Writer writer, void* data ) ;
+
+FUNCTION: int lua_yield ( lua_State* L, int nresults ) ;
+FUNCTION: int lua_resume ( lua_State* L, int narg ) ;
+FUNCTION: int lua_status ( lua_State* L ) ;
+
+CONSTANT: LUA_GCSTOP 0
+CONSTANT: LUA_GCRESTART 1
+CONSTANT: LUA_GCCOLLECT 2
+CONSTANT: LUA_GCCOUNT 3
+CONSTANT: LUA_GCCOUNTB 4
+CONSTANT: LUA_GCSTEP 5
+CONSTANT: LUA_GCSETPAUSE 6
+CONSTANT: LUA_GCSETSTEPMUL 7
+
+FUNCTION: int lua_gc ( lua_State* L, int what, int data ) ;
+
+FUNCTION: int lua_error ( lua_State* L ) ;
+FUNCTION: int lua_next ( lua_State* L, int idx ) ;
+FUNCTION: void lua_concat ( lua_State* L, int n ) ;
+FUNCTION: lua_Alloc lua_getallocf ( lua_State* L, void* *ud ) ;
+FUNCTION: void lua_setallocf ( lua_State* L, lua_Alloc f, void* ud ) ;
+
+TYPEDEF: lua_Reader lua_Chunkreader
+TYPEDEF: lua_Writer lua_Chunkwriter
+
+FUNCTION: void lua_setlevel ( lua_State* from, lua_State* to ) ;
+
+CONSTANT: LUA_HOOKCALL 0
+CONSTANT: LUA_HOOKRET 1
+CONSTANT: LUA_HOOKLINE 2
+CONSTANT: LUA_HOOKCOUNT 3
+CONSTANT: LUA_HOOKTAILRET 4
+
+: LUA_MASKCALL ( n -- n ) LUA_HOOKCALL shift ; inline
+: LUA_MASKRET ( n -- n ) LUA_HOOKRET shift ; inline
+: LUA_MASKLINE ( n -- n ) LUA_HOOKLINE shift ; inline
+: LUA_MASKCOUNT ( n -- n ) LUA_HOOKCOUNT shift ; inline
+
+C-TYPE: lua_Debug
+CALLBACK: void lua_Hook ( lua_State* L, lua_Debug* ar ) ;
+
+FUNCTION: int lua_getstack ( lua_State* L, int level, lua_Debug* ar ) ;
+FUNCTION: int lua_getinfo ( lua_State* L, c-string[ascii] what, lua_Debug* ar ) ;
+FUNCTION: c-string[ascii] lua_getlocal ( lua_State* L, lua_Debug* ar, int n ) ;
+FUNCTION: c-string[ascii] lua_setlocal ( lua_State* L, lua_Debug* ar, int n ) ;
+FUNCTION: c-string[ascii] lua_getupvalue ( lua_State* L, int funcindex, int n ) ;
+FUNCTION: c-string[ascii] lua_setupvalue ( lua_State* L, int funcindex, int n ) ;
+
+FUNCTION: int lua_sethook ( lua_State* L, lua_Hook func, int mask, int count ) ;
+FUNCTION: lua_Hook lua_gethook ( lua_State* L ) ;
+FUNCTION: int lua_gethookmask ( lua_State* L ) ;
+FUNCTION: int lua_gethookcount ( lua_State* L ) ;
+
+STRUCT: lua_Debug
+ { event int }
+ { name char* }
+ { namewhat char* }
+ { what char* }
+ { source char* }
+ { currentline int }
+ { nups int }
+ { linedefined int }
+ { lastlinedefined int }
+ { short_src char[LUA_IDSIZE] }
+ { i_ci int } ;
+
+! lauxlib.h
+
+: luaL_getn ( L i -- int ) lua_objlen ; inline
+: luaL_setn ( L i j -- ) 3drop ; inline
+
+: LUA_ERRFILE ( -- x ) LUA_ERRERR 1 + ;
+
+STRUCT: luaL_Reg
+ { name char* }
+ { func lua_CFunction } ;
+
+FUNCTION: void luaI_openlib ( lua_State* L, c-string[ascii] libname, luaL_Reg* l, int nup ) ;
+FUNCTION: void luaL_register ( lua_State* L, c-string[ascii] libname, luaL_Reg* l ) ;
+FUNCTION: int luaL_getmetafield ( lua_State* L, int obj, c-string[ascii] e ) ;
+FUNCTION: int luaL_callmeta ( lua_State* L, int obj, c-string[ascii] e ) ;
+FUNCTION: int luaL_typerror ( lua_State* L, int narg, c-string[ascii] tname ) ;
+FUNCTION: int luaL_argerror ( lua_State* L, int numarg, c-string[ascii] extramsg ) ;
+FUNCTION: c-string[ascii] luaL_checklstring ( lua_State* L, int numArg, size_t* l ) ;
+FUNCTION: c-string[ascii] luaL_optlstring ( lua_State* L, int numArg, c-string[ascii] def, size_t* l ) ;
+FUNCTION: lua_Number luaL_checknumber ( lua_State* L, int numArg ) ;
+FUNCTION: lua_Number luaL_optnumber ( lua_State* L, int nArg, lua_Number def ) ;
+
+FUNCTION: lua_Integer luaL_checkinteger ( lua_State* L, int numArg ) ;
+FUNCTION: lua_Integer luaL_optinteger ( lua_State* L, int nArg, lua_Integer def ) ;
+
+FUNCTION: void luaL_checkstack ( lua_State* L, int sz, c-string[ascii] msg ) ;
+FUNCTION: void luaL_checktype ( lua_State* L, int narg, int t ) ;
+FUNCTION: void luaL_checkany ( lua_State* L, int narg ) ;
+
+FUNCTION: int luaL_newmetatable ( lua_State* L, c-string[ascii] tname ) ;
+FUNCTION: void* luaL_checkudata ( lua_State* L, int ud, c-string[ascii] tname ) ;
+
+FUNCTION: void luaL_where ( lua_State* L, int lvl ) ;
+! FUNCTION: int luaL_error ( lua_State* L, c-string[ascii] fmt, ... ) ;
+FUNCTION: int luaL_checkoption ( lua_State* L, int narg, c-string[ascii] def, c-string[ascii] lst ) ;
+
+FUNCTION: int luaL_ref ( lua_State* L, int t ) ;
+FUNCTION: void luaL_unref ( lua_State* L, int t, int ref ) ;
+
+FUNCTION: int luaL_loadfile ( lua_State* L, c-string[ascii] filename ) ;
+FUNCTION: int luaL_loadbuffer ( lua_State* L, c-string[ascii] buff, size_t sz, c-string[ascii] name ) ;
+FUNCTION: int luaL_loadstring ( lua_State* L, c-string[ascii] s ) ;
+
+FUNCTION: lua_State* luaL_newstate ( ) ;
+FUNCTION: c-string[ascii] luaL_gsub ( lua_State* L, c-string[ascii] s, c-string[ascii] p, c-string[ascii] r ) ;
+FUNCTION: c-string[ascii] luaL_findtable ( lua_State* L, int idx, c-string[ascii] fname, int szhint ) ;
+
+: lua_pop ( L n -- ) neg 1 - lua_settop ; inline
+: lua_newtable ( L -- ) 0 0 lua_createtable ; inline
+: lua_pushcfunction ( L f -- ) 0 lua_pushcclosure ; inline
+: lua_setglobal ( L s -- ) [ LUA_GLOBALSINDEX ] dip lua_setfield ; inline
+: lua_register ( L n f -- ) pick swap lua_pushcfunction lua_setglobal ; inline
+: lua_strlen ( L i -- size_t ) lua_objlen ; inline
+: lua_isfunction ( L n -- ? ) lua_type LUA_TFUNCTION = ; inline
+: lua_istable ( L n -- ? ) lua_type LUA_TTABLE = ; inline
+: lua_islightuserdata ( L n -- ? ) lua_type LUA_TLIGHTUSERDATA = ; inline
+: lua_isnil ( L n -- ? ) lua_type LUA_TNIL = ; inline
+: lua_isboolean ( L n -- ? ) lua_type LUA_TBOOLEAN = ; inline
+: lua_isthread ( L n -- ? ) lua_type LUA_TTHREAD = ; inline
+: lua_isnone ( L n -- ? ) lua_type LUA_TNONE = ; inline
+: lua_isnoneornil ( L n -- ? ) lua_type 0 <= ; inline
+: lua_getglobal ( L s -- ) [ LUA_GLOBALSINDEX ] dip lua_getfield ; inline
+: lua_tostring ( L i -- string ) f lua_tolstring ; inline
+: lua_open ( -- lua_State* ) luaL_newstate ; inline
+: lua_getregistry ( L -- ) LUA_REGISTRYINDEX lua_pushvalue ; inline
+: lua_getgccount ( L -- int ) LUA_GCCOUNT 0 lua_gc ; inline
+
+: luaL_argcheck ( L cond numarg extramsg -- int ) rot 0 = [ luaL_argerror ] [ 3drop 1 ] if ; inline
+: luaL_checkstring ( L n -- string ) f luaL_checklstring ; inline
+: luaL_optstring ( L n d -- string ) f luaL_optlstring ; inline
+: luaL_checkint ( L n -- int ) luaL_checkinteger ; inline
+: luaL_optint ( L n d -- int ) luaL_optinteger ; inline
+: luaL_checklong ( L n -- long ) luaL_checkinteger ; inline
+: luaL_optlong ( L n d -- long ) luaL_optinteger ; inline
+
+: luaL_typename ( L i -- string ) dupd lua_type lua_typename ; inline
+: luaL_dofile ( L fn -- int )
+ dupd luaL_loadfile 0 = [
+ 0 LUA_MULTRET 0 lua_pcall
+ ] [ drop 1 ] if ; inline
+: luaL_dostring ( L s -- int )
+ dupd luaL_loadstring 0 = [
+ 0 LUA_MULTRET 0 lua_pcall
+ ] [ drop 1 ] if ; inline
+
+: luaL_getmetatable ( L n -- ) [ LUA_REGISTRYINDEX ] dip lua_getfield ; inline
+
+STRUCT: luaL_Buffer
+ { p char* }
+ { lvl int }
+ { L lua_State* }
+ { buffer char[LUAL_BUFFERSIZE] } ;
+
+FUNCTION: void luaL_buffinit ( lua_State* L, luaL_Buffer* B ) ;
+FUNCTION: char* luaL_prepbuffer ( luaL_Buffer* B ) ;
+FUNCTION: void luaL_addlstring ( luaL_Buffer* B, char* s, size_t l ) ;
+FUNCTION: void luaL_addstring ( luaL_Buffer* B, char* s ) ;
+FUNCTION: void luaL_addvalue ( luaL_Buffer* B ) ;
+FUNCTION: void luaL_pushresult ( luaL_Buffer* B ) ;
+
+:: luaL_addchar ( B c -- )
+ B p>> alien-address
+ LUAL_BUFFERSIZE B buffer>> <displaced-alien> alien-address
+ >= [ B luaL_prepbuffer drop ] when
+ c B p>> 0 set-alien-signed-1
+ B [ 1 swap <displaced-alien> ] change-p drop ; inline
+
+: luaL_putchar ( B c -- ) luaL_addchar ; inline
+: luaL_addsize ( B n -- ) [ swap <displaced-alien> ] curry change-p drop ; inline
--- /dev/null
+FFI bindings to the Lua programming language.
{ r_address_type_length_pcrel_scattered uint }
{ r_value int } ;
-C-ENUM: reloc_type_generic
+ENUM: reloc_type_generic
GENERIC_RELOC_VANILLA
GENERIC_RELOC_PAIR
GENERIC_RELOC_SECTDIFF
GENERIC_RELOC_PB_LA_PTR
GENERIC_RELOC_LOCAL_SECTDIFF ;
-C-ENUM: reloc_type_x86_64
+ENUM: reloc_type_x86_64
X86_64_RELOC_UNSIGNED
X86_64_RELOC_SIGNED
X86_64_RELOC_BRANCH
X86_64_RELOC_SIGNED_2
X86_64_RELOC_SIGNED_4 ;
-C-ENUM: reloc_type_ppc
+ENUM: reloc_type_ppc
PPC_RELOC_VANILLA
PPC_RELOC_PAIR
PPC_RELOC_BR14
math.matrices math.vectors.simd math.parser math.vectors
method-chains namespaces sequences splitting threads ui ui.gadgets
ui.gadgets.worlds ui.pixel-formats specialized-arrays
-specialized-vectors literals fry
-sequences.deep destructors math.bitwise opengl.gl
+specialized-vectors fry sequences.deep destructors math.bitwise opengl.gl
game.models game.models.obj game.models.loader game.models.collada
prettyprint images.tga literals ;
FROM: alien.c-types => float ;
TYPEDEF: void* TCADB
-C-ENUM: f
- ADBOVOID
- ADBOMDB
- ADBONDB
- ADBOHDB
- ADBOBDB
- ADBOFDB
- ADBOTDB
- ADBOSKEL ;
+CONSTANT: ADBOVOID 0
+CONSTANT: ADBOMDB 1
+CONSTANT: ADBONDB 2
+CONSTANT: ADBOHDB 3
+CONSTANT: ADBOBDB 4
+CONSTANT: ADBOFDB 5
+CONSTANT: ADBOTDB 6
+CONSTANT: ADBOSKEL 7
FUNCTION: TCADB* tcadbnew ( ) ;
FUNCTION: void tcadbdel ( TCADB* adb ) ;
TYPEDEF: void* BDBCUR
-C-ENUM: f
- BDBCPCURRENT
- BDBCPBEFORE
- BDBCPAFTER ;
+CONSTANT: BDBCPCURRENT 0
+CONSTANT: BDBCPBEFORE 1
+CONSTANT: BDBCPAFTER 2
FUNCTION: c-string tcbdberrmsg ( int ecode ) ;
FUNCTION: TCBDB* tcbdbnew ( ) ;
! { timeout double }
! { opts int } ;
-C-ENUM: f
- TTESUCCESS
- TTEINVALID
- TTENOHOST
- TTEREFUSED
- TTESEND
- TTERECV
- TTEKEEP
- TTENOREC ;
-CONSTANT: TTEMISC 9999
+CONSTANT: TTESUCCESS 0
+CONSTANT: TTEINVALID 1
+CONSTANT: TTENOHOST 2
+CONSTANT: TTEREFUSED 3
+CONSTANT: TTESEND 4
+CONSTANT: TTERECV 5
+CONSTANT: TTEKEEP 6
+CONSTANT: TTENOREC 7
+CONSTANT: TTEMISC 9999
CONSTANT: RDBTRECON 1
CONSTANT: RDBXOLCKREC 1
CONSTANT: TDBOLCKNB 32
CONSTANT: TDBOTSYNC 64
-C-ENUM: f
- TDBITLEXICAL
- TDBITDECIMAL ;
+CONSTANT: TDBITLEXICAL 0
+CONSTANT: TDBITDECIMAL 1
CONSTANT: TDBITOPT 9998
CONSTANT: TDBITVOID 9999
C-TYPE: TDBCOND
C-TYPE: TDBQRY
-C-ENUM: f
- TDBQCSTREQ
- TDBQCSTRINC
- TDBQCSTRBW
- TDBQCSTREW
- TDBQCSTRAND
- TDBQCSTROR
- TDBQCSTROREQ
- TDBQCSTRRX
- TDBQCNUMEQ
- TDBQCNUMGT
- TDBQCNUMGE
- TDBQCNUMLT
- TDBQCNUMLE
- TDBQCNUMBT
- TDBQCNUMOREQ ;
+CONSTANT: TDBQCSTREQ 0
+CONSTANT: TDBQCSTRINC 1
+CONSTANT: TDBQCSTRBW 2
+CONSTANT: TDBQCSTREW 3
+CONSTANT: TDBQCSTRAND 4
+CONSTANT: TDBQCSTROR 5
+CONSTANT: TDBQCSTROREQ 6
+CONSTANT: TDBQCSTRRX 7
+CONSTANT: TDBQCNUMEQ 8
+CONSTANT: TDBQCNUMGT 9
+CONSTANT: TDBQCNUMGE 10
+CONSTANT: TDBQCNUMLT 11
+CONSTANT: TDBQCNUMLE 12
+CONSTANT: TDBQCNUMBT 13
+CONSTANT: TDBQCNUMOREQ 14
CONSTANT: TDBQCNEGATE 16777216
CONSTANT: TDBQCNOIDX 33554432
-C-ENUM: f
- TDBQOSTRASC
- TDBQOSTRDESC
- TDBQONUMASC
- TDBQONUMDESC ;
+CONSTANT: TDBQOSTRASC 0
+CONSTANT: TDBQOSTRDESC 1
+CONSTANT: TDBQONUMASC 2
+CONSTANT: TDBQONUMDESC 3
CONSTANT: TDBQPPUT 1
CONSTANT: TDBQPOUT 2
LIBRARY: tokyocabinet
-C-ENUM: f
- TCDBTHASH
- TCDBTBTREE
- TCDBTFIXED
- TCDBTTABLE ;
+CONSTANT: TCDBTHASH 0
+CONSTANT: TCDBTBTREE 1
+CONSTANT: TCDBTFIXED 2
+CONSTANT: TCDBTTABLE 3
! FIXME: on windows 64bits this isn't correct, because long is 32bits there, and time_t is int64
TYPEDEF: long tokyo_time_t
+\r
;;; fuel-syntax.el --- auxiliar definitions for factor code navigation.\r
\r
;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz\r
'(":" "::" ";" "&:" "<<" "<PRIVATE" ">>"\r
"ABOUT:" "AFTER:" "ALIAS:" "ALIEN:" "ARTICLE:"\r
"B" "BEFORE:" "BIN:"\r
- "C:" "CALLBACK:" "C-ENUM:" "C-STRUCT:" "C-TYPE:" "C-UNION:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "call-next-method"\r
+ "C:" "CALLBACK:" "ENUM:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"\r
"DEFER:"\r
"EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"\r
"f" "FORGET:" "FROM:" "FUNCTION:"\r
"MEMO:" "MEMO:" "METHOD:" "MIXIN:"\r
"NAN:"\r
"OCT:"\r
- "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"\r
+ "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROTOCOL:" "PROVIDE:"\r
"QUALIFIED-WITH:" "QUALIFIED:"\r
"read-only" "RENAME:" "REQUIRE:" "REQUIRES:"\r
"SINGLETON:" "SINGLETONS:" "SLOT:" "SPECIALIZED-ARRAY:" "SPECIALIZED-ARRAYS:" "STRING:" "STRUCT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"\r
\r
(defconst fuel-syntax--indent-def-starts '("" ":"\r
"AFTER" "BEFORE"\r
- "C-ENUM" "C-STRUCT" "C-UNION" "COM-INTERFACE"\r
+ "ENUM" "COM-INTERFACE" "CONSULT"\r
"FROM" "FUNCTION:"\r
"INTERSECTION:"\r
"M" "M:" "MACRO" "MACRO:"\r
"MEMO" "MEMO:" "METHOD"\r
"SYNTAX"\r
- "PREDICATE" "PRIMITIVE"\r
+ "PREDICATE" "PRIMITIVE" "PROTOCOL"\r
"SINGLETONS"\r
"STRUCT" "SYMBOLS" "TAG" "TUPLE"\r
"TYPED" "TYPED:"\r
("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))\r
("\\_<USING:\\( \\)" (1 "<b"))\r
("\\_<\\(C\\)-ENUM: \\(;\\)" (1 "<b") (2 ">b"))\r
- ("\\_<C-ENUM:\\( \\|\n\\)" (1 "<b"))\r
+ ("\\_<ENUM:\\( \\|\n\\)" (1 "<b"))\r
("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\|\n\\)\\([^;]\\|$\\)" (1 "<b"))\r
("\\_<TUPLE: +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)" (1 "<b"))\r
("\\_<\\(SYMBOLS\\|SPECIALIZED-ARRAYS\\|SINGLETONS\\|VARIANT\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)"\r
! Internal keyset options
! (As _NONE but open for exclusive access, _CRYPT_DEFINED
! Last possible key option type, _CRYPT_DEFINED Last external keyset option)
-C-ENUM: f
- CRYPT_KEYOPT_NONE
- CRYPT_KEYOPT_READONLY
- CRYPT_KEYOPT_CREATE
- CRYPT_IKEYOPT_EXCLUSIVEACCESS
- CRYPT_KEYOPT_LAST
-;
+CONSTANT: CRYPT_KEYOPT_NONE 0
+CONSTANT: CRYPT_KEYOPT_READONLY 1
+CONSTANT: CRYPT_KEYOPT_CREATE 2
+CONSTANT: CRYPT_IKEYOPT_EXCLUSIVEACCESS 3
+CONSTANT: CRYPT_KEYOPT_LAST 4
: CRYPT_KEYOPT_LAST_EXTERNAL 3 ; inline ! = CRYPT_KEYOPT_CREATE + 1
: HPDF_COMP_MASK HEX: FF ; inline
! page mode
-C-ENUM: f
- HPDF_PAGE_MODE_USE_NONE
- HPDF_PAGE_MODE_USE_OUTLINE
- HPDF_PAGE_MODE_USE_THUMBS
- HPDF_PAGE_MODE_FULL_SCREEN
- HPDF_PAGE_MODE_EOF
-;
+CONSTANT: HPDF_PAGE_MODE_USE_NONE 0
+CONSTANT: HPDF_PAGE_MODE_USE_OUTLINE 1
+CONSTANT: HPDF_PAGE_MODE_USE_THUMBS 2
+CONSTANT: HPDF_PAGE_MODE_FULL_SCREEN 3
+CONSTANT: HPDF_PAGE_MODE_EOF 4
: error-code ( -- seq ) {
{ HEX: 1001 "HPDF_ARRAY_COUNT_ERR\nInternal error. The consistency of the data was lost." }
/* make an alien */
cell factor_vm::allot_alien(cell delegate_, cell displacement)
{
- if(delegate_ == false_object && displacement == 0)
- return false_object;
+ if(displacement == 0)
+ return delegate_;
data_root<object> delegate(delegate_,this);
data_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
FRAME_RETURN_ADDRESS(inner,this) = (char *)quot->entry_point + offset;
}
+void factor_vm::primitive_callstack_bounds()
+{
+ ctx->push(allot_alien((void*)ctx->callstack_seg->start));
+ ctx->push(allot_alien((void*)ctx->callstack_seg->end));
+}
+
}
break;
#endif
default:
- critical_error("Bad rel type",op.rel_type());
+ critical_error("Bad rel type in store_external_address()",op.rel_type());
break;
}
}
std::ostream &operator<<(std::ostream &out, const string *str)
{
for(cell i = 0; i < string_capacity(str); i++)
- out << (char)str->nth(i);
+ out << (char)str->data()[i];
return out;
}
true /* trace contexts? */);
}
-void factor_vm::inline_gc(cell *data_roots_base, cell data_roots_size)
+void factor_vm::inline_gc(cell gc_roots_)
{
- data_roots.push_back(data_root_range(data_roots_base,data_roots_size));
- primitive_minor_gc();
- data_roots.pop_back();
+ cell stack_pointer = (cell)ctx->callstack_top + sizeof(cell);
+
+ if(to_boolean(gc_roots_))
+ {
+ tagged<array> gc_roots(gc_roots_);
+
+ cell capacity = array_capacity(gc_roots.untagged());
+ for(cell i = 0; i < capacity; i++)
+ {
+ cell spill_slot = untag_fixnum(array_nth(gc_roots.untagged(),i));
+ cell *address = (cell *)(spill_slot + stack_pointer);
+ data_roots.push_back(data_root_range(address,1));
+ }
+
+ primitive_minor_gc();
+
+ for(cell i = 0; i < capacity; i++)
+ data_roots.pop_back();
+ }
+ else
+ primitive_minor_gc();
}
-VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent)
+VM_C_API void inline_gc(cell gc_roots, factor_vm *parent)
{
- parent->inline_gc(data_roots_base,data_roots_size);
+ parent->inline_gc(gc_roots);
}
/*
void start_again(gc_op op_, factor_vm *parent);
};
-VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent);
+VM_C_API void inline_gc(cell gc_roots, factor_vm *parent);
}
type since its used in a situation where relocation arguments cannot
be passed in, and so RT_DLSYM is inappropriate (Windows only) */
RT_EXCEPTION_HANDLER,
+
};
enum relocation_class {
case RT_EXCEPTION_HANDLER:
return 0;
default:
- critical_error("Bad rel type",rel_type());
+ critical_error("Bad rel type in number_of_parameters()",rel_type());
return -1; /* Can't happen */
}
}
return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
}
-struct object;
-
#define NO_TYPE_CHECK static const cell type_number = TYPE_COUNT
struct object {
cell hashcode;
u8 *data() const { return (u8 *)(this + 1); }
-
- cell nth(cell i) const;
};
struct code_block;
_(byte_array_to_bignum) \
_(callback) \
_(callstack) \
+ _(callstack_bounds) \
_(callstack_for) \
_(callstack_to_array) \
_(check_datastack) \
_(set_slot) \
_(set_special_object) \
_(set_string_nth_fast) \
- _(set_string_nth_slow) \
_(size) \
_(sleep) \
_(special_object) \
_(string) \
- _(string_nth) \
_(strip_stack_traces) \
_(system_micros) \
_(tuple) \
namespace factor
{
-cell string::nth(cell index) const
-{
- /* If high bit is set, the most significant 16 bits of the char
- come from the aux vector. The least significant bit of the
- corresponding aux vector entry is negated, so that we can
- XOR the two components together and get the original code point
- back. */
- cell lo_bits = data()[index];
-
- if((lo_bits & 0x80) == 0)
- return lo_bits;
- else
- {
- byte_array *aux = untag<byte_array>(this->aux);
- cell hi_bits = aux->data<u16>()[index];
- return (hi_bits << 7) ^ lo_bits;
- }
-}
-
-void factor_vm::set_string_nth_fast(string *str, cell index, cell ch)
-{
- str->data()[index] = (u8)ch;
-}
-
-void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
-{
- data_root<string> str(str_,this);
-
- byte_array *aux;
-
- str->data()[index] = ((ch & 0x7f) | 0x80);
-
- if(to_boolean(str->aux))
- aux = untag<byte_array>(str->aux);
- else
- {
- /* We don't need to pre-initialize the
- byte array with any data, since we
- only ever read from the aux vector
- if the most significant bit of a
- character is set. Initially all of
- the bits are clear. */
- aux = allot_uninitialized_array<byte_array>(untag_fixnum(str->length) * sizeof(u16));
-
- str->aux = tag<byte_array>(aux);
- write_barrier(&str->aux);
- }
-
- aux->data<u16>()[index] = (u16)((ch >> 7) ^ 1);
-}
-
-/* allocates memory */
-void factor_vm::set_string_nth(string *str, cell index, cell ch)
-{
- if(ch <= 0x7f)
- set_string_nth_fast(str,index,ch);
- else
- set_string_nth_slow(str,index,ch);
-}
-
/* Allocates memory */
string *factor_vm::allot_string_internal(cell capacity)
{
data_root<string> str(str_,this);
if(fill <= 0x7f)
- memset(&str->data()[start],(int)fill,capacity - start);
+ memset(&str->data()[start],(u8)fill,capacity - start);
else
{
- cell i;
+ byte_array *aux;
+ if(to_boolean(str->aux))
+ aux = untag<byte_array>(str->aux);
+ else
+ {
+ aux = allot_uninitialized_array<byte_array>(untag_fixnum(str->length) * 2);
+ str->aux = tag<byte_array>(aux);
+ write_barrier(&str->aux);
+ }
- for(i = start; i < capacity; i++)
- set_string_nth(str.untagged(),i,fill);
+ u8 lo_fill = (u8)((fill & 0x7f) | 0x80);
+ u16 hi_fill = (u16)((fill >> 7) ^ 0x1);
+ memset(&str->data()[start],lo_fill,capacity - start);
+ memset_2(&aux->data<u16>()[start],hi_fill,(capacity - start) * sizeof(u16));
}
}
if(to_boolean(str->aux))
{
- byte_array *new_aux = allot_byte_array(capacity * sizeof(u16));
-
+ byte_array *new_aux = allot_uninitialized_array<byte_array>(capacity * 2);
new_str->aux = tag<byte_array>(new_aux);
write_barrier(&new_str->aux);
ctx->push(tag<string>(reallot_string(str.untagged(),capacity)));
}
-void factor_vm::primitive_string_nth()
-{
- string *str = untag<string>(ctx->pop());
- cell index = untag_fixnum(ctx->pop());
- ctx->push(tag_fixnum(str->nth(index)));
-}
-
void factor_vm::primitive_set_string_nth_fast()
{
string *str = untag<string>(ctx->pop());
cell index = untag_fixnum(ctx->pop());
cell value = untag_fixnum(ctx->pop());
- set_string_nth_fast(str,index,value);
-}
-
-void factor_vm::primitive_set_string_nth_slow()
-{
- string *str = untag<string>(ctx->pop());
- cell index = untag_fixnum(ctx->pop());
- cell value = untag_fixnum(ctx->pop());
- set_string_nth_slow(str,index,value);
+ str->data()[index] = (u8)value;
}
}
namespace factor
{
+inline static void memset_2(void *dst, u16 pattern, size_t size)
+{
+#ifdef __APPLE__
+ cell cell_pattern = (pattern | (pattern << 16));
+ memset_pattern4(dst,&cell_pattern,size);
+#else
+ if(pattern == 0)
+ memset(dst,0,size);
+ else
+ {
+ u16 *start = (u16 *)dst;
+ u16 *end = (u16 *)((cell)dst + size);
+ while(start < end)
+ {
+ *start = pattern;
+ start++;
+ }
+ }
+#endif
+}
+
inline static void memset_cell(void *dst, cell pattern, size_t size)
{
#ifdef __APPLE__
void primitive_minor_gc();
void primitive_full_gc();
void primitive_compact_gc();
- void inline_gc(cell *data_roots_base, cell data_roots_size);
+ void inline_gc(cell gc_roots);
void primitive_enable_gc_events();
void primitive_disable_gc_events();
object *allot_object(cell type, cell size);
cell std_vector_to_array(std::vector<cell> &elements);
// strings
- cell string_nth(const string *str, cell index);
- void set_string_nth_fast(string *str, cell index, cell ch);
- void set_string_nth_slow(string *str_, cell index, cell ch);
- void set_string_nth(string *str, cell index, cell ch);
string *allot_string_internal(cell capacity);
void fill_string(string *str_, cell start, cell capacity, cell fill);
string *allot_string(cell capacity, cell fill);
bool reallot_string_in_place_p(string *str, cell capacity);
string* reallot_string(string *str_, cell capacity);
void primitive_resize_string();
- void primitive_string_nth();
void primitive_set_string_nth_fast();
- void primitive_set_string_nth_slow();
// booleans
cell tag_boolean(cell untagged)
void primitive_innermost_stack_frame_executing();
void primitive_innermost_stack_frame_scan();
void primitive_set_innermost_stack_frame_quot();
+ void primitive_callstack_bounds();
template<typename Iterator> void iterate_callstack(context *ctx, Iterator &iterator);
// alien
projects / factor.git / commitdiff