+++ /dev/null
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: alien
-USING: compiler errors generic hashtables inference inspector
-kernel lists namespaces sequences strings words ;
-
-TUPLE: alien-callback return parameters quot xt ;
-C: alien-callback make-node ;
-
-TUPLE: alien-callback-error ;
-
-M: alien-callback-error summary ( error -- )
- drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
-
-: alien-callback ( return parameters quot -- address )
- <alien-callback-error> throw ;
-
-: callback-bottom ( node -- )
- alien-callback-xt [ word-xt <alien> ] curry infer-quot ;
-
-\ alien-callback [ [ string object general-list ] [ alien ] ]
-"infer-effect" set-word-prop
-
-\ alien-callback [
- empty-node <alien-callback>
- pop-literal nip over set-alien-callback-quot
- pop-literal nip over set-alien-callback-parameters
- pop-literal nip over set-alien-callback-return
- gensym over set-alien-callback-xt
- dup node,
- callback-bottom
-] "infer" set-word-prop
-
-: box-parameters ( parameters -- )
- [ box-parameter ] each-parameter ;
-
-: registers>objects ( parameters -- )
- dup \ %freg>stack move-parameters
- "nest_stacks" f %alien-invoke box-parameters ;
-
-: unbox-return ( node -- )
- alien-callback-return [
- "unnest_stacks" f %alien-invoke
- ] [
- c-type [
- "reg-class" get
- "unboxer-function" get
- %callback-value
- ] bind
- ] if-void ;
-
-: generate-callback ( node -- )
- [ alien-callback-xt ] keep [
- dup alien-callback-parameters registers>objects
- dup alien-callback-quot \ init-error-handler swons
- %alien-callback
- unbox-return
- %return
- ] generate-block ;
-
-M: alien-callback generate-node ( node -- )
- end-basic-block compile-gc generate-callback iterate-next ;
-
-M: alien-callback stack-reserve*
- alien-callback-parameters stack-space ;
+++ /dev/null
-IN: alien
-USING: errors help ;
-
-HELP: alien-callback "( return parameters quot -- alien )"
-{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "quot" "a quotation" } { "alien" "an alien address" } }
-{ $description
- "Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "\"void\"" } " indicates that no value is to be returned."
- $terpri
- "This word only runs when it is called from within a " { $emphasis "compiled" } " word, with all three parameters as literal inputs. See " { $link "compiler" } "."
- $terpri
- "When a compiled reference to this word is called, it pushes the callback's alien address on the data stack. This address can be passed to any C function expecting a C function pointer with the correct signature. The callback is actually generated when the word calling " { $link alien-callback } " is compiled."
- $terpri
- "Callback quotations run with freshly-allocated stacks. This means the data stack contains the values passed by the C function, and nothing else. It also means that if the callback throws an error which is not caught, the Factor runtime will halt. See " { $link "errors" } " for error handling options."
-}
-{ $examples
- "A simple example, showing a C function which returns the difference of two given integers:"
- { $code
- ": difference-callback ( -- alien )"
- " \"int\" { \"int\" \"int\" } [ - ] alien-callback ;"
- }
-}
-{ $see-also alien-invoke } ;
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: alien
-USING: arrays assembler compiler compiler
-errors generic hashtables inference inspector
-io kernel kernel-internals lists math namespaces parser
-prettyprint sequences strings words ;
-
-TUPLE: alien-invoke library function return parameters ;
-C: alien-invoke make-node ;
-
-: alien-invoke-stack ( node -- )
- dup alien-invoke-parameters length over consume-values
- dup alien-invoke-return "void" = 0 1 ? swap produce-values ;
-
-: alien-invoke-dlsym ( node -- symbol dll )
- dup alien-invoke-function swap alien-invoke-library
- load-library ;
-
-TUPLE: alien-invoke-error library symbol ;
-
-M: alien-invoke-error summary ( error -- )
- drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ;
-
-: alien-invoke ( ... return library function parameters -- ... )
- pick pick <alien-invoke-error> throw ;
-
-\ alien-invoke [ [ string object string object ] [ ] ]
-"infer-effect" set-word-prop
-
-\ alien-invoke [
- empty-node <alien-invoke>
- pop-literal nip over set-alien-invoke-parameters
- pop-literal nip over set-alien-invoke-function
- pop-literal nip over set-alien-invoke-library
- pop-literal nip over set-alien-invoke-return
- dup alien-invoke-dlsym dlsym drop
- dup alien-invoke-stack
- node,
-] "infer" set-word-prop
-
-: unbox-parameter ( stack# type -- )
- c-type [ "reg-class" get "unboxer" get call ] bind ;
-
-: unbox-parameters ( parameters -- )
- [ unbox-parameter ] reverse-each-parameter ;
-
-: objects>registers ( parameters -- )
- #! Generate code for boxing a list of C types, then generate
- #! code for moving these parameters to register on
- #! architectures where parameters are passed in registers
- #! (PowerPC, AMD64).
- dup unbox-parameters "save_stacks" f %alien-invoke
- \ %stack>freg move-parameters ;
-
-: box-return ( node -- )
- alien-invoke-return [ ] [ f swap box-parameter ] if-void ;
-
-: generate-cleanup ( node -- )
- dup alien-invoke-library library-abi "stdcall" = [
- drop
- ] [
- alien-invoke-parameters stack-space %cleanup
- ] if ;
-
-M: alien-invoke generate-node ( node -- )
- end-basic-block compile-gc
- dup alien-invoke-parameters objects>registers
- dup alien-invoke-dlsym %alien-invoke
- dup generate-cleanup box-return
- iterate-next ;
-
-M: alien-invoke stack-reserve*
- alien-invoke-parameters stack-space ;
-
-: parse-arglist ( return seq -- types stack-effect )
- 2 swap group unpair
- rot dup "void" = [ drop { } ] [ 1array ] if 2array
- effect>string ;
-
-: (define-c-word) ( type lib func types stack-effect -- )
- >r over create-in >r
- [ alien-invoke ] cons cons cons cons r> swap define-compound
- word r> "stack-effect" set-word-prop ;
-
-: define-c-word ( return library function parameters -- )
- [ "()" subseq? not ] subset >r pick r> parse-arglist
- (define-c-word) ;
-
-M: compound unxref-word*
- dup word-def \ alien-invoke swap member?
- over "infer" word-prop or [
- drop
- ] [
- dup
- { "infer-effect" "base-case" "no-effect" "terminates" }
- reset-props update-xt
- ] if ;
+++ /dev/null
-IN: alien
-USING: help ;
-
-HELP: alien-invoke "( ... return library function parameters -- ... )"
-{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
-{ $description "Calls a C library function with the given name. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $snippet "\"void\"" } " indicates that no value is to be expected."
-$terpri
-"This word only runs when it is called from within a " { $emphasis "compiled" } " word, with all four parameters as literal inputs. See " { $link "compiler" } "." }
-{ $see-also alien-callback } ;
-
-HELP: define-c-word "( return library function parameters -- )"
-{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
-{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
-{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: alien
-USING: arrays hashtables io kernel lists math namespaces parser
-sequences ;
-
-: <alien> ( address -- alien ) f <displaced-alien> ; inline
-
-UNION: c-ptr byte-array alien ;
-
-M: alien = ( obj obj -- ? )
- over alien? [
- 2dup [ expired? ] 2apply 2dup or [
- 2swap 2drop
- ] [
- 2drop [ alien-address ] 2apply
- ] if =
- ] [
- 2drop f
- ] if ;
-
-global [ "libraries" nest drop ] bind
-
-: library ( name -- object ) "libraries" get hash ;
-
-: load-library ( name -- dll )
- library dup [
- [
- "dll" get dup [
- drop "name" get dlopen dup "dll" set
- ] unless
- ] bind
- ] when ;
-
-: add-library ( library name abi -- )
- "libraries" get [
- [ "abi" set "name" set ] make-hash swap set
- ] bind ;
-
-: add-simple-library ( name file -- )
- windows? ".dll" ".so" ? append
- windows? "stdcall" "cdecl" ? add-library ;
-
-: library-abi ( library -- abi )
- library "abi" swap ?hash [ "cdecl" ] unless* ;
+++ /dev/null
-IN: alien
-USING: help ;
-
-HELP: expired? "( c-ptr -- ? )"
-{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } }
-{ $description "Tests if the alien is a relic from an earlier session. When an image is loaded, any alien objects which persisted in the image are marked as being expired."
-$terpri
-"A byte array is never considered to be expired, whereas passing " { $link f } " always yields true." } ;
-
-HELP: <displaced-alien> "( displacement c-ptr -- alien )"
-{ $values { "displacement" "an integer" } { "c-ptr" "an alien, byte array, or " { $link f } } { "alien" "a new alien" } }
-{ $description "Creates a new alien address object, wrapping a raw memory address. The alien points to a location in memory which is offset by " { $snippet "displacement" } " from the address of " { $link "c-ptr" } "." }
-{ $notes "Passing a value of " { $link f } " for " { $snippet "c-ptr" } " creates an alien with an absolute address; this is how " { $link <alien> } " is implemented."
-$terpri
-"Passing a zero absolute address does not construct a new alien object, but instead makes the word output " { $link f } "." }
-{ $see-also <alien> alien-address } ;
-
-HELP: alien-address "( c-ptr -- addr )"
-{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "addr" "a non-negative integer" } }
-{ $description "Outputs the address of an alien." }
-{ $warning "Taking the address of a byte array is not safe. The byte array can be moved by the garbage collector between the time the address is taken, and when it is accessed. If you need to pass pointers to C functions which will persist across alien calls, you must allocate unmanaged memory instead. See " { $link "malloc" } "." } ;
-
-HELP: <alien> "( address -- alien )"
-{ $values { "address" "a non-negative integer" } { "alien" "a new alien address" } }
-{ $description "Creates an alien object, wrapping a raw memory address." }
-{ $notes "Alien objects are invalidated between image saves and loads." }
-{ $see-also <displaced-alien> alien-address } ;
-
-HELP: c-ptr f
-{ $description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ;
-
-HELP: library "( name -- library )"
-{ $values { "name" "a string" } { "library" "a hashtable" } }
-{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
- { $list
- { { $snippet "name" } " - the full path of the C library binary" }
- { { $snippet "abi" } " - the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
- { { $snippet "dll" } " - an instance of the " { $link dll } " class; only set if the library is loaded" }
- }
-} ;
-
-HELP: dlopen "( path -- dll )"
-{ $values { "path" "a path name string" } { "dll" "a DLL handle" } }
-{ $description "Opens a native library and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } "." }
-{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." }
-{ $notes "This is the low-level facility used to implement " { $link load-library } ". Use the latter instead." } ;
-
-HELP: dlsym "( name dll -- alien )"
-{ $values { "name" "a C symbol name" } { "dll" "a DLL handle" } { "alien" "an alien pointer" } }
-{ $description "Looks up a symbol in a native library. If " { $snippet "dll" } " is " { $link f } " looks for the symbol in the runtime executable." }
-{ $errors "Throws an error if the symbol could not be found." } ;
-
-HELP: dlclose "( dll -- )"
-{ $values { "dll" "a DLL handle" } }
-{ $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
-
-HELP: load-library "( name -- dll )"
-{ $values { "name" "a string" } { "dll" "a DLL handle" } }
-{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
-{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
-
-HELP: add-library "( name path abi -- )"
-{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
-{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
-{ $examples { $code "\"gif\" \"libgif.so\" \"cdecl\" add-library" } } ;
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: alien
-USING: arrays compiler errors generic
-hashtables kernel kernel-internals libc lists math namespaces
-parser sequences strings words ;
-
-: <c-type> ( -- type )
- H{
- { "setter" [ "Cannot read struct fields with type" throw ] }
- { "getter" [ "Cannot write struct fields with type" throw ] }
- { "boxer" [ "boxer-function" get %box ] }
- { "unboxer" [ "unboxer-function" get %unbox ] }
- { "reg-class" T{ int-regs f } }
- { "width" 0 }
- } clone ;
-
-SYMBOL: c-types
-
-: c-type ( name -- type )
- dup c-types get hash
- [ ] [ "No such C type: " swap append throw ] ?if ;
-
-: c-size ( name -- size ) "width" swap c-type hash ;
-
-: c-align ( name -- align ) "align" swap c-type hash ;
-
-: c-getter ( name -- quot ) "getter" swap c-type hash ;
-
-: c-setter ( name -- quot ) "setter" swap c-type hash ;
-
-: define-c-type ( quot name -- )
- >r <c-type> [ swap bind ] keep r> c-types get set-hash ;
- inline
-
-: <c-array> ( size type -- c-ptr )
- global [ c-size * <byte-array> ] bind ;
-
-: <c-object> ( type -- c-ptr ) 1 swap <c-array> ;
-
-: <malloc-array> ( size type -- malloc-ptr )
- global [ c-size calloc ] bind check-ptr ;
-
-: <malloc-object> ( type -- malloc-ptr ) 1 swap <malloc-array> ;
-
-: <malloc-string> ( string -- alien )
- "\0" append dup length malloc check-ptr
- [ alien-address string>memory ] keep ;
-
-: (typedef) ( old new -- ) c-types get [ >r get r> set ] bind ;
-
-: define-pointer ( type -- ) "*" append "void*" swap (typedef) ;
-
-: define-deref ( name vocab -- )
- >r dup "*" swap append r> create
- swap c-getter 0 swons define-compound ;
-
-: (define-nth) ( word type quot -- )
- >r c-size [ rot * ] curry r> append define-compound ;
-
-: define-nth ( name vocab -- )
- >r dup "-nth" append r> create
- swap dup c-getter (define-nth) ;
-
-: define-set-nth ( name vocab -- )
- >r "set-" over "-nth" append3 r> create
- swap dup c-setter (define-nth) ;
-
-: define-out ( name vocab -- )
- over [ <c-object> tuck 0 ] over c-setter append
- >r >r constructor-word r> r> cons define-compound ;
-
-: init-c-type ( name vocab -- )
- over define-pointer define-nth ;
-
-: define-primitive-type ( quot name -- )
- [ define-c-type ] keep "alien"
- 2dup init-c-type
- 2dup define-deref
- 2dup define-set-nth
- define-out ;
-
-: typedef ( old new -- )
- over "*" append over "*" append (typedef) (typedef) ;
+++ /dev/null
-IN: alien
-USING: help libc ;
-
-HELP: c-type "( name -- type )"
-{ $values { "name" "a string" } { "type" "a hashtable" } }
-{ $description "Looks up a C type by name." }
-{ $errors "Throws an error if the type does not exist." } ;
-
-HELP: c-size "( name -- size )"
-{ $values { "name" "a string" } { "size" "an integer" } }
-{ $description "Outputs the number of bytes taken up by this C type." }
-{ $examples
- "On a 32-bit system, you will get the following output:"
- { $example "USE: alien\n\"void*\" c-size ." "4" }
-}
-{ $errors "Throws an error if the type does not exist." } ;
-
-HELP: c-align "( name -- n )"
-{ $values { "name" "a string" } { "n" "an integer" } }
-{ $description "Outputs alignment at which values of this C type are padded in C structures." }
-{ $errors "Throws an error if the type does not exist." } ;
-
-HELP: c-getter "( name -- quot )"
-{ $values { "name" "a string" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } }
-{ $description "Outputs a quotation which reads values of this C type from a C structure." }
-{ $errors "Throws an error if the type does not exist." } ;
-
-HELP: c-setter "( name -- quot )"
-{ $values { "name" "a string" } { "quot" "a quotation with stack effect " { $snippet "( obj c-ptr n -- )" } } }
-{ $description "Outputs a quotation which writes values of this C type to a C structure." }
-{ $errors "Throws an error if the type does not exist." } ;
-
-HELP: <c-array> "( n type -- array )"
-{ $values { "n" "a non-negative integer" } { "type" "a string" } { "array" "a byte array" } }
-{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
-{ $errors "Throws an error if the type does not exist or the requested size is negative." }
-{ $see-also <malloc-array> } ;
-
-HELP: <c-object> "( n type -- array )"
-{ $values { "type" "a string" } { "array" "a byte array" } }
-{ $description "Creates a byte array suitable for holding a value with the given C type." }
-{ $errors "Throws an error if the type does not exist." }
-{ $see-also <malloc-object> } ;
-
-HELP: string>alien "( string -- array )"
-{ $values { "string" "a string" } { "array" "a byte array" } }
-{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
-{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." }
-{ $see-also alien>string <malloc-string> } ;
-
-HELP: alien>string "( c-ptr -- string )"
-{ $values { "c-ptr" "an alien, byte array or " { $link f } } { "string" "a string" } }
-{ $description "Reads a null-terminated 8-bit C string from the specified address." }
-{ $see-also string>alien } ;
-
-HELP: <malloc-array> "( n type -- alien )"
-{ $values { "n" "a non-negative integer" } { "type" "a string" } { "alien" "an alien address" } }
-{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if the type does not exist, if the requested size is negative, or if memory allocation fails." }
-{ $see-also <c-array> } ;
-
-HELP: <malloc-object> "( type -- alien )"
-{ $values { "type" "a string" } { "alien" "an alien address" } }
-{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if the type does not exist or if memory allocation fails." }
-{ $see-also <c-object> } ;
-
-HELP: <malloc-string> "( string -- alien )"
-{ $values { "string" "a string" } { "alien" "an alien address" } }
-{ $description "Copies a string to an unmanaged memory block large enough to hold a copy of the string in 8-bit ASCII encoding, with a trailing null byte." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if memory allocation fails." }
-{ $see-also string>alien } ;
-
-HELP: (typedef) "( old new -- )"
-{ $values { "old" "a string" } { "new" "a string" } }
-{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
-{ $notes "You should use the higher-level " { $link POSTPONE: TYPEDEF: } " word instead." }
-{ $see-also typedef POSTPONE: TYPEDEF: } ;
-
-HELP: define-pointer "( type -- )"
-{ $values { "type" "a string" } }
-{ $description "Aliases the C type " { $snippet "type*" } " to " { $snippet "void*" } "." }
-{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
-
-HELP: define-deref "( name vocab -- )"
-{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
-{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
-{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
-
-HELP: define-nth "( name vocab -- )"
-{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
-{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
-{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
-
-HELP: define-set-nth "( name vocab -- )"
-{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
-{ $description "Defines a word " { $snippet "set-" { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( value n c-ptr -- )" } " for writing the value with C type " { $snippet "name" } " to an alien pointer, displaced by a multiple of the C type's size." }
-{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
-
-HELP: define-out "( name vocab -- )"
-{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
-{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
-{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
-
-HELP: typedef "( old new -- )"
-{ $values { "old" "a string" } { "new" "a string" } }
-{ $description "Alises the C types " { $snippet "old" } " and " { $snippet "old*" } " under the names " { $snippet "new" } " and " { $snippet "new*" } ", respectively." }
-{ $notes "You should use the higher-level " { $link POSTPONE: TYPEDEF: } " word instead." }
-{ $see-also (typedef) POSTPONE: TYPEDEF: } ;
+++ /dev/null
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: alien
-USING: arrays compiler generic hashtables kernel
-kernel-internals math namespaces sequences words ;
-
-: parameter-size c-size cell align ;
-
-: parameter-sizes ( types -- offsets )
- #! Compute stack frame locations.
- 0 [ parameter-size + ] accumulate ;
-
-: stack-space ( parameters -- n )
- 0 [ parameter-size + ] reduce ;
-
-: reg-class-full? ( class -- ? )
- dup class get swap fastcall-regs length >= ;
-
-: spill-param ( reg-class -- n reg-class )
- reg-size stack-params dup get -rot +@ T{ stack-params } ;
-
-: fastcall-param ( reg-class -- n reg-class )
- [ dup class get swap inc-reg-class ] keep ;
-
-: alloc-parameter ( parameter -- n reg reg-class )
- #! Allocate a register and stack frame location.
- #! n is a stack location, and the value of the class
- #! variable is a register number.
- c-type "reg-class" swap hash dup reg-class-full?
- [ spill-param ] [ fastcall-param ] if ;
-
-: flatten-value-types ( params -- params )
- #! Convert value type structs to consecutive void*s.
- [
- dup c-struct?
- [ c-size cell / "void*" <array> ] [ 1array ] if
- ] map concat ;
-
-: each-parameter ( parameters quot -- )
- >r [ parameter-sizes ] keep r> 2each ; inline
-
-: reverse-each-parameter ( parameters quot -- )
- >r [ parameter-sizes ] keep
- [ reverse-slice ] 2apply r> 2each ; inline
-
-: move-parameters ( params vop -- )
- #! Moves values from C stack to registers (if vop is
- #! %stack>freg) and registers to C stack (if vop is
- #! %freg>stack).
- swap [
- flatten-value-types
- 0 { int-regs float-regs stack-params } [ set ] each-with
- [ pick >r alloc-parameter r> execute ] each-parameter
- drop
- ] with-scope ; inline
-
-: box-parameter ( stack# type -- node )
- c-type [ "reg-class" get "boxer" get call ] bind ;
-
-: if-void ( type true false -- | false: type -- )
- pick "void" = [ drop nip call ] [ nip call ] if ; inline
-
-: compile-gc ; ! "simple_gc" f %alien-invoke , ;
+++ /dev/null
-! Copyright (C) 2004, 2005 Mackenzie Straight.
-! See http://factorcode.org/license.txt for BSD license.
-IN: libc
-USING: alien errors kernel math ;
-
-LIBRARY: libc
-FUNCTION: void* malloc ( ulong size ) ;
-FUNCTION: void* calloc ( ulong count, ulong size ) ;
-FUNCTION: void free ( void* ptr ) ;
-FUNCTION: void* realloc ( void* ptr, ulong size ) ;
-FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ;
-
-: check-ptr [ "Out of memory" throw ] unless* ;
+++ /dev/null
-IN: libc
-USING: help ;
-
-HELP: malloc "( size -- alien )"
-{ $values { "size" "a non-negative integer" } { "alien" "an alien address" } }
-{ $description "Allocates a block of " { $snippet "size" } " bytes from the operating system. The contents of the block are undefined."
-$terpri
-"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } ;
-
-HELP: calloc "( count size -- alien )"
-{ $values { "count" "a non-negative integer" } { "size" "a non-negative integer" } { "alien" "an alien address" } }
-{ $description "Allocates a block of " { $snippet "count * size" } " bytes from the operating system. The contents of the block are initially zero."
-$terpri
-"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } ;
-
-HELP: realloc "( alien size -- newalien )"
-{ $values { "alien" "an alien address" } { "size" "a non-negative integer" } { "newalien" "an alien address" } }
-{ $description "Allocates a new block of " { $snippet "size" } " bytes from the operating system. The contents of " { $snippet "alien" } ", which itself must be a block previously returned by " { $link malloc } " or " { $link realloc } ", are copied into the new block, and the old block is freed."
-$terpri
-"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } ;
-
-HELP: memcpy "( dst src size -- newalien )"
-{ $values { "dst" "an alien address" } { "src" "an alien address" } { "size" "a non-negative integer" } }
-{ $description "Copies " { $snippet "size" } " bytes from " { $snippet "src" } " to " { $snippet "dst" } "." }
-{ $warning "As per the BSD C library documentation, the behavior is undefined if the source and destination overlap." } ;
-
-HELP: check-ptr "( c-ptr -- checked )"
-{ $values { "c-ptr" "an alien address, byte array, or " { $link f } } { "checked" "an alien address or byte array with non-zero address" } }
-{ $description "Throws an error if the input is " { $link f } ". Otherwise the object remains on the data stack." } ;
-
-HELP: free "( ptr -- )"
-{ $values { "ptr" "an alien address" } }
-{ $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ;
+++ /dev/null
-USING: alien compiler kernel kernel-internals math namespaces ;
-
-[
- [ alien-unsigned-cell <alien> ] "getter" set
- [
- >r >r alien-address r> r> set-alien-unsigned-cell
- ] "setter" set
- bootstrap-cell "width" set
- bootstrap-cell "align" set
- "box_alien" "boxer-function" set
- "unbox_alien" "unboxer-function" set
-] "void*" define-primitive-type
-
-[
- [ alien-signed-8 ] "getter" set
- [ set-alien-signed-8 ] "setter" set
- 8 "width" set
- 8 "align" set
- "box_signed_8" "boxer-function" set
- "unbox_signed_8" "unboxer-function" set
-] "longlong" define-primitive-type
-
-[
- [ alien-unsigned-8 ] "getter" set
- [ set-alien-unsigned-8 ] "setter" set
- 8 "width" set
- 8 "align" set
- "box_unsigned_8" "boxer-function" set
- "unbox_unsigned_8" "unboxer-function" set
-] "ulonglong" define-primitive-type
-
-[
- [ alien-signed-cell ] "getter" set
- [ set-alien-signed-cell ] "setter" set
- bootstrap-cell "width" set
- bootstrap-cell "align" set
- "box_signed_cell" "boxer-function" set
- "unbox_signed_cell" "unboxer-function" set
-] "long" define-primitive-type
-
-[
- [ alien-unsigned-cell ] "getter" set
- [ set-alien-unsigned-cell ] "setter" set
- bootstrap-cell "width" set
- bootstrap-cell "align" set
- "box_unsigned_cell" "boxer-function" set
- "unbox_unsigned_cell" "unboxer-function" set
-] "ulong" define-primitive-type
-
-[
- [ alien-signed-4 ] "getter" set
- [ set-alien-signed-4 ] "setter" set
- 4 "width" set
- 4 "align" set
- "box_signed_4" "boxer-function" set
- "unbox_signed_4" "unboxer-function" set
-] "int" define-primitive-type
-
-[
- [ alien-unsigned-4 ] "getter" set
- [ set-alien-unsigned-4 ] "setter" set
- 4 "width" set
- 4 "align" set
- "box_unsigned_4" "boxer-function" set
- "unbox_unsigned_4" "unboxer-function" set
-] "uint" define-primitive-type
-
-[
- [ alien-signed-2 ] "getter" set
- [ set-alien-signed-2 ] "setter" set
- 2 "width" set
- 2 "align" set
- "box_signed_2" "boxer-function" set
- "unbox_signed_2" "unboxer-function" set
-] "short" define-primitive-type
-
-[
- [ alien-unsigned-2 ] "getter" set
- [ set-alien-unsigned-2 ] "setter" set
- 2 "width" set
- 2 "align" set
- "box_unsigned_2" "boxer-function" set
- "unbox_unsigned_2" "unboxer-function" set
-] "ushort" define-primitive-type
-
-[
- [ alien-signed-1 ] "getter" set
- [ set-alien-signed-1 ] "setter" set
- 1 "width" set
- 1 "align" set
- "box_signed_1" "boxer-function" set
- "unbox_signed_1" "unboxer-function" set
-] "char" define-primitive-type
-
-[
- [ alien-unsigned-1 ] "getter" set
- [ set-alien-unsigned-1 ] "setter" set
- 1 "width" set
- 1 "align" set
- "box_unsigned_1" "boxer-function" set
- "unbox_unsigned_1" "unboxer-function" set
-] "uchar" define-primitive-type
-
-[
- [ alien-unsigned-cell <alien> alien>string ] "getter" set
- [
- >r >r string>alien alien-address r> r>
- set-alien-unsigned-cell
- ] "setter" set
- bootstrap-cell "width" set
- bootstrap-cell "align" set
- "box_c_string" "boxer-function" set
- "unbox_c_string" "unboxer-function" set
-] "char*" define-primitive-type
-
-[
- [ alien-unsigned-4 ] "getter" set
- [ set-alien-unsigned-4 ] "setter" set
- bootstrap-cell "width" set
- bootstrap-cell "align" set
- "box_utf16_string" "boxer-function" set
- "unbox_utf16_string" "unboxer-function" set
-] "ushort*" define-primitive-type
-
-[
- [ alien-unsigned-4 zero? not ] "getter" set
- [ 1 0 ? set-alien-unsigned-4 ] "setter" set
- bootstrap-cell "width" set
- bootstrap-cell "align" set
- "box_boolean" "boxer-function" set
- "unbox_boolean" "unboxer-function" set
-] "bool" define-primitive-type
-
-[
- [ alien-float ] "getter" set
- [ set-alien-float ] "setter" set
- 4 "width" set
- 4 "align" set
- "box_float" "boxer-function" set
- "unbox_float" "unboxer-function" set
- T{ float-regs f 4 } "reg-class" set
-] "float" define-primitive-type
-
-[
- [ alien-double ] "getter" set
- [ set-alien-double ] "setter" set
- 8 "width" set
- 8 "align" set
- "box_double" "boxer-function" set
- "unbox_double" "unboxer-function" set
- T{ float-regs f 8 } "reg-class" set
-] "double" define-primitive-type
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: alien
-USING: assembler compiler errors generic
-hashtables kernel kernel-internals lists math namespaces parser
-sequences strings words ;
-
-! Some code for interfacing with C structures.
-
-: define-getter ( offset type name -- )
- #! Define a word with stack effect ( alien -- obj ) in the
- #! current 'in' vocabulary.
- create-in >r c-getter cons r> swap define-compound ;
-
-: define-setter ( offset type name -- )
- #! Define a word with stack effect ( obj alien -- ) in the
- #! current 'in' vocabulary.
- "set-" swap append create-in >r c-setter cons r>
- swap define-compound ;
-
-: define-field ( offset type name -- offset )
- >r dup >r c-align align r> r>
- "struct-name" get swap "-" swap append3
- ( offset type name -- )
- 3dup define-getter 3dup define-setter
- drop c-size + ;
-
-: define-member ( max type -- max )
- c-size max ;
-
-: define-struct-type ( width -- )
- #! Define inline and pointer type for the struct. Pointer
- #! type is exactly like void*.
- [
- "width" set
- bootstrap-cell "align" set
- [ swap <displaced-alien> ] "getter" set
- "width" get [ %unbox-struct ] curry "unboxer" set
- "width" get [ %box-struct ] curry "boxer" set
- "struct" on
- ] "struct-name" get define-c-type
- "struct-name" get in get init-c-type ;
-
-: c-struct? ( type -- ? )
- c-types get hash [ "struct" swap hash ] [ f ] if* ;
+++ /dev/null
-IN: alien
-USING: help ;
-
-HELP: c-struct? "( type -- ? )"
-{ $values { "type" "a string" } { "?" "a boolean" } }
-{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: BEGIN-STRUCT: } "." } ;
+++ /dev/null
-! Copyright (C) 2005 Alex Chapman.
-! See http://factorcode.org/license.txt for BSD license.
-IN: !syntax
-USING: alien compiler kernel lists math namespaces parser
-sequences syntax words ;
-
-: DLL" skip-blank parse-string dlopen swons ; parsing
-
-: ALIEN: scan-word <alien> swons ; parsing
-
-: LIBRARY: scan "c-library" set ; parsing
-
-: FUNCTION:
- scan "c-library" get scan string-mode on
- [ string-mode off define-c-word ] [ ] ; parsing
-
-: TYPEDEF: scan scan typedef ; parsing
-
-: BEGIN-STRUCT: ( -- offset )
- scan "struct-name" set 0 ; parsing
-
-: FIELD: ( offset -- offset )
- scan scan define-field ; parsing
-
-: END-STRUCT ( length -- )
- define-struct-type ; parsing
-
-: C-UNION:
- scan "struct-name" set
- string-mode on [
- string-mode off
- 0 [ define-member ] reduce define-struct-type
- ] [ ] ; parsing
-
-: C-ENUM:
- string-mode on [
- string-mode off 0 [
- create-in swap [ unit define-compound ] keep 1+
- ] reduce drop
- ] [ ] ; parsing
+++ /dev/null
-IN: syntax
-USING: alien help ;
-
-HELP: DLL" "path\""
-{ $values { "path" "a path name string" } }
-{ $description "Constructs a DLL handle at parse time." }
-{ $see-also dlopen } ;
-
-HELP: ALIEN: "address"
-{ $values { "address" "a non-negative integer" } }
-{ $description "Creates an alien object at parse time." }
-{ $notes "Alien objects are invalidated between image saves and loads." }
-{ $see-also <alien> } ;
-
-HELP: LIBRARY: "name"
-{ $values { "name" "a logical library name" } }
-{ $description "Sets the logical library for consequent " { $link POSTPONE: FUNCTION: } " definitions that follow." } ;
-
-HELP: FUNCTION: "return name ( parameters )"
-{ $values { "return" "a C return type" } { "name" "a C function name" "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
-{ $description "Defines a new word " { $snippet "name" } " which calls a C library function with the same name, in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
-$terpri
-"The new word must be compiled before being executed; see " { $link "compiler" } "." }
-{ $examples
-"For example, suppose the " { $snippet "foo" } " library exports the following function:"
-{ $code
- "void the_answer(char* question, int value) {"
- " printf(\"The answer to %s is %d.\n\",question,value);"
- "}"
-}
-"You can define a word for invoking it:"
-{ $example
- "LIBRARY: foo\nFUNCTION: the_answer ( char* question, int value ) ;\n\ the_answer compile\n\"the question\" 42 the-answer" "The answer to the question is 42."
-} }
-{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration slightly easier to read:"
-{ $code
- "FUNCTION: void glHint ( GLenum target, GLenum mode ) ;"
- "FUNCTION: void glHint GLenum target GLenum mode ;"
-} } ;
-
-HELP: TYPEDEF: "old new"
-{ $values { "old" "a C type" } { "new" "a C type" } }
-{ $description "Alises the C types " { $snippet "old" } " and " { $snippet "old*" } " under the names " { $snippet "new" } " and " { $snippet "new*" } ", respectively." }
-{ $see-also (typedef) typedef } ;
-
-HELP: BEGIN-STRUCT: "name"
-{ $values { "name" "a new C type name" } }
-{ $description "Begins reading a C struct definition. This word must be followed by one or more " { $link POSTPONE: FIELD: } " declarations, terminating in " { $link POSTPONE: END-STRUCT } "." } ;
-
-HELP: FIELD: "type name"
-{ $values { "type" "a C type" } { "name" "a field name" } }
-{ $description "Adds a field to the C structure currently being read. This word can only be used inside a " { $link POSTPONE: BEGIN-STRUCT: } "/" { $link POSTPONE: END-STRUCT } " pair." } ;
-
-HELP: END-STRUCT f
-{ $description "Ends a structure definition. Only valid after a " { $link POSTPONE: BEGIN-STRUCT: } "." } ;
-
-HELP: C-UNION: "name members..."
-{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
-{ $description "Defines a new C type sized to fit its largest member." }
-{ $examples { $code "C-UNION: event active-event keyboard-event mouse-event ;" } } ;
-
-HELP: C-ENUM: "words..."
-{ $values { "words" "a sequence of word names" } }
-{ $description "Creates a sequence of compound definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." }
-{ $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 symbolic constants instead." }
-{ $examples
- "The following two lines are equivalent:"
- { $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
-} ;
"/library/generic/math-combination.factor"
"/library/generic/tuple.factor"
- "/library/alien/aliens.factor"
+ "/library/compiler/alien/aliens.factor"
"/library/syntax/prettyprint.factor"
"/library/syntax/see.factor"
"/library/compiler/architecture.factor"
- "/library/inference/shuffle.factor"
- "/library/inference/dataflow.factor"
- "/library/inference/inference.factor"
- "/library/inference/branches.factor"
- "/library/inference/words.factor"
- "/library/inference/class-infer.factor"
- "/library/inference/kill-literals.factor"
- "/library/inference/optimizer.factor"
- "/library/inference/inline-methods.factor"
- "/library/inference/known-words.factor"
- "/library/inference/stack.factor"
- "/library/inference/call-optimizers.factor"
- "/library/inference/print-dataflow.factor"
-
- "/library/compiler/assembler.factor"
- "/library/compiler/templates.factor"
- "/library/compiler/xt.factor"
- "/library/compiler/generator.factor"
+ "/library/compiler/inference/shuffle.factor"
+ "/library/compiler/inference/dataflow.factor"
+ "/library/compiler/inference/inference.factor"
+ "/library/compiler/inference/branches.factor"
+ "/library/compiler/inference/words.factor"
+ "/library/compiler/inference/stack.factor"
+
+ "/library/compiler/optimizer/class-infer.factor"
+ "/library/compiler/optimizer/kill-literals.factor"
+ "/library/compiler/optimizer/optimizer.factor"
+ "/library/compiler/optimizer/inline-methods.factor"
+ "/library/compiler/optimizer/known-words.factor"
+ "/library/compiler/optimizer/call-optimizers.factor"
+ "/library/compiler/optimizer/print-dataflow.factor"
+
+ "/library/compiler/generator/assembler.factor"
+ "/library/compiler/generator/templates.factor"
+ "/library/compiler/generator/xt.factor"
+ "/library/compiler/generator/generator.factor"
+
"/library/compiler/compiler.factor"
- "/library/alien/malloc.factor"
- "/library/alien/c-types.factor"
- "/library/alien/structs.factor"
- "/library/alien/compiler.factor"
- "/library/alien/alien-invoke.factor"
- "/library/alien/alien-callback.factor"
- "/library/alien/syntax.factor"
+ "/library/compiler/alien/malloc.factor"
+ "/library/compiler/alien/c-types.factor"
+ "/library/compiler/alien/structs.factor"
+ "/library/compiler/alien/compiler.factor"
+ "/library/compiler/alien/alien-invoke.factor"
+ "/library/compiler/alien/alien-callback.factor"
+ "/library/compiler/alien/syntax.factor"
"/library/io/buffer.factor"
"/library/kernel.facts"
"/library/threads.facts"
"/library/words.facts"
- "/library/alien/alien-callback.facts"
- "/library/alien/alien-invoke.facts"
- "/library/alien/aliens.facts"
- "/library/alien/c-types.facts"
- "/library/alien/malloc.facts"
- "/library/alien/structs.facts"
- "/library/alien/syntax.facts"
+ "/library/compiler/alien/alien-callback.facts"
+ "/library/compiler/alien/alien-invoke.facts"
+ "/library/compiler/alien/aliens.facts"
+ "/library/compiler/alien/c-types.facts"
+ "/library/compiler/alien/malloc.facts"
+ "/library/compiler/alien/structs.facts"
+ "/library/compiler/alien/syntax.facts"
"/library/bootstrap/image.facts"
"/library/collections/growable.facts"
"/library/collections/arrays.facts"
{
"/library/compiler/ppc/assembler.factor"
"/library/compiler/ppc/architecture.factor"
- ! "/library/compiler/ppc/generator.factor"
- ! "/library/compiler/ppc/slots.factor"
- ! "/library/compiler/ppc/stack.factor"
- ! "/library/compiler/ppc/fixnum.factor"
- ! "/library/compiler/ppc/alien.factor"
+ "/library/compiler/ppc/intrinsics.factor"
}
]
} {
--- /dev/null
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: alien
+USING: compiler errors generic hashtables inference inspector
+kernel lists namespaces sequences strings words ;
+
+TUPLE: alien-callback return parameters quot xt ;
+C: alien-callback make-node ;
+
+TUPLE: alien-callback-error ;
+
+M: alien-callback-error summary ( error -- )
+ drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
+
+: alien-callback ( return parameters quot -- address )
+ <alien-callback-error> throw ;
+
+: callback-bottom ( node -- )
+ alien-callback-xt [ word-xt <alien> ] curry infer-quot ;
+
+\ alien-callback [ [ string object general-list ] [ alien ] ]
+"infer-effect" set-word-prop
+
+\ alien-callback [
+ empty-node <alien-callback>
+ pop-literal nip over set-alien-callback-quot
+ pop-literal nip over set-alien-callback-parameters
+ pop-literal nip over set-alien-callback-return
+ gensym over set-alien-callback-xt
+ dup node,
+ callback-bottom
+] "infer" set-word-prop
+
+: box-parameters ( parameters -- )
+ [ box-parameter ] each-parameter ;
+
+: registers>objects ( parameters -- )
+ dup \ %freg>stack move-parameters
+ "nest_stacks" f %alien-invoke box-parameters ;
+
+: unbox-return ( node -- )
+ alien-callback-return [
+ "unnest_stacks" f %alien-invoke
+ ] [
+ c-type [
+ "reg-class" get
+ "unboxer-function" get
+ %callback-value
+ ] bind
+ ] if-void ;
+
+: generate-callback ( node -- )
+ [ alien-callback-xt ] keep [
+ dup alien-callback-parameters registers>objects
+ dup alien-callback-quot \ init-error-handler swons
+ %alien-callback
+ unbox-return
+ %return
+ ] generate-block ;
+
+M: alien-callback generate-node ( node -- )
+ end-basic-block compile-gc generate-callback iterate-next ;
+
+M: alien-callback stack-reserve*
+ alien-callback-parameters stack-space ;
--- /dev/null
+IN: alien
+USING: errors help ;
+
+HELP: alien-callback "( return parameters quot -- alien )"
+{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "quot" "a quotation" } { "alien" "an alien address" } }
+{ $description
+ "Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "\"void\"" } " indicates that no value is to be returned."
+ $terpri
+ "This word only runs when it is called from within a " { $emphasis "compiled" } " word, with all three parameters as literal inputs. See " { $link "compiler" } "."
+ $terpri
+ "When a compiled reference to this word is called, it pushes the callback's alien address on the data stack. This address can be passed to any C function expecting a C function pointer with the correct signature. The callback is actually generated when the word calling " { $link alien-callback } " is compiled."
+ $terpri
+ "Callback quotations run with freshly-allocated stacks. This means the data stack contains the values passed by the C function, and nothing else. It also means that if the callback throws an error which is not caught, the Factor runtime will halt. See " { $link "errors" } " for error handling options."
+}
+{ $examples
+ "A simple example, showing a C function which returns the difference of two given integers:"
+ { $code
+ ": difference-callback ( -- alien )"
+ " \"int\" { \"int\" \"int\" } [ - ] alien-callback ;"
+ }
+}
+{ $see-also alien-invoke } ;
--- /dev/null
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: alien
+USING: arrays assembler compiler compiler
+errors generic hashtables inference inspector
+io kernel kernel-internals lists math namespaces parser
+prettyprint sequences strings words ;
+
+TUPLE: alien-invoke library function return parameters ;
+C: alien-invoke make-node ;
+
+: alien-invoke-stack ( node -- )
+ dup alien-invoke-parameters length over consume-values
+ dup alien-invoke-return "void" = 0 1 ? swap produce-values ;
+
+: alien-invoke-dlsym ( node -- symbol dll )
+ dup alien-invoke-function swap alien-invoke-library
+ load-library ;
+
+TUPLE: alien-invoke-error library symbol ;
+
+M: alien-invoke-error summary ( error -- )
+ drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ;
+
+: alien-invoke ( ... return library function parameters -- ... )
+ pick pick <alien-invoke-error> throw ;
+
+\ alien-invoke [ [ string object string object ] [ ] ]
+"infer-effect" set-word-prop
+
+\ alien-invoke [
+ empty-node <alien-invoke>
+ pop-literal nip over set-alien-invoke-parameters
+ pop-literal nip over set-alien-invoke-function
+ pop-literal nip over set-alien-invoke-library
+ pop-literal nip over set-alien-invoke-return
+ dup alien-invoke-dlsym dlsym drop
+ dup alien-invoke-stack
+ node,
+] "infer" set-word-prop
+
+: unbox-parameter ( stack# type -- )
+ c-type [ "reg-class" get "unboxer" get call ] bind ;
+
+: unbox-parameters ( parameters -- )
+ [ unbox-parameter ] reverse-each-parameter ;
+
+: objects>registers ( parameters -- )
+ #! Generate code for boxing a list of C types, then generate
+ #! code for moving these parameters to register on
+ #! architectures where parameters are passed in registers
+ #! (PowerPC, AMD64).
+ dup unbox-parameters "save_stacks" f %alien-invoke
+ \ %stack>freg move-parameters ;
+
+: box-return ( node -- )
+ alien-invoke-return [ ] [ f swap box-parameter ] if-void ;
+
+: generate-cleanup ( node -- )
+ dup alien-invoke-library library-abi "stdcall" = [
+ drop
+ ] [
+ alien-invoke-parameters stack-space %cleanup
+ ] if ;
+
+M: alien-invoke generate-node ( node -- )
+ end-basic-block compile-gc
+ dup alien-invoke-parameters objects>registers
+ dup alien-invoke-dlsym %alien-invoke
+ dup generate-cleanup box-return
+ iterate-next ;
+
+M: alien-invoke stack-reserve*
+ alien-invoke-parameters stack-space ;
+
+: parse-arglist ( return seq -- types stack-effect )
+ 2 swap group unpair
+ rot dup "void" = [ drop { } ] [ 1array ] if 2array
+ effect>string ;
+
+: (define-c-word) ( type lib func types stack-effect -- )
+ >r over create-in >r
+ [ alien-invoke ] cons cons cons cons r> swap define-compound
+ word r> "stack-effect" set-word-prop ;
+
+: define-c-word ( return library function parameters -- )
+ [ "()" subseq? not ] subset >r pick r> parse-arglist
+ (define-c-word) ;
+
+M: compound unxref-word*
+ dup word-def \ alien-invoke swap member?
+ over "infer" word-prop or [
+ drop
+ ] [
+ dup
+ { "infer-effect" "base-case" "no-effect" "terminates" }
+ reset-props update-xt
+ ] if ;
--- /dev/null
+IN: alien
+USING: help ;
+
+HELP: alien-invoke "( ... return library function parameters -- ... )"
+{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
+{ $description "Calls a C library function with the given name. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $snippet "\"void\"" } " indicates that no value is to be expected."
+$terpri
+"This word only runs when it is called from within a " { $emphasis "compiled" } " word, with all four parameters as literal inputs. See " { $link "compiler" } "." }
+{ $see-also alien-callback } ;
+
+HELP: define-c-word "( return library function parameters -- )"
+{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
+{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
+{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
--- /dev/null
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: alien
+USING: arrays hashtables io kernel lists math namespaces parser
+sequences ;
+
+: <alien> ( address -- alien ) f <displaced-alien> ; inline
+
+UNION: c-ptr byte-array alien ;
+
+M: alien = ( obj obj -- ? )
+ over alien? [
+ 2dup [ expired? ] 2apply 2dup or [
+ 2swap 2drop
+ ] [
+ 2drop [ alien-address ] 2apply
+ ] if =
+ ] [
+ 2drop f
+ ] if ;
+
+global [ "libraries" nest drop ] bind
+
+: library ( name -- object ) "libraries" get hash ;
+
+: load-library ( name -- dll )
+ library dup [
+ [
+ "dll" get dup [
+ drop "name" get dlopen dup "dll" set
+ ] unless
+ ] bind
+ ] when ;
+
+: add-library ( library name abi -- )
+ "libraries" get [
+ [ "abi" set "name" set ] make-hash swap set
+ ] bind ;
+
+: add-simple-library ( name file -- )
+ windows? ".dll" ".so" ? append
+ windows? "stdcall" "cdecl" ? add-library ;
+
+: library-abi ( library -- abi )
+ library "abi" swap ?hash [ "cdecl" ] unless* ;
--- /dev/null
+IN: alien
+USING: help ;
+
+HELP: expired? "( c-ptr -- ? )"
+{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } }
+{ $description "Tests if the alien is a relic from an earlier session. When an image is loaded, any alien objects which persisted in the image are marked as being expired."
+$terpri
+"A byte array is never considered to be expired, whereas passing " { $link f } " always yields true." } ;
+
+HELP: <displaced-alien> "( displacement c-ptr -- alien )"
+{ $values { "displacement" "an integer" } { "c-ptr" "an alien, byte array, or " { $link f } } { "alien" "a new alien" } }
+{ $description "Creates a new alien address object, wrapping a raw memory address. The alien points to a location in memory which is offset by " { $snippet "displacement" } " from the address of " { $link "c-ptr" } "." }
+{ $notes "Passing a value of " { $link f } " for " { $snippet "c-ptr" } " creates an alien with an absolute address; this is how " { $link <alien> } " is implemented."
+$terpri
+"Passing a zero absolute address does not construct a new alien object, but instead makes the word output " { $link f } "." }
+{ $see-also <alien> alien-address } ;
+
+HELP: alien-address "( c-ptr -- addr )"
+{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "addr" "a non-negative integer" } }
+{ $description "Outputs the address of an alien." }
+{ $warning "Taking the address of a byte array is not safe. The byte array can be moved by the garbage collector between the time the address is taken, and when it is accessed. If you need to pass pointers to C functions which will persist across alien calls, you must allocate unmanaged memory instead. See " { $link "malloc" } "." } ;
+
+HELP: <alien> "( address -- alien )"
+{ $values { "address" "a non-negative integer" } { "alien" "a new alien address" } }
+{ $description "Creates an alien object, wrapping a raw memory address." }
+{ $notes "Alien objects are invalidated between image saves and loads." }
+{ $see-also <displaced-alien> alien-address } ;
+
+HELP: c-ptr f
+{ $description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ;
+
+HELP: library "( name -- library )"
+{ $values { "name" "a string" } { "library" "a hashtable" } }
+{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
+ { $list
+ { { $snippet "name" } " - the full path of the C library binary" }
+ { { $snippet "abi" } " - the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
+ { { $snippet "dll" } " - an instance of the " { $link dll } " class; only set if the library is loaded" }
+ }
+} ;
+
+HELP: dlopen "( path -- dll )"
+{ $values { "path" "a path name string" } { "dll" "a DLL handle" } }
+{ $description "Opens a native library and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } "." }
+{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." }
+{ $notes "This is the low-level facility used to implement " { $link load-library } ". Use the latter instead." } ;
+
+HELP: dlsym "( name dll -- alien )"
+{ $values { "name" "a C symbol name" } { "dll" "a DLL handle" } { "alien" "an alien pointer" } }
+{ $description "Looks up a symbol in a native library. If " { $snippet "dll" } " is " { $link f } " looks for the symbol in the runtime executable." }
+{ $errors "Throws an error if the symbol could not be found." } ;
+
+HELP: dlclose "( dll -- )"
+{ $values { "dll" "a DLL handle" } }
+{ $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
+
+HELP: load-library "( name -- dll )"
+{ $values { "name" "a string" } { "dll" "a DLL handle" } }
+{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
+{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
+
+HELP: add-library "( name path abi -- )"
+{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
+{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
+{ $examples { $code "\"gif\" \"libgif.so\" \"cdecl\" add-library" } } ;
--- /dev/null
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: alien
+USING: arrays compiler errors generic
+hashtables kernel kernel-internals libc lists math namespaces
+parser sequences strings words ;
+
+: <c-type> ( -- type )
+ H{
+ { "setter" [ "Cannot read struct fields with type" throw ] }
+ { "getter" [ "Cannot write struct fields with type" throw ] }
+ { "boxer" [ "boxer-function" get %box ] }
+ { "unboxer" [ "unboxer-function" get %unbox ] }
+ { "reg-class" T{ int-regs f } }
+ { "width" 0 }
+ } clone ;
+
+SYMBOL: c-types
+
+: c-type ( name -- type )
+ dup c-types get hash
+ [ ] [ "No such C type: " swap append throw ] ?if ;
+
+: c-size ( name -- size ) "width" swap c-type hash ;
+
+: c-align ( name -- align ) "align" swap c-type hash ;
+
+: c-getter ( name -- quot ) "getter" swap c-type hash ;
+
+: c-setter ( name -- quot ) "setter" swap c-type hash ;
+
+: define-c-type ( quot name -- )
+ >r <c-type> [ swap bind ] keep r> c-types get set-hash ;
+ inline
+
+: <c-array> ( size type -- c-ptr )
+ global [ c-size * <byte-array> ] bind ;
+
+: <c-object> ( type -- c-ptr ) 1 swap <c-array> ;
+
+: <malloc-array> ( size type -- malloc-ptr )
+ global [ c-size calloc ] bind check-ptr ;
+
+: <malloc-object> ( type -- malloc-ptr ) 1 swap <malloc-array> ;
+
+: <malloc-string> ( string -- alien )
+ "\0" append dup length malloc check-ptr
+ [ alien-address string>memory ] keep ;
+
+: (typedef) ( old new -- ) c-types get [ >r get r> set ] bind ;
+
+: define-pointer ( type -- ) "*" append "void*" swap (typedef) ;
+
+: define-deref ( name vocab -- )
+ >r dup "*" swap append r> create
+ swap c-getter 0 swons define-compound ;
+
+: (define-nth) ( word type quot -- )
+ >r c-size [ rot * ] curry r> append define-compound ;
+
+: define-nth ( name vocab -- )
+ >r dup "-nth" append r> create
+ swap dup c-getter (define-nth) ;
+
+: define-set-nth ( name vocab -- )
+ >r "set-" over "-nth" append3 r> create
+ swap dup c-setter (define-nth) ;
+
+: define-out ( name vocab -- )
+ over [ <c-object> tuck 0 ] over c-setter append
+ >r >r constructor-word r> r> cons define-compound ;
+
+: init-c-type ( name vocab -- )
+ over define-pointer define-nth ;
+
+: define-primitive-type ( quot name -- )
+ [ define-c-type ] keep "alien"
+ 2dup init-c-type
+ 2dup define-deref
+ 2dup define-set-nth
+ define-out ;
+
+: typedef ( old new -- )
+ over "*" append over "*" append (typedef) (typedef) ;
--- /dev/null
+IN: alien
+USING: help libc ;
+
+HELP: c-type "( name -- type )"
+{ $values { "name" "a string" } { "type" "a hashtable" } }
+{ $description "Looks up a C type by name." }
+{ $errors "Throws an error if the type does not exist." } ;
+
+HELP: c-size "( name -- size )"
+{ $values { "name" "a string" } { "size" "an integer" } }
+{ $description "Outputs the number of bytes taken up by this C type." }
+{ $examples
+ "On a 32-bit system, you will get the following output:"
+ { $example "USE: alien\n\"void*\" c-size ." "4" }
+}
+{ $errors "Throws an error if the type does not exist." } ;
+
+HELP: c-align "( name -- n )"
+{ $values { "name" "a string" } { "n" "an integer" } }
+{ $description "Outputs alignment at which values of this C type are padded in C structures." }
+{ $errors "Throws an error if the type does not exist." } ;
+
+HELP: c-getter "( name -- quot )"
+{ $values { "name" "a string" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } }
+{ $description "Outputs a quotation which reads values of this C type from a C structure." }
+{ $errors "Throws an error if the type does not exist." } ;
+
+HELP: c-setter "( name -- quot )"
+{ $values { "name" "a string" } { "quot" "a quotation with stack effect " { $snippet "( obj c-ptr n -- )" } } }
+{ $description "Outputs a quotation which writes values of this C type to a C structure." }
+{ $errors "Throws an error if the type does not exist." } ;
+
+HELP: <c-array> "( n type -- array )"
+{ $values { "n" "a non-negative integer" } { "type" "a string" } { "array" "a byte array" } }
+{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
+{ $errors "Throws an error if the type does not exist or the requested size is negative." }
+{ $see-also <malloc-array> } ;
+
+HELP: <c-object> "( n type -- array )"
+{ $values { "type" "a string" } { "array" "a byte array" } }
+{ $description "Creates a byte array suitable for holding a value with the given C type." }
+{ $errors "Throws an error if the type does not exist." }
+{ $see-also <malloc-object> } ;
+
+HELP: string>alien "( string -- array )"
+{ $values { "string" "a string" } { "array" "a byte array" } }
+{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
+{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." }
+{ $see-also alien>string <malloc-string> } ;
+
+HELP: alien>string "( c-ptr -- string )"
+{ $values { "c-ptr" "an alien, byte array or " { $link f } } { "string" "a string" } }
+{ $description "Reads a null-terminated 8-bit C string from the specified address." }
+{ $see-also string>alien } ;
+
+HELP: <malloc-array> "( n type -- alien )"
+{ $values { "n" "a non-negative integer" } { "type" "a string" } { "alien" "an alien address" } }
+{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if the type does not exist, if the requested size is negative, or if memory allocation fails." }
+{ $see-also <c-array> } ;
+
+HELP: <malloc-object> "( type -- alien )"
+{ $values { "type" "a string" } { "alien" "an alien address" } }
+{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if the type does not exist or if memory allocation fails." }
+{ $see-also <c-object> } ;
+
+HELP: <malloc-string> "( string -- alien )"
+{ $values { "string" "a string" } { "alien" "an alien address" } }
+{ $description "Copies a string to an unmanaged memory block large enough to hold a copy of the string in 8-bit ASCII encoding, with a trailing null byte." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if memory allocation fails." }
+{ $see-also string>alien } ;
+
+HELP: (typedef) "( old new -- )"
+{ $values { "old" "a string" } { "new" "a string" } }
+{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
+{ $notes "You should use the higher-level " { $link POSTPONE: TYPEDEF: } " word instead." }
+{ $see-also typedef POSTPONE: TYPEDEF: } ;
+
+HELP: define-pointer "( type -- )"
+{ $values { "type" "a string" } }
+{ $description "Aliases the C type " { $snippet "type*" } " to " { $snippet "void*" } "." }
+{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
+
+HELP: define-deref "( name vocab -- )"
+{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
+{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
+{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
+
+HELP: define-nth "( name vocab -- )"
+{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
+{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
+{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
+
+HELP: define-set-nth "( name vocab -- )"
+{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
+{ $description "Defines a word " { $snippet "set-" { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( value n c-ptr -- )" } " for writing the value with C type " { $snippet "name" } " to an alien pointer, displaced by a multiple of the C type's size." }
+{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
+
+HELP: define-out "( name vocab -- )"
+{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
+{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
+{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
+
+HELP: typedef "( old new -- )"
+{ $values { "old" "a string" } { "new" "a string" } }
+{ $description "Alises the C types " { $snippet "old" } " and " { $snippet "old*" } " under the names " { $snippet "new" } " and " { $snippet "new*" } ", respectively." }
+{ $notes "You should use the higher-level " { $link POSTPONE: TYPEDEF: } " word instead." }
+{ $see-also (typedef) POSTPONE: TYPEDEF: } ;
--- /dev/null
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: alien
+USING: arrays compiler generic hashtables kernel
+kernel-internals math namespaces sequences words ;
+
+: parameter-size c-size cell align ;
+
+: parameter-sizes ( types -- offsets )
+ #! Compute stack frame locations.
+ 0 [ parameter-size + ] accumulate ;
+
+: stack-space ( parameters -- n )
+ 0 [ parameter-size + ] reduce ;
+
+: reg-class-full? ( class -- ? )
+ dup class get swap fastcall-regs length >= ;
+
+: spill-param ( reg-class -- n reg-class )
+ reg-size stack-params dup get -rot +@ T{ stack-params } ;
+
+: fastcall-param ( reg-class -- n reg-class )
+ [ dup class get swap inc-reg-class ] keep ;
+
+: alloc-parameter ( parameter -- n reg reg-class )
+ #! Allocate a register and stack frame location.
+ #! n is a stack location, and the value of the class
+ #! variable is a register number.
+ c-type "reg-class" swap hash dup reg-class-full?
+ [ spill-param ] [ fastcall-param ] if ;
+
+: flatten-value-types ( params -- params )
+ #! Convert value type structs to consecutive void*s.
+ [
+ dup c-struct?
+ [ c-size cell / "void*" <array> ] [ 1array ] if
+ ] map concat ;
+
+: each-parameter ( parameters quot -- )
+ >r [ parameter-sizes ] keep r> 2each ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+ >r [ parameter-sizes ] keep
+ [ reverse-slice ] 2apply r> 2each ; inline
+
+: move-parameters ( params vop -- )
+ #! Moves values from C stack to registers (if vop is
+ #! %stack>freg) and registers to C stack (if vop is
+ #! %freg>stack).
+ swap [
+ flatten-value-types
+ 0 { int-regs float-regs stack-params } [ set ] each-with
+ [ pick >r alloc-parameter r> execute ] each-parameter
+ drop
+ ] with-scope ; inline
+
+: box-parameter ( stack# type -- node )
+ c-type [ "reg-class" get "boxer" get call ] bind ;
+
+: if-void ( type true false -- | false: type -- )
+ pick "void" = [ drop nip call ] [ nip call ] if ; inline
+
+: compile-gc ; ! "simple_gc" f %alien-invoke , ;
--- /dev/null
+! Copyright (C) 2004, 2005 Mackenzie Straight.
+! See http://factorcode.org/license.txt for BSD license.
+IN: libc
+USING: alien errors kernel math ;
+
+LIBRARY: libc
+FUNCTION: void* malloc ( ulong size ) ;
+FUNCTION: void* calloc ( ulong count, ulong size ) ;
+FUNCTION: void free ( void* ptr ) ;
+FUNCTION: void* realloc ( void* ptr, ulong size ) ;
+FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ;
+
+: check-ptr [ "Out of memory" throw ] unless* ;
--- /dev/null
+IN: libc
+USING: help ;
+
+HELP: malloc "( size -- alien )"
+{ $values { "size" "a non-negative integer" } { "alien" "an alien address" } }
+{ $description "Allocates a block of " { $snippet "size" } " bytes from the operating system. The contents of the block are undefined."
+$terpri
+"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } ;
+
+HELP: calloc "( count size -- alien )"
+{ $values { "count" "a non-negative integer" } { "size" "a non-negative integer" } { "alien" "an alien address" } }
+{ $description "Allocates a block of " { $snippet "count * size" } " bytes from the operating system. The contents of the block are initially zero."
+$terpri
+"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } ;
+
+HELP: realloc "( alien size -- newalien )"
+{ $values { "alien" "an alien address" } { "size" "a non-negative integer" } { "newalien" "an alien address" } }
+{ $description "Allocates a new block of " { $snippet "size" } " bytes from the operating system. The contents of " { $snippet "alien" } ", which itself must be a block previously returned by " { $link malloc } " or " { $link realloc } ", are copied into the new block, and the old block is freed."
+$terpri
+"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } ;
+
+HELP: memcpy "( dst src size -- newalien )"
+{ $values { "dst" "an alien address" } { "src" "an alien address" } { "size" "a non-negative integer" } }
+{ $description "Copies " { $snippet "size" } " bytes from " { $snippet "src" } " to " { $snippet "dst" } "." }
+{ $warning "As per the BSD C library documentation, the behavior is undefined if the source and destination overlap." } ;
+
+HELP: check-ptr "( c-ptr -- checked )"
+{ $values { "c-ptr" "an alien address, byte array, or " { $link f } } { "checked" "an alien address or byte array with non-zero address" } }
+{ $description "Throws an error if the input is " { $link f } ". Otherwise the object remains on the data stack." } ;
+
+HELP: free "( ptr -- )"
+{ $values { "ptr" "an alien address" } }
+{ $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ;
--- /dev/null
+USING: alien compiler kernel kernel-internals math namespaces ;
+
+[
+ [ alien-unsigned-cell <alien> ] "getter" set
+ [
+ >r >r alien-address r> r> set-alien-unsigned-cell
+ ] "setter" set
+ bootstrap-cell "width" set
+ bootstrap-cell "align" set
+ "box_alien" "boxer-function" set
+ "unbox_alien" "unboxer-function" set
+] "void*" define-primitive-type
+
+[
+ [ alien-signed-8 ] "getter" set
+ [ set-alien-signed-8 ] "setter" set
+ 8 "width" set
+ 8 "align" set
+ "box_signed_8" "boxer-function" set
+ "unbox_signed_8" "unboxer-function" set
+] "longlong" define-primitive-type
+
+[
+ [ alien-unsigned-8 ] "getter" set
+ [ set-alien-unsigned-8 ] "setter" set
+ 8 "width" set
+ 8 "align" set
+ "box_unsigned_8" "boxer-function" set
+ "unbox_unsigned_8" "unboxer-function" set
+] "ulonglong" define-primitive-type
+
+[
+ [ alien-signed-cell ] "getter" set
+ [ set-alien-signed-cell ] "setter" set
+ bootstrap-cell "width" set
+ bootstrap-cell "align" set
+ "box_signed_cell" "boxer-function" set
+ "unbox_signed_cell" "unboxer-function" set
+] "long" define-primitive-type
+
+[
+ [ alien-unsigned-cell ] "getter" set
+ [ set-alien-unsigned-cell ] "setter" set
+ bootstrap-cell "width" set
+ bootstrap-cell "align" set
+ "box_unsigned_cell" "boxer-function" set
+ "unbox_unsigned_cell" "unboxer-function" set
+] "ulong" define-primitive-type
+
+[
+ [ alien-signed-4 ] "getter" set
+ [ set-alien-signed-4 ] "setter" set
+ 4 "width" set
+ 4 "align" set
+ "box_signed_4" "boxer-function" set
+ "unbox_signed_4" "unboxer-function" set
+] "int" define-primitive-type
+
+[
+ [ alien-unsigned-4 ] "getter" set
+ [ set-alien-unsigned-4 ] "setter" set
+ 4 "width" set
+ 4 "align" set
+ "box_unsigned_4" "boxer-function" set
+ "unbox_unsigned_4" "unboxer-function" set
+] "uint" define-primitive-type
+
+[
+ [ alien-signed-2 ] "getter" set
+ [ set-alien-signed-2 ] "setter" set
+ 2 "width" set
+ 2 "align" set
+ "box_signed_2" "boxer-function" set
+ "unbox_signed_2" "unboxer-function" set
+] "short" define-primitive-type
+
+[
+ [ alien-unsigned-2 ] "getter" set
+ [ set-alien-unsigned-2 ] "setter" set
+ 2 "width" set
+ 2 "align" set
+ "box_unsigned_2" "boxer-function" set
+ "unbox_unsigned_2" "unboxer-function" set
+] "ushort" define-primitive-type
+
+[
+ [ alien-signed-1 ] "getter" set
+ [ set-alien-signed-1 ] "setter" set
+ 1 "width" set
+ 1 "align" set
+ "box_signed_1" "boxer-function" set
+ "unbox_signed_1" "unboxer-function" set
+] "char" define-primitive-type
+
+[
+ [ alien-unsigned-1 ] "getter" set
+ [ set-alien-unsigned-1 ] "setter" set
+ 1 "width" set
+ 1 "align" set
+ "box_unsigned_1" "boxer-function" set
+ "unbox_unsigned_1" "unboxer-function" set
+] "uchar" define-primitive-type
+
+[
+ [ alien-unsigned-cell <alien> alien>string ] "getter" set
+ [
+ >r >r string>alien alien-address r> r>
+ set-alien-unsigned-cell
+ ] "setter" set
+ bootstrap-cell "width" set
+ bootstrap-cell "align" set
+ "box_c_string" "boxer-function" set
+ "unbox_c_string" "unboxer-function" set
+] "char*" define-primitive-type
+
+[
+ [ alien-unsigned-4 ] "getter" set
+ [ set-alien-unsigned-4 ] "setter" set
+ bootstrap-cell "width" set
+ bootstrap-cell "align" set
+ "box_utf16_string" "boxer-function" set
+ "unbox_utf16_string" "unboxer-function" set
+] "ushort*" define-primitive-type
+
+[
+ [ alien-unsigned-4 zero? not ] "getter" set
+ [ 1 0 ? set-alien-unsigned-4 ] "setter" set
+ bootstrap-cell "width" set
+ bootstrap-cell "align" set
+ "box_boolean" "boxer-function" set
+ "unbox_boolean" "unboxer-function" set
+] "bool" define-primitive-type
+
+[
+ [ alien-float ] "getter" set
+ [ set-alien-float ] "setter" set
+ 4 "width" set
+ 4 "align" set
+ "box_float" "boxer-function" set
+ "unbox_float" "unboxer-function" set
+ T{ float-regs f 4 } "reg-class" set
+] "float" define-primitive-type
+
+[
+ [ alien-double ] "getter" set
+ [ set-alien-double ] "setter" set
+ 8 "width" set
+ 8 "align" set
+ "box_double" "boxer-function" set
+ "unbox_double" "unboxer-function" set
+ T{ float-regs f 8 } "reg-class" set
+] "double" define-primitive-type
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: alien
+USING: assembler compiler errors generic
+hashtables kernel kernel-internals lists math namespaces parser
+sequences strings words ;
+
+! Some code for interfacing with C structures.
+
+: define-getter ( offset type name -- )
+ #! Define a word with stack effect ( alien -- obj ) in the
+ #! current 'in' vocabulary.
+ create-in >r c-getter cons r> swap define-compound ;
+
+: define-setter ( offset type name -- )
+ #! Define a word with stack effect ( obj alien -- ) in the
+ #! current 'in' vocabulary.
+ "set-" swap append create-in >r c-setter cons r>
+ swap define-compound ;
+
+: define-field ( offset type name -- offset )
+ >r dup >r c-align align r> r>
+ "struct-name" get swap "-" swap append3
+ ( offset type name -- )
+ 3dup define-getter 3dup define-setter
+ drop c-size + ;
+
+: define-member ( max type -- max )
+ c-size max ;
+
+: define-struct-type ( width -- )
+ #! Define inline and pointer type for the struct. Pointer
+ #! type is exactly like void*.
+ [
+ "width" set
+ bootstrap-cell "align" set
+ [ swap <displaced-alien> ] "getter" set
+ "width" get [ %unbox-struct ] curry "unboxer" set
+ "width" get [ %box-struct ] curry "boxer" set
+ "struct" on
+ ] "struct-name" get define-c-type
+ "struct-name" get in get init-c-type ;
+
+: c-struct? ( type -- ? )
+ c-types get hash [ "struct" swap hash ] [ f ] if* ;
--- /dev/null
+IN: alien
+USING: help ;
+
+HELP: c-struct? "( type -- ? )"
+{ $values { "type" "a string" } { "?" "a boolean" } }
+{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: BEGIN-STRUCT: } "." } ;
--- /dev/null
+! Copyright (C) 2005 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+IN: !syntax
+USING: alien compiler kernel lists math namespaces parser
+sequences syntax words ;
+
+: DLL" skip-blank parse-string dlopen swons ; parsing
+
+: ALIEN: scan-word <alien> swons ; parsing
+
+: LIBRARY: scan "c-library" set ; parsing
+
+: FUNCTION:
+ scan "c-library" get scan string-mode on
+ [ string-mode off define-c-word ] [ ] ; parsing
+
+: TYPEDEF: scan scan typedef ; parsing
+
+: BEGIN-STRUCT: ( -- offset )
+ scan "struct-name" set 0 ; parsing
+
+: FIELD: ( offset -- offset )
+ scan scan define-field ; parsing
+
+: END-STRUCT ( length -- )
+ define-struct-type ; parsing
+
+: C-UNION:
+ scan "struct-name" set
+ string-mode on [
+ string-mode off
+ 0 [ define-member ] reduce define-struct-type
+ ] [ ] ; parsing
+
+: C-ENUM:
+ string-mode on [
+ string-mode off 0 [
+ create-in swap [ unit define-compound ] keep 1+
+ ] reduce drop
+ ] [ ] ; parsing
--- /dev/null
+IN: syntax
+USING: alien help ;
+
+HELP: DLL" "path\""
+{ $values { "path" "a path name string" } }
+{ $description "Constructs a DLL handle at parse time." }
+{ $see-also dlopen } ;
+
+HELP: ALIEN: "address"
+{ $values { "address" "a non-negative integer" } }
+{ $description "Creates an alien object at parse time." }
+{ $notes "Alien objects are invalidated between image saves and loads." }
+{ $see-also <alien> } ;
+
+HELP: LIBRARY: "name"
+{ $values { "name" "a logical library name" } }
+{ $description "Sets the logical library for consequent " { $link POSTPONE: FUNCTION: } " definitions that follow." } ;
+
+HELP: FUNCTION: "return name ( parameters )"
+{ $values { "return" "a C return type" } { "name" "a C function name" "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
+{ $description "Defines a new word " { $snippet "name" } " which calls a C library function with the same name, in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
+$terpri
+"The new word must be compiled before being executed; see " { $link "compiler" } "." }
+{ $examples
+"For example, suppose the " { $snippet "foo" } " library exports the following function:"
+{ $code
+ "void the_answer(char* question, int value) {"
+ " printf(\"The answer to %s is %d.\n\",question,value);"
+ "}"
+}
+"You can define a word for invoking it:"
+{ $example
+ "LIBRARY: foo\nFUNCTION: the_answer ( char* question, int value ) ;\n\ the_answer compile\n\"the question\" 42 the-answer" "The answer to the question is 42."
+} }
+{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration slightly easier to read:"
+{ $code
+ "FUNCTION: void glHint ( GLenum target, GLenum mode ) ;"
+ "FUNCTION: void glHint GLenum target GLenum mode ;"
+} } ;
+
+HELP: TYPEDEF: "old new"
+{ $values { "old" "a C type" } { "new" "a C type" } }
+{ $description "Alises the C types " { $snippet "old" } " and " { $snippet "old*" } " under the names " { $snippet "new" } " and " { $snippet "new*" } ", respectively." }
+{ $see-also (typedef) typedef } ;
+
+HELP: BEGIN-STRUCT: "name"
+{ $values { "name" "a new C type name" } }
+{ $description "Begins reading a C struct definition. This word must be followed by one or more " { $link POSTPONE: FIELD: } " declarations, terminating in " { $link POSTPONE: END-STRUCT } "." } ;
+
+HELP: FIELD: "type name"
+{ $values { "type" "a C type" } { "name" "a field name" } }
+{ $description "Adds a field to the C structure currently being read. This word can only be used inside a " { $link POSTPONE: BEGIN-STRUCT: } "/" { $link POSTPONE: END-STRUCT } " pair." } ;
+
+HELP: END-STRUCT f
+{ $description "Ends a structure definition. Only valid after a " { $link POSTPONE: BEGIN-STRUCT: } "." } ;
+
+HELP: C-UNION: "name members..."
+{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
+{ $description "Defines a new C type sized to fit its largest member." }
+{ $examples { $code "C-UNION: event active-event keyboard-event mouse-event ;" } } ;
+
+HELP: C-ENUM: "words..."
+{ $values { "words" "a sequence of word names" } }
+{ $description "Creates a sequence of compound definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." }
+{ $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 symbolic constants instead." }
+{ $examples
+ "The following two lines are equivalent:"
+ { $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
+} ;
+++ /dev/null
-IN: compiler
-USING: generic kernel kernel-internals math memory namespaces
-sequences ;
-
-! A scratch register for computations
-TUPLE: vreg n ;
-
-! Register classes
-TUPLE: int-regs ;
-TUPLE: float-regs size ;
-
-! A pseudo-register class for parameters spilled on the stack
-TUPLE: stack-params ;
-
-! Return values of this class go here
-GENERIC: return-reg ( register-class -- reg )
-
-! Sequence of registers used for parameter passing in class
-GENERIC: fastcall-regs ( register-class -- regs )
-
-! Sequence mapping vreg-n to native assembler registers
-DEFER: vregs ( -- regs )
-
-! Load a literal (immediate or indirect)
-G: load-literal ( obj vreg -- ) 1 standard-combination ;
-
-! Set up caller stack frame (PowerPC and AMD64)
-DEFER: %prologue ( n -- )
-
-! Tail call another word
-DEFER: %jump ( label -- )
-
-! Call another word
-DEFER: %call ( label -- )
-
-! Local jump for branches or tail calls in nested #label
-DEFER: %jump-label ( label -- )
-
-! Test if vreg is 'f' or not
-DEFER: %jump-t ( label vreg -- )
-
-! Jump table of addresses (one cell each) is right after this
-DEFER: %dispatch ( vreg -- )
-
-! Return to caller
-DEFER: %return ( -- )
-
-! Change datastack height
-DEFER: %inc-d ( n -- )
-
-! Change callstack height
-DEFER: %inc-r ( n -- )
-
-! Load stack into vreg
-DEFER: %peek ( vreg loc -- )
-
-! Store vreg to stack
-DEFER: %replace ( vreg loc -- )
-
-! FFI stuff
-DEFER: %unbox ( n reg-class func -- )
-
-DEFER: %unbox-struct ( n reg-class size -- )
-
-DEFER: %box ( n reg-class func -- )
-
-DEFER: %box-struct ( n reg-class size -- )
-
-DEFER: %alien-invoke ( library function -- )
-
-DEFER: %alien-callback ( quot -- )
-
-DEFER: %callback-value ( reg-class func -- )
-
-! A few FFI operations have default implementations
-: %cleanup ( n -- ) drop ;
-
-: %stack>freg ( n reg reg-class -- ) 3drop ;
-
-: %freg>stack ( n reg reg-class -- ) 3drop ;
-
-! Some stuff probably not worth redefining in other backends
-M: stack-params fastcall-regs drop 0 ;
-
-GENERIC: reg-size ( register-class -- n )
-
-GENERIC: inc-reg-class ( register-class -- )
-
-M: int-regs reg-size drop cell ;
-
-: (inc-reg-class)
- dup class inc
- macosx? [ reg-size stack-params +@ ] [ drop ] if ;
-
-M: int-regs inc-reg-class
- (inc-reg-class) ;
-
-M: float-regs reg-size float-regs-size ;
-
-M: float-regs inc-reg-class
- dup (inc-reg-class)
- macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
-
-GENERIC: v>operand
-
-M: integer v>operand tag-bits shift ;
-
-M: vreg v>operand vreg-n vregs nth ;
-
-M: f v>operand address ;
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: assembler
-USING: alien generic hashtables kernel kernel-internals lists
-math memory namespaces ;
-
-: compiled-base 18 getenv ; inline
-
-: compiled-header HEX: 01c3babe ; inline
-
-: set-compiled-1 ( n a -- ) f swap set-alien-signed-1 ; inline
-: set-compiled-4 ( n a -- ) f swap set-alien-signed-4 ; inline
-: compiled-cell ( a -- n ) f swap alien-signed-cell ; inline
-: set-compiled-cell ( n a -- ) f swap set-alien-signed-cell ; inline
-
-: compile-aligned ( n -- )
- compiled-offset 8 align set-compiled-offset ; inline
-
-: add-literal ( obj -- lit# )
- address literal-top [ set-compiled-cell ] keep
- dup cell + set-literal-top ;
-
-: assemble-1 ( n -- )
- compiled-offset set-compiled-1
- compiled-offset 1+ set-compiled-offset ; inline
-
-: assemble-4 ( n -- )
- compiled-offset set-compiled-4
- compiled-offset 4 + set-compiled-offset ; inline
-
-: assemble-cell ( n -- )
- compiled-offset set-compiled-cell
- compiled-offset cell + set-compiled-offset ; inline
-
-: begin-assembly ( -- code-len-fixup reloc-len-fixup )
- compiled-header assemble-cell
- compiled-offset 0 assemble-cell
- compiled-offset 0 assemble-cell ;
-
-: w>h/h dup -16 shift HEX: ffff bitand >r HEX: ffff bitand r> ;
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: arrays assembler errors generic hashtables inference
-kernel kernel-internals lists math namespaces queues sequences
-words ;
-
-GENERIC: stack-reserve*
-
-M: object stack-reserve* drop 0 ;
-
-: stack-reserve ( node -- n )
- 0 swap [ stack-reserve* max ] each-node ;
-
-DEFER: #terminal?
-
-PREDICATE: #merge #terminal-merge node-successor #terminal? ;
-
-PREDICATE: #call #terminal-call
- dup node-successor node-successor #terminal?
- swap if-intrinsic and ;
-
-UNION: #terminal
- POSTPONE: f #return #values #terminal-merge ;
-
-: tail-call? ( -- ? )
- node-stack get [
- dup #terminal-call? swap node-successor #terminal? or
- ] all? ;
-
-: generate-code ( word node quot -- length | quot: node -- )
- compiled-offset >r
- compile-aligned
- rot save-xt
- over stack-reserve %prologue
- call
- compile-aligned
- compiled-offset r> - ;
-
-: generate-reloc ( -- length )
- relocation-table get
- dup [ assemble-cell ] each
- length cells ;
-
-SYMBOL: previous-offset
-
-: begin-generating ( -- code-len-fixup reloc-len-fixup )
- compiled-offset previous-offset set
- V{ } clone relocation-table set
- init-templates begin-assembly swap ;
-
-: generate-1 ( word node quot -- | quot: node -- )
- #! If generation fails, reset compiled offset.
- [
- begin-generating >r >r
- generate-code
- generate-reloc
- r> set-compiled-cell
- r> set-compiled-cell
- ] [
- previous-offset get set-compiled-offset rethrow
- ] recover ;
-
-SYMBOL: generate-queue
-
-: generate-loop ( -- )
- generate-queue get dup queue-empty? [
- drop
- ] [
- deque first3 generate-1 generate-loop
- ] if ;
-
-: generate-block ( word node quot -- | quot: node -- )
- 3array generate-queue get enque ;
-
-GENERIC: generate-node ( node -- )
-
-: generate-nodes ( node -- )
- [ node@ generate-node ] iterate-nodes end-basic-block ;
-
-: generate-word ( node -- )
- [ [ generate-nodes ] with-node-iterator ]
- generate-block ;
-
-: generate ( word node -- )
- [
- <queue> generate-queue set
- generate-word generate-loop
- ] with-scope ;
-
-! node
-M: node generate-node ( node -- next ) drop iterate-next ;
-
-! #label
-: generate-call ( label -- next )
- end-basic-block
- tail-call? [ %jump f ] [ %call iterate-next ] if ;
-
-M: #label generate-node ( node -- next )
- #! We remap the IR node's label to a new label object here,
- #! to avoid problems with two IR #label nodes having the
- #! same label in different lexical scopes.
- dup node-param dup generate-call >r
- swap node-child generate-word r> ;
-
-! #if
-: generate-if ( node label -- next )
- <label> [
- >r >r node-children first2 generate-nodes
- r> r> %jump-label save-xt generate-nodes
- ] keep save-xt iterate-next ;
-
-M: #if generate-node ( node -- next )
- [
- end-basic-block
- <label> dup "flag" get %jump-t
- ] H{
- { +input { { 0 "flag" } } }
- } with-template generate-if ;
-
-! #call
-: [with-template] ( quot template -- quot )
- 2array >list [ with-template ] append ;
-
-: define-intrinsic ( word quot template -- | quot: -- )
- [with-template] "intrinsic" set-word-prop ;
-
-: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
-
-: define-if-intrinsic ( word quot template -- | quot: label -- )
- [with-template] "if-intrinsic" set-word-prop ;
-
-: if-intrinsic ( #call -- quot )
- dup node-successor #if?
- [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
-
-M: #call generate-node ( node -- next )
- dup if-intrinsic [
- >r <label> dup r> call
- >r node-successor r> generate-if node-successor
- ] [
- dup intrinsic
- [ call iterate-next ] [ node-param generate-call ] ?if
- ] if* ;
-
-! #call-label
-M: #call-label generate-node ( node -- next )
- node-param generate-call ;
-
-! #dispatch
-: target-label ( label -- ) 0 assemble-cell absolute-cell ;
-
-: dispatch-head ( node -- label/node )
- #! Output the jump table insn and return a list of
- #! label/branch pairs.
- [ end-basic-block "n" get %dispatch ]
- H{ { +input { { 0 "n" } } } } with-template
- node-children [ <label> dup target-label 2array ] map ;
-
-: dispatch-body ( label/node -- )
- <label> swap [
- first2 save-xt generate-nodes end-basic-block
- dup %jump-label
- ] each save-xt ;
-
-M: #dispatch generate-node ( node -- next )
- #! The parameter is a list of nodes, each one is a branch to
- #! take in case the top of stack has that type.
- dispatch-head dispatch-body iterate-next ;
-
-! #push
-UNION: immediate fixnum POSTPONE: f ;
-
-: generate-push ( node -- )
- >#push< dup length dup ensure-vregs
- alloc-reg# [ <vreg> ] map
- [ [ load-literal ] 2each ] keep
- phantom-d get phantom-append ;
-
-M: #push generate-node ( #push -- )
- generate-push iterate-next ;
-
-! #shuffle
-: phantom-shuffle-input ( n phantom -- seq )
- 2dup length <= [
- cut-phantom
- ] [
- [ phantom-locs ] keep [ length swap head-slice* ] keep
- [ append 0 ] keep set-length
- ] if ;
-
-: phantom-shuffle-inputs ( shuffle -- locs locs )
- dup shuffle-in-d length phantom-d get phantom-shuffle-input
- swap shuffle-in-r length phantom-r get phantom-shuffle-input ;
-
-: adjust-shuffle ( shuffle -- )
- dup shuffle-in-d length neg phantom-d get adjust-phantom
- shuffle-in-r length neg phantom-r get adjust-phantom ;
-
-: shuffle-vregs# ( shuffle -- n )
- dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
-
-: phantom-shuffle ( shuffle -- )
- dup shuffle-vregs# ensure-vregs
- [ phantom-shuffle-inputs ] keep
- [ shuffle* ] keep adjust-shuffle
- (template-outputs) ;
-
-M: #shuffle generate-node ( #shuffle -- )
- node-shuffle phantom-shuffle iterate-next ;
-
-! #return
-M: #return generate-node drop end-basic-block %return f ;
-
-! These constants must match native/card.h
-: card-bits 7 ;
-: card-mark HEX: 80 ;
-
-: string-offset 3 cells object-tag - ;
--- /dev/null
+IN: compiler
+USING: generic kernel kernel-internals math memory namespaces
+sequences ;
+
+! A scratch register for computations
+TUPLE: vreg n ;
+
+! Register classes
+TUPLE: int-regs ;
+TUPLE: float-regs size ;
+
+! A pseudo-register class for parameters spilled on the stack
+TUPLE: stack-params ;
+
+! Return values of this class go here
+GENERIC: return-reg ( register-class -- reg )
+
+! Sequence of registers used for parameter passing in class
+GENERIC: fastcall-regs ( register-class -- regs )
+
+! Sequence mapping vreg-n to native assembler registers
+DEFER: vregs ( -- regs )
+
+! Load a literal (immediate or indirect)
+G: load-literal ( obj vreg -- ) 1 standard-combination ;
+
+! Set up caller stack frame (PowerPC and AMD64)
+DEFER: %prologue ( n -- )
+
+! Tail call another word
+DEFER: %jump ( label -- )
+
+! Call another word
+DEFER: %call ( label -- )
+
+! Local jump for branches or tail calls in nested #label
+DEFER: %jump-label ( label -- )
+
+! Test if vreg is 'f' or not
+DEFER: %jump-t ( label vreg -- )
+
+! Jump table of addresses (one cell each) is right after this
+DEFER: %dispatch ( vreg -- )
+
+! Return to caller
+DEFER: %return ( -- )
+
+! Change datastack height
+DEFER: %inc-d ( n -- )
+
+! Change callstack height
+DEFER: %inc-r ( n -- )
+
+! Load stack into vreg
+DEFER: %peek ( vreg loc -- )
+
+! Store vreg to stack
+DEFER: %replace ( vreg loc -- )
+
+! FFI stuff
+DEFER: %unbox ( n reg-class func -- )
+
+DEFER: %unbox-struct ( n reg-class size -- )
+
+DEFER: %box ( n reg-class func -- )
+
+DEFER: %box-struct ( n reg-class size -- )
+
+DEFER: %alien-invoke ( library function -- )
+
+DEFER: %alien-callback ( quot -- )
+
+DEFER: %callback-value ( reg-class func -- )
+
+! A few FFI operations have default implementations
+: %cleanup ( n -- ) drop ;
+
+: %stack>freg ( n reg reg-class -- ) 3drop ;
+
+: %freg>stack ( n reg reg-class -- ) 3drop ;
+
+! Some stuff probably not worth redefining in other backends
+M: stack-params fastcall-regs drop 0 ;
+
+GENERIC: reg-size ( register-class -- n )
+
+GENERIC: inc-reg-class ( register-class -- )
+
+M: int-regs reg-size drop cell ;
+
+: (inc-reg-class)
+ dup class inc
+ macosx? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: int-regs inc-reg-class
+ (inc-reg-class) ;
+
+M: float-regs reg-size float-regs-size ;
+
+M: float-regs inc-reg-class
+ dup (inc-reg-class)
+ macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
+
+GENERIC: v>operand
+
+M: integer v>operand tag-bits shift ;
+
+M: vreg v>operand vreg-n vregs nth ;
+
+M: f v>operand address ;
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: assembler
+USING: alien generic hashtables kernel kernel-internals lists
+math memory namespaces ;
+
+: compiled-base 18 getenv ; inline
+
+: compiled-header HEX: 01c3babe ; inline
+
+: set-compiled-1 ( n a -- ) f swap set-alien-signed-1 ; inline
+: set-compiled-4 ( n a -- ) f swap set-alien-signed-4 ; inline
+: compiled-cell ( a -- n ) f swap alien-signed-cell ; inline
+: set-compiled-cell ( n a -- ) f swap set-alien-signed-cell ; inline
+
+: compile-aligned ( n -- )
+ compiled-offset 8 align set-compiled-offset ; inline
+
+: add-literal ( obj -- lit# )
+ address literal-top [ set-compiled-cell ] keep
+ dup cell + set-literal-top ;
+
+: assemble-1 ( n -- )
+ compiled-offset set-compiled-1
+ compiled-offset 1+ set-compiled-offset ; inline
+
+: assemble-4 ( n -- )
+ compiled-offset set-compiled-4
+ compiled-offset 4 + set-compiled-offset ; inline
+
+: assemble-cell ( n -- )
+ compiled-offset set-compiled-cell
+ compiled-offset cell + set-compiled-offset ; inline
+
+: begin-assembly ( -- code-len-fixup reloc-len-fixup )
+ compiled-header assemble-cell
+ compiled-offset 0 assemble-cell
+ compiled-offset 0 assemble-cell ;
+
+: w>h/h dup -16 shift HEX: ffff bitand >r HEX: ffff bitand r> ;
--- /dev/null
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler
+USING: arrays assembler errors generic hashtables inference
+kernel kernel-internals lists math namespaces queues sequences
+words ;
+
+GENERIC: stack-reserve*
+
+M: object stack-reserve* drop 0 ;
+
+: stack-reserve ( node -- n )
+ 0 swap [ stack-reserve* max ] each-node ;
+
+DEFER: #terminal?
+
+PREDICATE: #merge #terminal-merge node-successor #terminal? ;
+
+PREDICATE: #call #terminal-call
+ dup node-successor node-successor #terminal?
+ swap if-intrinsic and ;
+
+UNION: #terminal
+ POSTPONE: f #return #values #terminal-merge ;
+
+: tail-call? ( -- ? )
+ node-stack get [
+ dup #terminal-call? swap node-successor #terminal? or
+ ] all? ;
+
+: generate-code ( word node quot -- length | quot: node -- )
+ compiled-offset >r
+ compile-aligned
+ rot save-xt
+ over stack-reserve %prologue
+ call
+ compile-aligned
+ compiled-offset r> - ;
+
+: generate-reloc ( -- length )
+ relocation-table get
+ dup [ assemble-cell ] each
+ length cells ;
+
+SYMBOL: previous-offset
+
+: begin-generating ( -- code-len-fixup reloc-len-fixup )
+ compiled-offset previous-offset set
+ V{ } clone relocation-table set
+ init-templates begin-assembly swap ;
+
+: generate-1 ( word node quot -- | quot: node -- )
+ #! If generation fails, reset compiled offset.
+ [
+ begin-generating >r >r
+ generate-code
+ generate-reloc
+ r> set-compiled-cell
+ r> set-compiled-cell
+ ] [
+ previous-offset get set-compiled-offset rethrow
+ ] recover ;
+
+SYMBOL: generate-queue
+
+: generate-loop ( -- )
+ generate-queue get dup queue-empty? [
+ drop
+ ] [
+ deque first3 generate-1 generate-loop
+ ] if ;
+
+: generate-block ( word node quot -- | quot: node -- )
+ 3array generate-queue get enque ;
+
+GENERIC: generate-node ( node -- )
+
+: generate-nodes ( node -- )
+ [ node@ generate-node ] iterate-nodes end-basic-block ;
+
+: generate-word ( node -- )
+ [ [ generate-nodes ] with-node-iterator ]
+ generate-block ;
+
+: generate ( word node -- )
+ [
+ <queue> generate-queue set
+ generate-word generate-loop
+ ] with-scope ;
+
+! node
+M: node generate-node ( node -- next ) drop iterate-next ;
+
+! #label
+: generate-call ( label -- next )
+ end-basic-block
+ tail-call? [ %jump f ] [ %call iterate-next ] if ;
+
+M: #label generate-node ( node -- next )
+ #! We remap the IR node's label to a new label object here,
+ #! to avoid problems with two IR #label nodes having the
+ #! same label in different lexical scopes.
+ dup node-param dup generate-call >r
+ swap node-child generate-word r> ;
+
+! #if
+: generate-if ( node label -- next )
+ <label> [
+ >r >r node-children first2 generate-nodes
+ r> r> %jump-label save-xt generate-nodes
+ ] keep save-xt iterate-next ;
+
+M: #if generate-node ( node -- next )
+ [
+ end-basic-block
+ <label> dup "flag" get %jump-t
+ ] H{
+ { +input { { 0 "flag" } } }
+ } with-template generate-if ;
+
+! #call
+: [with-template] ( quot template -- quot )
+ 2array >list [ with-template ] append ;
+
+: define-intrinsic ( word quot template -- | quot: -- )
+ [with-template] "intrinsic" set-word-prop ;
+
+: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
+
+: define-if-intrinsic ( word quot template -- | quot: label -- )
+ [with-template] "if-intrinsic" set-word-prop ;
+
+: if-intrinsic ( #call -- quot )
+ dup node-successor #if?
+ [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
+
+M: #call generate-node ( node -- next )
+ dup if-intrinsic [
+ >r <label> dup r> call
+ >r node-successor r> generate-if node-successor
+ ] [
+ dup intrinsic
+ [ call iterate-next ] [ node-param generate-call ] ?if
+ ] if* ;
+
+! #call-label
+M: #call-label generate-node ( node -- next )
+ node-param generate-call ;
+
+! #dispatch
+: target-label ( label -- ) 0 assemble-cell absolute-cell ;
+
+: dispatch-head ( node -- label/node )
+ #! Output the jump table insn and return a list of
+ #! label/branch pairs.
+ [ end-basic-block "n" get %dispatch ]
+ H{ { +input { { 0 "n" } } } } with-template
+ node-children [ <label> dup target-label 2array ] map ;
+
+: dispatch-body ( label/node -- )
+ <label> swap [
+ first2 save-xt generate-nodes end-basic-block
+ dup %jump-label
+ ] each save-xt ;
+
+M: #dispatch generate-node ( node -- next )
+ #! The parameter is a list of nodes, each one is a branch to
+ #! take in case the top of stack has that type.
+ dispatch-head dispatch-body iterate-next ;
+
+! #push
+UNION: immediate fixnum POSTPONE: f ;
+
+: generate-push ( node -- )
+ >#push< dup length dup ensure-vregs
+ alloc-reg# [ <vreg> ] map
+ [ [ load-literal ] 2each ] keep
+ phantom-d get phantom-append ;
+
+M: #push generate-node ( #push -- )
+ generate-push iterate-next ;
+
+! #shuffle
+: phantom-shuffle-input ( n phantom -- seq )
+ 2dup length <= [
+ cut-phantom
+ ] [
+ [ phantom-locs ] keep [ length swap head-slice* ] keep
+ [ append 0 ] keep set-length
+ ] if ;
+
+: phantom-shuffle-inputs ( shuffle -- locs locs )
+ dup shuffle-in-d length phantom-d get phantom-shuffle-input
+ swap shuffle-in-r length phantom-r get phantom-shuffle-input ;
+
+: adjust-shuffle ( shuffle -- )
+ dup shuffle-in-d length neg phantom-d get adjust-phantom
+ shuffle-in-r length neg phantom-r get adjust-phantom ;
+
+: shuffle-vregs# ( shuffle -- n )
+ dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
+
+: phantom-shuffle ( shuffle -- )
+ dup shuffle-vregs# ensure-vregs
+ [ phantom-shuffle-inputs ] keep
+ [ shuffle* ] keep adjust-shuffle
+ (template-outputs) ;
+
+M: #shuffle generate-node ( #shuffle -- )
+ node-shuffle phantom-shuffle iterate-next ;
+
+! #return
+M: #return generate-node drop end-basic-block %return f ;
+
+! These constants must match native/card.h
+: card-bits 7 ;
+: card-mark HEX: 80 ;
+
+: string-offset 3 cells object-tag - ;
--- /dev/null
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler
+USING: arrays generic hashtables inference io kernel math
+namespaces prettyprint sequences vectors words ;
+
+SYMBOL: free-vregs
+
+! A data stack location.
+TUPLE: ds-loc n ;
+
+! A call stack location.
+TUPLE: cs-loc n ;
+
+UNION: loc ds-loc cs-loc ;
+
+TUPLE: phantom-stack height ;
+
+C: phantom-stack ( -- stack )
+ 0 over set-phantom-stack-height
+ V{ } clone over set-delegate ;
+
+GENERIC: finalize-height ( n stack -- )
+
+GENERIC: <loc> ( n stack -- loc )
+
+: (loc)
+ #! Utility for methods on <loc>
+ phantom-stack-height - ;
+
+: (finalize-height) ( stack word -- )
+ #! We consolidate multiple stack height changes until the
+ #! last moment, and we emit the final height changing
+ #! instruction here.
+ swap [
+ phantom-stack-height
+ dup zero? [ 2drop ] [ swap execute ] if
+ 0
+ ] keep set-phantom-stack-height ; inline
+
+TUPLE: phantom-datastack ;
+
+C: phantom-datastack
+ [ >r <phantom-stack> r> set-delegate ] keep ;
+
+M: phantom-datastack <loc> (loc) <ds-loc> ;
+
+M: phantom-datastack finalize-height
+ \ %inc-d (finalize-height) ;
+
+TUPLE: phantom-callstack ;
+
+C: phantom-callstack
+ [ >r <phantom-stack> r> set-delegate ] keep ;
+
+M: phantom-callstack <loc> (loc) <cs-loc> ;
+
+M: phantom-callstack finalize-height
+ \ %inc-r (finalize-height) ;
+
+: phantom-locs ( n phantom -- locs )
+ #! A sequence of n ds-locs or cs-locs indexing the stack.
+ swap reverse-slice [ swap <loc> ] map-with ;
+
+: phantom-locs* ( phantom -- locs )
+ dup length swap phantom-locs ;
+
+: adjust-phantom ( n phantom -- )
+ #! Change stack heiht.
+ [ phantom-stack-height + ] keep set-phantom-stack-height ;
+
+GENERIC: cut-phantom ( n phantom -- seq )
+
+M: phantom-stack cut-phantom ( n phantom -- seq )
+ [ delegate cut* swap ] keep set-delegate ;
+
+SYMBOL: phantom-d
+SYMBOL: phantom-r
+
+: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
+
+: init-templates ( -- )
+ <phantom-datastack> phantom-d set
+ <phantom-callstack> phantom-r set ;
+
+: finalize-heights ( -- )
+ phantoms [ finalize-height ] 2apply ;
+
+: alloc-reg ( -- n ) free-vregs get pop ;
+
+: stack>vreg ( vreg# loc -- operand )
+ >r <vreg> dup r> %peek ;
+
+: stack>new-vreg ( loc -- vreg )
+ alloc-reg swap stack>vreg ;
+
+: vreg>stack ( value loc -- )
+ over loc? [
+ 2drop
+ ] [
+ over [ %replace ] [ 2drop ] if
+ ] if ;
+
+: vregs>stack ( phantom -- )
+ [
+ dup phantom-locs* [ vreg>stack ] 2each 0
+ ] keep set-length ;
+
+: (live-locs) ( seq -- seq )
+ dup phantom-locs* [ 2array ] 2map
+ [ first2 over loc? >r = not r> and ] subset
+ [ first ] map ;
+
+: live-locs ( phantom phantom -- hash )
+ [ (live-locs) ] 2apply append prune
+ [ dup stack>new-vreg ] map>hash ;
+
+: lazy-store ( value loc -- )
+ over loc? [
+ 2dup = [
+ 2drop
+ ] [
+ >r \ live-locs get hash r> vreg>stack
+ ] if
+ ] [
+ 2drop
+ ] if ;
+
+: flush-locs ( phantom phantom -- )
+ 2dup live-locs \ live-locs set
+ [ dup phantom-locs* [ lazy-store ] 2each ] 2apply ;
+
+: finalize-contents ( -- )
+ phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
+
+: end-basic-block ( -- )
+ finalize-contents finalize-heights ;
+
+: used-vregs ( -- seq )
+ phantoms append [ vreg? ] subset [ vreg-n ] map ;
+
+: compute-free-vregs ( -- )
+ used-vregs vregs length reverse diff
+ >vector free-vregs set ;
+
+: requested-vregs ( template -- n )
+ 0 [ [ 1+ ] unless ] reduce ;
+
+: template-vreg# ( template template -- n )
+ [ requested-vregs ] 2apply + ;
+
+: alloc-regs ( template -- template )
+ [ [ alloc-reg ] unless* ] map ;
+
+: alloc-reg# ( n -- regs )
+ free-vregs [ cut ] change ;
+
+: additional-vregs# ( seq seq -- n )
+ 2array phantoms 2array [ [ length ] map ] 2apply v-
+ 0 [ 0 max + ] reduce ;
+
+: free-vregs* ( -- n )
+ free-vregs get length
+ phantoms [ [ loc? ] subset length ] 2apply + - ;
+
+: ensure-vregs ( n -- )
+ compute-free-vregs free-vregs* <=
+ [ finalize-contents compute-free-vregs ] unless ;
+
+: lazy-load ( value loc -- value )
+ over loc?
+ [ dupd = [ drop f ] [ stack>new-vreg ] if ] [ drop ] if ;
+
+: phantom-vregs ( values template -- )
+ [ >r f lazy-load r> second set ] 2each ;
+
+: stack>vregs ( phantom template -- values )
+ [
+ [ first ] map alloc-regs
+ dup length rot phantom-locs
+ [ stack>vreg ] 2map
+ ] 2keep length neg swap adjust-phantom ;
+
+: compatible-values? ( value template -- ? )
+ {
+ { [ over loc? ] [ 2drop t ] }
+ { [ dup not ] [ 2drop t ] }
+ { [ over not ] [ 2drop f ] }
+ { [ dup integer? ] [ swap vreg-n = ] }
+ } cond ;
+
+: template-match? ( template phantom -- ? )
+ [ reverse-slice ] 2apply
+ t [ swap first compatible-values? and ] 2reduce ;
+
+: split-template ( template phantom -- slow fast )
+ over length over length <=
+ [ drop { } swap ] [ length swap cut* ] if ;
+
+: match-template ( template -- slow fast )
+ phantom-d get 2dup template-match?
+ [ split-template ] [ drop { } ] if ;
+
+: fast-input ( template -- )
+ phantom-d get
+ over length neg over adjust-phantom
+ over length swap cut-phantom
+ swap phantom-vregs ;
+
+: phantom-append ( seq stack -- )
+ over length over adjust-phantom swap nappend ;
+
+: (template-outputs) ( seq stack -- )
+ phantoms swapd phantom-append phantom-append ;
+
+SYMBOL: +input
+SYMBOL: +output
+SYMBOL: +scratch
+SYMBOL: +clobber
+
+: fix-spec ( spec -- spec )
+ H{
+ { +input { } }
+ { +output { } }
+ { +scratch { } }
+ { +clobber { } }
+ } swap hash-union ;
+
+: adjust-free-vregs ( seq -- ) free-vregs [ diff ] change ;
+
+: output-vregs ( -- seq seq )
+ +output +clobber [ get [ get ] map ] 2apply ;
+
+: outputs-clash? ( -- ? )
+ output-vregs append phantoms append
+ [ swap member? ] contains-with? ;
+
+: slow-input ( template -- )
+ dup empty? [ finalize-contents ] unless
+ outputs-clash? [ finalize-contents ] when
+ phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
+
+: input-vregs ( -- seq )
+ +input +scratch [ get [ second get vreg-n ] map ] 2apply
+ append ;
+
+: template-inputs ( -- )
+ +input get dup { } additional-vregs# ensure-vregs
+ match-template fast-input
+ used-vregs adjust-free-vregs
+ slow-input
+ input-vregs adjust-free-vregs ;
+
+: template-outputs ( -- )
+ +output get [ get ] map { } (template-outputs) ;
+
+: with-template ( quot spec -- )
+ fix-spec [ template-inputs call template-outputs ] bind
+ compute-free-vregs ; inline
+
+: operand ( var -- op ) get v>operand ; inline
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: compiler
+USING: assembler errors generic hashtables kernel
+kernel-internals lists math namespaces prettyprint sequences
+strings vectors words ;
+
+: <label> ( -- label )
+ #! Make a label.
+ gensym dup t "label" set-word-prop ;
+
+: label? ( obj -- ? )
+ dup word? [ "label" word-prop ] [ drop f ] if ;
+
+! We use a hashtable "compiled-xts" that maps words to
+! xt's that are currently being compiled. The commit-xt's word
+! sets the xt of each word in the hashtable to the value in the
+! hastable.
+SYMBOL: compiled-xts
+
+: save-xt ( word -- )
+ compiled-offset swap compiled-xts get set-hash ;
+
+: commit-xts ( -- )
+ #! We must flush the instruction cache on PowerPC.
+ flush-icache
+ compiled-xts get [ swap set-word-xt ] hash-each ;
+
+: compiled-xt ( word -- xt )
+ dup compiled-xts get hash [ ] [ word-xt ] ?if ;
+
+! deferred-xts is a vector of objects responding to the fixup
+! generic.
+SYMBOL: deferred-xts
+
+: deferred-xt deferred-xts get push ;
+
+! To support saving compiled code to disk, generator words
+! append relocation instructions to this vector.
+SYMBOL: relocation-table
+
+: rel, ( n -- ) relocation-table get push ;
+
+: cell-just-compiled compiled-offset cell - ;
+
+: 4-just-compiled compiled-offset 4 - ;
+
+: rel-absolute-cell 0 ;
+: rel-absolute 1 ;
+: rel-relative 2 ;
+: rel-2/2 3 ;
+
+: rel-type, ( arg class type -- )
+ #! Write a relocation instruction for the runtime image
+ #! loader.
+ over >r >r >r 16 shift r> 8 shift bitor r> bitor rel,
+ compiled-offset r> rel-absolute-cell = cell 4 ? - rel, ;
+
+: rel-dlsym ( name dll class -- )
+ >r cons add-literal compiled-base - cell / r>
+ 1 rel-type, ;
+
+: rel-address ( class -- )
+ #! Relocate address just compiled.
+ dup rel-relative = [ drop ] [ 0 swap 2 rel-type, ] if ;
+
+: rel-word ( word class -- )
+ over primitive? [
+ >r word-primitive r> 0 rel-type,
+ ] [
+ rel-address drop
+ ] if ;
+
+: rel-userenv ( n class -- ) 3 rel-type, ;
+
+: rel-cards ( class -- ) 0 swap 4 rel-type, ;
+
+! This is for fixing up forward references
+GENERIC: resolve ( fixup -- addr )
+
+TUPLE: absolute word ;
+
+M: absolute resolve absolute-word compiled-xt ;
+
+TUPLE: relative word to ;
+
+M: relative resolve
+ [ relative-word compiled-xt ] keep relative-to - ;
+
+GENERIC: fixup ( addr fixup -- )
+
+TUPLE: fixup-cell at ;
+
+C: fixup-cell ( resolver at -- fixup )
+ [ set-fixup-cell-at ] keep [ set-delegate ] keep ;
+
+M: fixup-cell fixup ( addr fixup -- )
+ fixup-cell-at set-compiled-cell ;
+
+TUPLE: fixup-4 at ;
+
+C: fixup-4 ( resolver at -- fixup )
+ [ set-fixup-4-at ] keep [ set-delegate ] keep ;
+
+M: fixup-4 fixup ( addr fixup -- )
+ fixup-4-at set-compiled-4 ;
+
+TUPLE: fixup-bitfield at mask ;
+
+C: fixup-bitfield ( resolver at mask -- fixup )
+ [ set-fixup-bitfield-mask ] keep
+ [ set-fixup-bitfield-at ] keep
+ [ set-delegate ] keep ;
+
+: <fixup-3> ( resolver at -- )
+ #! Only for PowerPC branch instructions.
+ BIN: 11111111111111111111111100 <fixup-bitfield> ;
+
+: <fixup-2> ( resolver at -- )
+ #! Only for PowerPC conditional branch instructions.
+ BIN: 1111111111111100 <fixup-bitfield> ;
+
+: or-compiled ( n off -- )
+ [ compiled-cell bitor ] keep set-compiled-cell ;
+
+M: fixup-bitfield fixup ( addr fixup -- )
+ [ fixup-bitfield-mask bitand ] keep
+ fixup-bitfield-at or-compiled ;
+
+TUPLE: fixup-2/2 at ;
+
+C: fixup-2/2 ( resolver at -- fixup )
+ [ set-fixup-2/2-at ] keep [ set-delegate ] keep ;
+
+M: fixup-2/2 fixup ( addr fixup -- )
+ fixup-2/2-at >r w>h/h r> tuck 4 - or-compiled or-compiled ;
+
+: relative-4 ( word -- )
+ dup rel-relative rel-word
+ compiled-offset <relative>
+ 4-just-compiled <fixup-4> deferred-xt ;
+
+: relative-3 ( word -- )
+ #! Labels only -- no image relocation information saved
+ 4-just-compiled <relative>
+ 4-just-compiled <fixup-3> deferred-xt ;
+
+: relative-2 ( word -- )
+ #! Labels only -- no image relocation information saved
+ 4-just-compiled <relative>
+ 4-just-compiled <fixup-2> deferred-xt ;
+
+: relative-2/2 ( word -- )
+ #! Labels only -- no image relocation information saved
+ compiled-offset <relative>
+ 4-just-compiled <fixup-2/2> deferred-xt ;
+
+: absolute-4 ( word -- )
+ dup rel-absolute rel-word
+ <absolute> 4-just-compiled <fixup-4> deferred-xt ;
+
+: absolute-2/2 ( word -- )
+ dup rel-2/2 rel-word
+ <absolute> cell-just-compiled <fixup-2/2> deferred-xt ;
+
+: absolute-cell ( word -- )
+ dup rel-absolute-cell rel-word
+ <absolute> cell-just-compiled <fixup-cell> deferred-xt ;
+
+! When a word is encountered that has not been previously
+! compiled, it is pushed onto this vector. Compilation stops
+! when the vector is empty.
+SYMBOL: compile-words
+
+: compiling? ( word -- ? )
+ #! A word that is compiling or already compiled will not be
+ #! added to the list of words to be compiled.
+ dup compiled?
+ over label? or
+ over compile-words get member? or
+ swap compiled-xts get hash or ;
+
+: fixup-xts ( -- )
+ deferred-xts get [ dup resolve swap fixup ] each ;
+
+: with-compiler ( quot -- )
+ [
+ V{ } clone deferred-xts set
+ H{ } clone compiled-xts set
+ V{ } clone compile-words set
+ call
+ fixup-xts
+ commit-xts
+ ] with-scope ;
+
+: postpone-word ( word -- )
+ dup compiling? not over compound? and
+ [ dup compile-words get push ] when drop ;
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: inference
+USING: arrays errors generic hashtables interpreter kernel math
+namespaces parser prettyprint sequences strings vectors words ;
+
+: unify-lengths ( seq -- seq )
+ #! Pad all vectors to the same length. If one vector is
+ #! shorter, pad it with unknown results at the bottom.
+ dup 0 [ length max ] reduce swap [ add-inputs ] map-with ;
+
+: unify-values ( seq -- value )
+ #! If all values in list are equal, return the value.
+ #! Otherwise, unify.
+ dup all-eq? [ first ] [ drop <computed> ] if ;
+
+: unify-stacks ( seq -- stack )
+ #! Replace differing literals in stacks with unknown
+ #! results.
+ [ ] subset dup empty?
+ [ drop f ] [ unify-lengths flip [ unify-values ] map ] if ;
+
+: balanced? ( in out -- ? )
+ [ dup [ length - ] [ 2drop f ] if ] 2map
+ [ ] subset all-equal? ;
+
+: unify-in-d ( seq -- n )
+ #! Input is a sequence of positive integers or f.
+ #! Output is the maximum or 0.
+ 0 [ [ max ] when* ] reduce ;
+
+: unbalanced-branches ( in out -- )
+ { "Unbalanced branches:" } -rot [
+ swap unparse " " rot length unparse append3
+ ] 2map append "\n" join inference-error ;
+
+: unify-effect ( in out -- in out )
+ #! In is a sequence of integers; out is a sequence of stacks.
+ 2dup balanced? [
+ unify-stacks >r unify-in-d r>
+ ] [
+ unbalanced-branches
+ ] if ;
+
+: active-variable ( seq symbol -- seq )
+ swap [
+ terminated? over hash [ 2drop f ] [ hash ] if
+ ] map-with ;
+
+: datastack-effect ( seq -- )
+ dup d-in active-variable
+ swap meta-d active-variable
+ unify-effect meta-d set d-in set ;
+
+: callstack-effect ( seq -- )
+ dup length 0 <array>
+ swap meta-r active-variable
+ unify-effect meta-r set drop ;
+
+: unify-effects ( seq -- )
+ dup datastack-effect dup callstack-effect
+ [ terminated? swap hash ] all? terminated? set ;
+
+: unify-dataflow ( effects -- nodes )
+ [ [ dataflow-graph get ] bind ] map ;
+
+: copy-inference ( -- )
+ meta-r [ clone ] change
+ meta-d [ clone ] change
+ d-in [ ] change
+ dataflow-graph off
+ current-node off ;
+
+: infer-branch ( value -- namespace )
+ #! Return a namespace with inferencer variables:
+ #! meta-d, meta-r, d-in. They are set to f if
+ #! terminate was called.
+ [
+ [
+ base-case-continuation set
+ copy-inference
+ dup value-recursion recursive-state set
+ dup value-literal infer-quot
+ terminated? get [ #values node, ] unless
+ f
+ ] callcc1 [ terminate ] when drop
+ ] make-hash ;
+
+: (infer-branches) ( branchlist -- list )
+ [ infer-branch ] map dup unify-effects unify-dataflow ;
+
+: infer-branches ( branches node -- )
+ #! Recursive stack effect inference is done here. If one of
+ #! the branches has an undecidable stack effect, we set the
+ #! base case to this stack effect and try again.
+ [ >r (infer-branches) r> set-node-children ] keep
+ node, #merge node, ;
--- /dev/null
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: inference
+USING: arrays generic hashtables interpreter kernel lists math
+namespaces parser sequences words ;
+
+! The dataflow IR is the first of the two intermediate
+! representations used by Factor. It annotates concatenative
+! code with stack flow information and types.
+
+TUPLE: node param shuffle
+ classes literals history
+ successor children ;
+
+M: node = eq? ;
+
+: make-node ( param in-d out-d in-r out-r node -- node )
+ [ >r swapd <shuffle> f f f f f <node> r> set-delegate ] keep ;
+
+: node-in-d node-shuffle shuffle-in-d ;
+: node-in-r node-shuffle shuffle-in-r ;
+: node-out-d node-shuffle shuffle-out-d ;
+: node-out-r node-shuffle shuffle-out-r ;
+
+: set-node-in-d node-shuffle set-shuffle-in-d ;
+: set-node-in-r node-shuffle set-shuffle-in-r ;
+: set-node-out-d node-shuffle set-shuffle-out-d ;
+: set-node-out-r node-shuffle set-shuffle-out-r ;
+
+: empty-node f { } { } { } { } ;
+: param-node ( label) { } { } { } { } ;
+: in-node ( inputs) >r f r> { } { } { } ;
+: out-node ( outputs) >r f { } r> { } { } ;
+
+: d-tail ( n -- list ) meta-d get tail* ;
+: r-tail ( n -- list ) meta-r get tail* ;
+
+: node-child node-children first ;
+
+TUPLE: #label ;
+C: #label make-node ;
+: #label ( label -- node ) param-node <#label> ;
+
+TUPLE: #entry ;
+C: #entry make-node ;
+: #entry ( -- node ) meta-d get clone in-node <#entry> ;
+
+TUPLE: #call ;
+C: #call make-node ;
+: #call ( word -- node ) param-node <#call> ;
+
+TUPLE: #call-label ;
+C: #call-label make-node ;
+: #call-label ( label -- node ) param-node <#call-label> ;
+
+TUPLE: #push ;
+C: #push make-node ;
+: #push ( outputs -- node ) d-tail out-node <#push> ;
+: >#push< ( node -- seq ) node-out-d [ value-literal ] map ;
+
+TUPLE: #shuffle ;
+C: #shuffle make-node ;
+: #shuffle ( -- node ) empty-node <#shuffle> ;
+
+TUPLE: #values ;
+C: #values make-node ;
+: #values ( -- node ) meta-d get clone in-node <#values> ;
+
+TUPLE: #return ;
+C: #return make-node ;
+: #return ( label -- node )
+ #! The parameter is the label we are returning from, or if
+ #! f, this is a top-level return.
+ meta-d get clone in-node <#return>
+ [ set-node-param ] keep ;
+
+TUPLE: #if ;
+C: #if make-node ;
+: #if ( in -- node ) 1 d-tail in-node <#if> ;
+
+TUPLE: #dispatch ;
+C: #dispatch make-node ;
+: #dispatch ( in -- node ) 1 d-tail in-node <#dispatch> ;
+
+TUPLE: #merge ;
+C: #merge make-node ;
+: #merge ( -- node ) meta-d get clone out-node <#merge> ;
+
+TUPLE: #terminate ;
+C: #terminate make-node ;
+: #terminate ( -- node ) empty-node <#terminate> ;
+
+: node-inputs ( d-count r-count node -- )
+ tuck
+ >r r-tail r> set-node-in-r
+ >r d-tail r> set-node-in-d ;
+
+: node-outputs ( d-count r-count node -- )
+ tuck
+ >r r-tail r> set-node-out-r
+ >r d-tail r> set-node-out-d ;
+
+! Variable holding dataflow graph being built.
+SYMBOL: dataflow-graph
+! The most recently added node.
+SYMBOL: current-node
+
+: node, ( node -- )
+ dataflow-graph get [
+ dup current-node [ set-node-successor ] change
+ ] [
+ ! first node
+ dup dataflow-graph set current-node set
+ ] if ;
+
+: node-values ( node -- values )
+ [
+ dup node-in-d % dup node-out-d %
+ dup node-in-r % node-out-r %
+ ] { } make ;
+
+: uses-value? ( value node -- ? ) node-values memq? ;
+
+: outputs-value? ( value node -- ? )
+ 2dup node-out-d member? >r node-out-r member? r> or ;
+
+: last-node ( node -- last )
+ dup node-successor [ last-node ] [ ] ?if ;
+
+: penultimate-node ( node -- penultimate )
+ dup node-successor dup [
+ dup node-successor
+ [ nip penultimate-node ] [ drop ] if
+ ] [
+ 2drop f
+ ] if ;
+
+: drop-inputs ( node -- #shuffle )
+ node-in-d clone in-node <#shuffle> ;
+
+: #drop ( n -- #shuffle )
+ d-tail in-node <#shuffle> ;
+
+: each-node ( node quot -- | quot: node -- )
+ over [
+ [ call ] 2keep swap
+ [ node-children [ swap each-node ] each-with ] 2keep
+ node-successor swap each-node
+ ] [
+ 2drop
+ ] if ; inline
+
+: each-node-with ( obj node quot -- | quot: obj node -- )
+ swap [ with ] each-node 2drop ; inline
+
+: all-nodes? ( node quot -- ? | quot: node -- ? )
+ over [
+ [ call ] 2keep rot [
+ [
+ swap node-children [ swap all-nodes? ] all-with?
+ ] 2keep rot [
+ >r node-successor r> all-nodes?
+ ] [
+ 2drop f
+ ] if
+ ] [
+ 2drop f
+ ] if
+ ] [
+ 2drop t
+ ] if ; inline
+
+: all-nodes-with? ( obj node quot -- ? | quot: obj node -- ? )
+ swap [ with rot ] all-nodes? 2nip ; inline
+
+: remember-node ( word node -- )
+ #! Annotate each node with the fact it was inlined from
+ #! 'word'.
+ [
+ dup #call?
+ [ [ node-history ?push ] keep set-node-history ]
+ [ 2drop ] if
+ ] each-node-with ;
+
+GENERIC: calls-label* ( label node -- ? )
+
+M: node calls-label* 2drop f ;
+
+M: #call-label calls-label* node-param eq? ;
+
+: calls-label? ( label node -- ? )
+ [ calls-label* not ] all-nodes-with? not ;
+
+: recursive-label? ( node -- ? )
+ dup node-param swap calls-label? ;
+
+SYMBOL: node-stack
+
+: >node node-stack get push ;
+: node> node-stack get pop ;
+: node@ node-stack get peek ;
+
+DEFER: iterate-nodes
+
+: iterate-children ( quot -- )
+ node@ node-children [ swap iterate-nodes ] each-with ;
+ inline
+
+: iterate-next ( -- node ) node@ node-successor ;
+
+: iterate-nodes ( node quot -- )
+ over [
+ [ swap >node call node> drop ] keep
+ over [ iterate-nodes ] [ 2drop ] if
+ ] [
+ 2drop
+ ] if ; inline
+
+: ?set-node-successor ( next prev -- )
+ [ set-node-successor ] [ drop ] if* ;
+
+: map-node ( prev quot -- )
+ swap >r node@ swap call dup r> ?set-node-successor
+ node> drop >node ; inline
+
+DEFER: map-children
+DEFER: (map-nodes)
+
+: map-next ( quot -- )
+ node@ [
+ swap [ map-children ] keep
+ node> node-successor >node (map-nodes)
+ ] [
+ drop
+ ] if* ; inline
+
+: (map-nodes) ( prev quot -- | quot: node -- node )
+ node@
+ [ [ map-node ] keep map-next ]
+ [ drop f swap ?set-node-successor ] if ; inline
+
+: map-first ( node quot -- node | quot: node -- node )
+ call node> drop dup >node ; inline
+
+: map-nodes ( node quot -- node | quot: node -- node )
+ over [
+ over >node [ map-first ] keep map-next node>
+ ] when drop ; inline
+
+: map-children ( quot -- | quot: node -- node )
+ node@ [ node-children [ swap map-nodes ] map-with ] keep
+ set-node-children ; inline
+
+: with-node-iterator ( quot -- )
+ [ V{ } clone node-stack set call ] with-scope ; inline
+
+: (subst-values) ( new old node -- )
+ [
+ [ node-in-d subst ] 3keep [ node-in-r subst ] 3keep
+ [ node-out-d subst ] 3keep [ node-out-r subst ] 3keep
+ drop
+ ] each-node 2drop ;
+
+: subst-values ( new old node -- )
+ #! Mutates nodes.
+ 1 node-stack get head* swap add
+ [ >r 2dup r> node-successor (subst-values) ] each 2drop ;
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: inference
+USING: arrays errors generic inspector interpreter io kernel
+lists math namespaces parser prettyprint sequences strings
+vectors words ;
+
+! This variable takes a boolean value.
+SYMBOL: inferring-base-case
+
+! Called when a recursive call during base case inference is
+! found. Either tries to infer another branch, or gives up.
+SYMBOL: base-case-continuation
+
+TUPLE: inference-error message rstate data-stack call-stack ;
+
+: inference-error ( msg -- )
+ recursive-state get meta-d get meta-r get
+ <inference-error> throw ;
+
+M: inference-error error. ( error -- )
+ "Inference error:" print
+ dup inference-error-message print
+ "Recursive state:" print
+ inference-error-rstate describe ;
+
+M: object value-literal ( value -- )
+ {
+ "A literal value was expected where a computed value was found.\n"
+ "This means the word you are inferring applies 'call' or 'execute'\n"
+ "to a value that is not known at compile time.\n"
+ "See the handbook for details."
+ } concat inference-error ;
+
+! Word properties that affect inference:
+! - infer-effect -- must be set. controls number of inputs
+! expected, and number of outputs produced.
+! - infer - quotation with custom inference behavior; if uses
+! this. Word is passed on the stack.
+
+! Vector of results we had to add to the datastack. Ie, the
+! inputs.
+SYMBOL: d-in
+
+: pop-literal ( -- rstate obj )
+ 1 #drop node,
+ pop-d dup value-recursion swap value-literal ;
+
+: value-vector ( n -- vector ) [ drop <computed> ] map >vector ;
+
+: add-inputs ( n stack -- stack )
+ tuck length - dup 0 >
+ [ value-vector swap append ] [ drop ] if ;
+
+: ensure-values ( n -- )
+ dup meta-d get length - 0 max d-in [ + ] change
+ meta-d [ add-inputs ] change ;
+
+: effect ( -- { in# out# } )
+ #! After inference is finished, collect information.
+ d-in get meta-d get length 2array ;
+
+SYMBOL: terminated?
+
+: init-inference ( recursive-state -- )
+ terminated? off
+ V{ } clone meta-r set
+ V{ } clone meta-d set
+ 0 d-in set
+ recursive-state set
+ dataflow-graph off
+ current-node off ;
+
+GENERIC: apply-object
+
+: apply-literal ( obj -- )
+ #! Literals are annotated with the current recursive
+ #! state.
+ <value> push-d 1 #push node, ;
+
+M: object apply-object apply-literal ;
+
+M: wrapper apply-object wrapped apply-literal ;
+
+: terminate ( -- )
+ #! Ignore this branch's stack effect.
+ terminated? on #terminate node, ;
+
+GENERIC: infer-quot
+
+M: general-list infer-quot ( quot -- )
+ #! Recursive calls to this word are made for nested
+ #! quotations.
+ [ terminated? get [ drop f ] [ apply-object t ] if ] all? drop ;
+
+: infer-quot-value ( rstate quot -- )
+ recursive-state get >r swap recursive-state set
+ infer-quot r> recursive-state set ;
+
+: check-return ( -- )
+ #! Raise an error if word leaves values on return stack.
+ meta-r get empty? [
+ "Word leaves " meta-r get length number>string
+ " element(s) on return stack. Check >r/r> usage." append3
+ inference-error
+ ] unless ;
+
+: with-infer ( quot -- )
+ [
+ inferring-base-case off
+ base-case-continuation off
+ f init-inference
+ call
+ check-return
+ ] with-scope ;
+
+: infer ( quot -- effect )
+ #! Stack effect of a quotation.
+ [ infer-quot effect ] with-infer ;
+
+: (dataflow) ( quot -- dataflow )
+ infer-quot f #return node, dataflow-graph get ;
+
+: dataflow ( quot -- dataflow )
+ #! Data flow of a quotation.
+ [ (dataflow) ] with-infer ;
+
+: dataflow-with ( quot stack -- effect )
+ #! Infer starting from a stack of values.
+ [ meta-d set (dataflow) ] with-infer ;
--- /dev/null
+IN: inference
+USING: help ;
+
+HELP: infer "( quot -- effect )"
+{ $values { "quot" "a quotation" } { "effect" "a pair of integers" } }
+{ $description "Attempts to infer the quotation's stack effect, outputting a pair holding the correct of data stack inputs and outputs for the quotation." }
+{ $errors "Throws an error if stack effect inference fails. See " { $link "inference" } "." } ;
--- /dev/null
+IN: inference
+USING: arrays alien assembler errors generic hashtables
+hashtables-internals interpreter io io-internals kernel
+kernel-internals lists math math-internals memory parser
+sequences strings vectors words prettyprint ;
+
+! We transform calls to these words into 'branched' forms;
+! eg, there is no VOP for fixnum<=, only fixnum<= followed
+! by an #if, so if we have a 'bare' fixnum<= we add
+! [ t ] [ f ] if at the end.
+
+! This transformation really belongs in the optimizer, but it
+! is simpler to do it here.
+\ fixnum< [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ fixnum< t "flushable" set-word-prop
+\ fixnum< t "foldable" set-word-prop
+
+\ fixnum<= [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ fixnum<= t "flushable" set-word-prop
+\ fixnum<= t "foldable" set-word-prop
+
+\ fixnum> [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ fixnum> t "flushable" set-word-prop
+\ fixnum> t "foldable" set-word-prop
+
+\ fixnum>= [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ fixnum>= t "flushable" set-word-prop
+\ fixnum>= t "foldable" set-word-prop
+
+\ eq? [ [ object object ] [ object ] ] "infer-effect" set-word-prop
+\ eq? t "flushable" set-word-prop
+\ eq? t "foldable" set-word-prop
+
+: manual-branch ( word -- )
+ dup "infer-effect" word-prop consume/produce
+ [ [ t ] [ f ] if ] infer-quot ;
+
+! { fixnum<= fixnum< fixnum>= fixnum> eq? }
+! [ dup [ manual-branch ] curry "infer" set-word-prop ] each
+
+! Primitive combinators
+\ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop
+
+\ call [ pop-literal infer-quot-value ] "infer" set-word-prop
+
+\ execute [ [ word ] [ ] ] "infer-effect" set-word-prop
+
+\ execute [
+ pop-literal unit infer-quot-value
+] "infer" set-word-prop
+
+\ if [ [ object general-list general-list ] [ ] ] "infer-effect" set-word-prop
+
+\ if [
+ 2 #drop node, pop-d pop-d swap 2array
+ #if pop-d drop infer-branches
+] "infer" set-word-prop
+
+\ cond [ [ object ] [ ] ] "infer-effect" set-word-prop
+
+\ cond [
+ pop-literal reverse-slice
+ [ no-cond ] swap alist>quot infer-quot-value
+] "infer" set-word-prop
+
+\ dispatch [ [ fixnum array ] [ ] ] "infer-effect" set-word-prop
+
+\ dispatch [
+ pop-literal nip [ <value> ] map
+ #dispatch pop-d drop infer-branches
+] "infer" set-word-prop
+
+! Non-standard control flow
+\ throw [ [ object ] [ ] ] "infer-effect" set-word-prop
+
+\ throw [
+ \ throw dup "infer-effect" word-prop consume/produce
+ terminate
+] "infer" set-word-prop
+
+! Stack effects for all primitives
+\ cons [ [ object object ] [ cons ] ] "infer-effect" set-word-prop
+\ cons t "foldable" set-word-prop
+\ cons t "flushable" set-word-prop
+
+\ <vector> [ [ integer ] [ vector ] ] "infer-effect" set-word-prop
+\ <vector> t "flushable" set-word-prop
+
+\ rehash-string [ [ string ] [ ] ] "infer-effect" set-word-prop
+
+\ <sbuf> [ [ integer ] [ sbuf ] ] "infer-effect" set-word-prop
+\ <sbuf> t "flushable" set-word-prop
+
+\ >fixnum [ [ number ] [ fixnum ] ] "infer-effect" set-word-prop
+\ >fixnum t "flushable" set-word-prop
+\ >fixnum t "foldable" set-word-prop
+
+\ >bignum [ [ number ] [ bignum ] ] "infer-effect" set-word-prop
+\ >bignum t "flushable" set-word-prop
+\ >bignum t "foldable" set-word-prop
+
+\ >float [ [ number ] [ float ] ] "infer-effect" set-word-prop
+\ >float t "flushable" set-word-prop
+\ >float t "foldable" set-word-prop
+
+\ (fraction>) [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
+\ (fraction>) t "flushable" set-word-prop
+\ (fraction>) t "foldable" set-word-prop
+
+\ string>float [ [ string ] [ float ] ] "infer-effect" set-word-prop
+\ string>float t "flushable" set-word-prop
+\ string>float t "foldable" set-word-prop
+
+\ float>string [ [ float ] [ string ] ] "infer-effect" set-word-prop
+\ float>string t "flushable" set-word-prop
+\ float>string t "foldable" set-word-prop
+
+\ float>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop
+\ float>bits t "flushable" set-word-prop
+\ float>bits t "foldable" set-word-prop
+
+\ double>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop
+\ double>bits t "flushable" set-word-prop
+\ double>bits t "foldable" set-word-prop
+
+\ bits>float [ [ integer ] [ float ] ] "infer-effect" set-word-prop
+\ bits>float t "flushable" set-word-prop
+\ bits>float t "foldable" set-word-prop
+
+\ bits>double [ [ integer ] [ float ] ] "infer-effect" set-word-prop
+\ bits>double t "flushable" set-word-prop
+\ bits>double t "foldable" set-word-prop
+
+\ <complex> [ [ real real ] [ number ] ] "infer-effect" set-word-prop
+\ <complex> t "flushable" set-word-prop
+\ <complex> t "foldable" set-word-prop
+
+\ fixnum+ [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ fixnum+ t "flushable" set-word-prop
+\ fixnum+ t "foldable" set-word-prop
+
+\ fixnum+fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum+fast t "flushable" set-word-prop
+\ fixnum+fast t "foldable" set-word-prop
+
+\ fixnum- [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ fixnum- t "flushable" set-word-prop
+\ fixnum- t "foldable" set-word-prop
+
+\ fixnum-fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-fast t "flushable" set-word-prop
+\ fixnum-fast t "foldable" set-word-prop
+
+\ fixnum* [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ fixnum* t "flushable" set-word-prop
+\ fixnum* t "foldable" set-word-prop
+
+\ fixnum/i [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ fixnum/i t "flushable" set-word-prop
+\ fixnum/i t "foldable" set-word-prop
+
+\ fixnum/f [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ fixnum/f t "flushable" set-word-prop
+\ fixnum/f t "foldable" set-word-prop
+
+\ fixnum-mod [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-mod t "flushable" set-word-prop
+\ fixnum-mod t "foldable" set-word-prop
+
+\ fixnum/mod [ [ fixnum fixnum ] [ integer fixnum ] ] "infer-effect" set-word-prop
+\ fixnum/mod t "flushable" set-word-prop
+\ fixnum/mod t "foldable" set-word-prop
+
+\ fixnum-bitand [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-bitand t "flushable" set-word-prop
+\ fixnum-bitand t "foldable" set-word-prop
+
+\ fixnum-bitor [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-bitor t "flushable" set-word-prop
+\ fixnum-bitor t "foldable" set-word-prop
+
+\ fixnum-bitxor [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-bitxor t "flushable" set-word-prop
+\ fixnum-bitxor t "foldable" set-word-prop
+
+\ fixnum-bitnot [ [ fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-bitnot t "flushable" set-word-prop
+\ fixnum-bitnot t "foldable" set-word-prop
+
+\ fixnum-shift [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ fixnum-shift t "flushable" set-word-prop
+\ fixnum-shift t "foldable" set-word-prop
+
+\ bignum= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
+\ bignum= t "flushable" set-word-prop
+\ bignum= t "foldable" set-word-prop
+
+\ bignum+ [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum+ t "flushable" set-word-prop
+\ bignum+ t "foldable" set-word-prop
+
+\ bignum- [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum- t "flushable" set-word-prop
+\ bignum- t "foldable" set-word-prop
+
+\ bignum* [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum* t "flushable" set-word-prop
+\ bignum* t "foldable" set-word-prop
+
+\ bignum/i [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum/i t "flushable" set-word-prop
+\ bignum/i t "foldable" set-word-prop
+
+\ bignum/f [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum/f t "flushable" set-word-prop
+\ bignum/f t "foldable" set-word-prop
+
+\ bignum-mod [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-mod t "flushable" set-word-prop
+\ bignum-mod t "foldable" set-word-prop
+
+\ bignum/mod [ [ bignum bignum ] [ bignum bignum ] ] "infer-effect" set-word-prop
+\ bignum/mod t "flushable" set-word-prop
+\ bignum/mod t "foldable" set-word-prop
+
+\ bignum-bitand [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-bitand t "flushable" set-word-prop
+\ bignum-bitand t "foldable" set-word-prop
+
+\ bignum-bitor [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-bitor t "flushable" set-word-prop
+\ bignum-bitor t "foldable" set-word-prop
+
+\ bignum-bitxor [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-bitxor t "flushable" set-word-prop
+\ bignum-bitxor t "foldable" set-word-prop
+
+\ bignum-bitnot [ [ bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-bitnot t "flushable" set-word-prop
+\ bignum-bitnot t "foldable" set-word-prop
+
+\ bignum-shift [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-shift t "flushable" set-word-prop
+\ bignum-shift t "foldable" set-word-prop
+
+\ bignum< [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
+\ bignum< t "flushable" set-word-prop
+\ bignum< t "foldable" set-word-prop
+
+\ bignum<= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
+\ bignum<= t "flushable" set-word-prop
+\ bignum<= t "foldable" set-word-prop
+
+\ bignum> [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
+\ bignum> t "flushable" set-word-prop
+\ bignum> t "foldable" set-word-prop
+
+\ bignum>= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
+\ bignum>= t "flushable" set-word-prop
+\ bignum>= t "foldable" set-word-prop
+
+\ float+ [ [ float float ] [ float ] ] "infer-effect" set-word-prop
+\ float+ t "flushable" set-word-prop
+\ float+ t "foldable" set-word-prop
+
+\ float- [ [ float float ] [ float ] ] "infer-effect" set-word-prop
+\ float- t "flushable" set-word-prop
+\ float- t "foldable" set-word-prop
+
+\ float* [ [ float float ] [ float ] ] "infer-effect" set-word-prop
+\ float* t "flushable" set-word-prop
+\ float* t "foldable" set-word-prop
+
+\ float/f [ [ float float ] [ float ] ] "infer-effect" set-word-prop
+\ float/f t "flushable" set-word-prop
+\ float/f t "foldable" set-word-prop
+
+\ float< [ [ float float ] [ object ] ] "infer-effect" set-word-prop
+\ float< t "flushable" set-word-prop
+\ float< t "foldable" set-word-prop
+
+\ float-mod [ [ float float ] [ float ] ] "infer-effect" set-word-prop
+\ float-mod t "flushable" set-word-prop
+\ float-mod t "foldable" set-word-prop
+
+\ float<= [ [ float float ] [ object ] ] "infer-effect" set-word-prop
+\ float<= t "flushable" set-word-prop
+\ float<= t "foldable" set-word-prop
+
+\ float> [ [ float float ] [ object ] ] "infer-effect" set-word-prop
+\ float> t "flushable" set-word-prop
+\ float> t "foldable" set-word-prop
+
+\ float>= [ [ float float ] [ object ] ] "infer-effect" set-word-prop
+\ float>= t "flushable" set-word-prop
+\ float>= t "foldable" set-word-prop
+
+\ facos [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ facos t "flushable" set-word-prop
+\ facos t "foldable" set-word-prop
+
+\ fasin [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fasin t "flushable" set-word-prop
+\ fasin t "foldable" set-word-prop
+
+\ fatan [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fatan t "flushable" set-word-prop
+\ fatan t "foldable" set-word-prop
+
+\ fatan2 [ [ real real ] [ float ] ] "infer-effect" set-word-prop
+\ fatan2 t "flushable" set-word-prop
+\ fatan2 t "foldable" set-word-prop
+
+\ fcos [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fcos t "flushable" set-word-prop
+\ fcos t "foldable" set-word-prop
+
+\ fexp [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fexp t "flushable" set-word-prop
+\ fexp t "foldable" set-word-prop
+
+\ fcosh [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fcosh t "flushable" set-word-prop
+\ fcosh t "foldable" set-word-prop
+
+\ flog [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ flog t "flushable" set-word-prop
+\ flog t "foldable" set-word-prop
+
+\ fpow [ [ real real ] [ float ] ] "infer-effect" set-word-prop
+\ fpow t "flushable" set-word-prop
+\ fpow t "foldable" set-word-prop
+
+\ fsin [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fsin t "flushable" set-word-prop
+\ fsin t "foldable" set-word-prop
+
+\ fsinh [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fsinh t "flushable" set-word-prop
+\ fsinh t "foldable" set-word-prop
+
+\ fsqrt [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fsqrt t "flushable" set-word-prop
+\ fsqrt t "foldable" set-word-prop
+
+\ <word> [ [ object object ] [ word ] ] "infer-effect" set-word-prop
+\ <word> t "flushable" set-word-prop
+
+\ update-xt [ [ word ] [ ] ] "infer-effect" set-word-prop
+\ compiled? [ [ word ] [ object ] ] "infer-effect" set-word-prop
+
+\ getenv [ [ fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ setenv [ [ object fixnum ] [ ] ] "infer-effect" set-word-prop
+\ stat [ [ string ] [ general-list ] ] "infer-effect" set-word-prop
+\ (directory) [ [ string ] [ general-list ] ] "infer-effect" set-word-prop
+\ gc [ [ fixnum ] [ ] ] "infer-effect" set-word-prop
+\ gc-time [ [ string ] [ ] ] "infer-effect" set-word-prop
+\ save-image [ [ string ] [ ] ] "infer-effect" set-word-prop
+\ exit [ [ integer ] [ ] ] "infer-effect" set-word-prop
+\ room [ [ ] [ integer integer integer integer general-list ] ] "infer-effect" set-word-prop
+\ os-env [ [ string ] [ object ] ] "infer-effect" set-word-prop
+\ millis [ [ ] [ integer ] ] "infer-effect" set-word-prop
+
+\ type [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
+\ type t "flushable" set-word-prop
+\ type t "foldable" set-word-prop
+
+\ tag [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
+\ tag t "flushable" set-word-prop
+\ tag t "foldable" set-word-prop
+
+\ cwd [ [ ] [ string ] ] "infer-effect" set-word-prop
+\ cd [ [ string ] [ ] ] "infer-effect" set-word-prop
+
+\ compiled-offset [ [ ] [ integer ] ] "infer-effect" set-word-prop
+\ compiled-offset t "flushable" set-word-prop
+
+\ set-compiled-offset [ [ integer ] [ ] ] "infer-effect" set-word-prop
+
+\ literal-top [ [ ] [ integer ] ] "infer-effect" set-word-prop
+\ literal-top t "flushable" set-word-prop
+
+\ set-literal-top [ [ integer ] [ ] ] "infer-effect" set-word-prop
+
+\ address [ [ object ] [ integer ] ] "infer-effect" set-word-prop
+\ address t "flushable" set-word-prop
+
+\ dlopen [ [ string ] [ dll ] ] "infer-effect" set-word-prop
+\ dlsym [ [ string object ] [ integer ] ] "infer-effect" set-word-prop
+\ dlclose [ [ dll ] [ ] ] "infer-effect" set-word-prop
+
+\ <byte-array> [ [ integer ] [ byte-array ] ] "infer-effect" set-word-prop
+\ <byte-array> t "flushable" set-word-prop
+
+\ <displaced-alien> [ [ integer c-ptr ] [ c-ptr ] ] "infer-effect" set-word-prop
+\ <displaced-alien> t "flushable" set-word-prop
+
+\ alien-signed-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-signed-cell t "flushable" set-word-prop
+
+\ set-alien-signed-cell [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-unsigned-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-unsigned-cell t "flushable" set-word-prop
+
+\ set-alien-unsigned-cell [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-signed-8 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-signed-8 t "flushable" set-word-prop
+
+\ set-alien-signed-8 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-unsigned-8 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-unsigned-8 t "flushable" set-word-prop
+
+\ set-alien-unsigned-8 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-signed-4 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-signed-4 t "flushable" set-word-prop
+
+\ set-alien-signed-4 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-unsigned-4 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-unsigned-4 t "flushable" set-word-prop
+
+\ set-alien-unsigned-4 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-signed-2 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-signed-2 t "flushable" set-word-prop
+
+\ set-alien-signed-2 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-unsigned-2 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-unsigned-2 t "flushable" set-word-prop
+
+\ set-alien-unsigned-2 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-signed-1 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-signed-1 t "flushable" set-word-prop
+
+\ set-alien-signed-1 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-unsigned-1 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-unsigned-1 t "flushable" set-word-prop
+
+\ set-alien-unsigned-1 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-float [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
+\ alien-float t "flushable" set-word-prop
+
+\ set-alien-float [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-float [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
+\ alien-float t "flushable" set-word-prop
+
+\ set-alien-double [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien-double [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
+\ alien-double t "flushable" set-word-prop
+
+\ alien>string [ [ c-ptr ] [ string ] ] "infer-effect" set-word-prop
+\ alien>string t "flushable" set-word-prop
+
+\ string>alien [ [ string ] [ byte-array ] ] "infer-effect" set-word-prop
+\ string>alien t "flushable" set-word-prop
+
+\ string>memory [ [ string integer ] [ ] ] "infer-effect" set-word-prop
+\ memory>string [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
+
+\ alien-address [ [ alien ] [ integer ] ] "infer-effect" set-word-prop
+
+\ slot [ [ object fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ slot t "flushable" set-word-prop
+
+\ set-slot [ [ object object fixnum ] [ ] ] "infer-effect" set-word-prop
+
+\ integer-slot [ [ object fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ integer-slot t "flushable" set-word-prop
+
+\ set-integer-slot [ [ integer object fixnum ] [ ] ] "infer-effect" set-word-prop
+
+\ char-slot [ [ fixnum object ] [ fixnum ] ] "infer-effect" set-word-prop
+\ char-slot t "flushable" set-word-prop
+
+\ set-char-slot [ [ fixnum fixnum object ] [ ] ] "infer-effect" set-word-prop
+\ resize-array [ [ fixnum array ] [ array ] ] "infer-effect" set-word-prop
+\ resize-string [ [ fixnum string ] [ string ] ] "infer-effect" set-word-prop
+
+\ (hashtable) [ [ ] [ hashtable ] ] "infer-effect" set-word-prop
+\ (hashtable) t "flushable" set-word-prop
+
+\ <array> [ [ integer object ] [ array ] ] "infer-effect" set-word-prop
+\ <array> t "flushable" set-word-prop
+
+\ <tuple> [ [ integer ] [ tuple ] ] "infer-effect" set-word-prop
+\ <tuple> t "flushable" set-word-prop
+
+\ begin-scan [ [ ] [ ] ] "infer-effect" set-word-prop
+\ next-object [ [ ] [ object ] ] "infer-effect" set-word-prop
+\ end-scan [ [ ] [ ] ] "infer-effect" set-word-prop
+
+\ size [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
+\ size t "flushable" set-word-prop
+
+\ die [ [ ] [ ] ] "infer-effect" set-word-prop
+\ fopen [ [ string string ] [ alien ] ] "infer-effect" set-word-prop
+\ fgetc [ [ alien ] [ object ] ] "infer-effect" set-word-prop
+\ fwrite [ [ string alien ] [ ] ] "infer-effect" set-word-prop
+\ fflush [ [ alien ] [ ] ] "infer-effect" set-word-prop
+\ fclose [ [ alien ] [ ] ] "infer-effect" set-word-prop
+\ expired? [ [ object ] [ object ] ] "infer-effect" set-word-prop
+
+\ <wrapper> [ [ object ] [ wrapper ] ] "infer-effect" set-word-prop
+\ <wrapper> t "flushable" set-word-prop
+\ <wrapper> t "foldable" set-word-prop
+
+\ (clone) [ [ object ] [ object ] ] "infer-effect" set-word-prop
+\ (clone) t "flushable" set-word-prop
+
+\ array>tuple [ [ array ] [ tuple ] ] "infer-effect" set-word-prop
+\ array>tuple t "flushable" set-word-prop
+
+\ tuple>array [ [ tuple ] [ array ] ] "infer-effect" set-word-prop
+\ tuple>array t "flushable" set-word-prop
+
+\ array>vector [ [ array ] [ vector ] ] "infer-effect" set-word-prop
+\ array>vector t "flushable" set-word-prop
+
+\ flush-icache [ [ ] [ ] ] "infer-effect" set-word-prop
+
+\ <string> [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
+\ <string> t "flushable" set-word-prop
--- /dev/null
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: inference
+USING: hashtables kernel math namespaces sequences ;
+
+! Recursive state. An alist, mapping words to labels.
+SYMBOL: recursive-state
+
+: <computed> \ <computed> counter ;
+
+TUPLE: value uid literal recursion ;
+
+C: value ( obj -- value )
+ <computed> over set-value-uid
+ recursive-state get over set-value-recursion
+ [ set-value-literal ] keep ;
+
+M: value hashcode value-uid ;
+
+M: value = eq? ;
+
+M: integer value-uid ;
+
+M: integer value-recursion drop f ;
+
+TUPLE: shuffle in-d in-r out-d out-r ;
+
+: load-shuffle ( d r shuffle -- )
+ tuck shuffle-in-r [ set ] 2each shuffle-in-d [ set ] 2each ;
+
+: shuffled-values ( values -- values )
+ [ [ namespace hash dup ] keep ? ] map ;
+
+: store-shuffle ( shuffle -- d r )
+ dup shuffle-out-d shuffled-values
+ swap shuffle-out-r shuffled-values ;
+
+: shuffle* ( d r shuffle -- d r )
+ [ [ load-shuffle ] keep store-shuffle ] with-scope ;
+
+: split-shuffle ( d r shuffle -- d' r' d r )
+ tuck shuffle-in-r length swap cut*
+ >r >r shuffle-in-d length swap cut*
+ r> swap r> ;
+
+: join-shuffle ( d' r' d r -- d r )
+ swapd append >r append r> ;
+
+: shuffle ( d r shuffle -- d r )
+ #! d and r lengths must be at least the required length for
+ #! the shuffle.
+ [ split-shuffle ] keep shuffle* join-shuffle ;
+
+M: shuffle clone ( shuffle -- shuffle )
+ [ shuffle-in-d clone ] keep
+ [ shuffle-in-r clone ] keep
+ [ shuffle-out-d clone ] keep
+ shuffle-out-r clone
+ <shuffle> ;
--- /dev/null
+IN: inference
+USING: arrays generic interpreter kernel math namespaces
+sequences words ;
+
+: infer-shuffle-inputs ( shuffle node -- )
+ >r dup shuffle-in-d length swap shuffle-in-r length r>
+ node-inputs ;
+
+: shuffle-stacks ( shuffle -- )
+ #! Shuffle simulated stacks.
+ meta-d get meta-r get rot shuffle meta-r set meta-d set ;
+
+: infer-shuffle-outputs ( shuffle node -- )
+ >r dup shuffle-out-d length swap shuffle-out-r length r>
+ node-outputs ;
+
+: infer-shuffle ( shuffle -- )
+ #shuffle
+ 2dup infer-shuffle-inputs
+ over shuffle-stacks
+ tuck infer-shuffle-outputs
+ node, ;
+
+: shuffle>effect ( shuffle -- effect )
+ dup shuffle-in-d [ drop object ] map
+ swap shuffle-out-d [ drop object ] map 2array ;
+
+: define-shuffle ( word shuffle -- )
+ [ shuffle>effect "infer-effect" set-word-prop ] 2keep
+ [ , \ infer-shuffle , ] [ ] make "infer" set-word-prop ;
+
+{
+ { drop T{ shuffle f 1 0 { } { } } }
+ { 2drop T{ shuffle f 2 0 { } { } } }
+ { 3drop T{ shuffle f 3 0 { } { } } }
+ { dup T{ shuffle f 1 0 { 0 0 } { } } }
+ { 2dup T{ shuffle f 2 0 { 0 1 0 1 } { } } }
+ { 3dup T{ shuffle f 3 0 { 0 1 2 0 1 2 } { } } }
+ { rot T{ shuffle f 3 0 { 1 2 0 } { } } }
+ { -rot T{ shuffle f 3 0 { 2 0 1 } { } } }
+ { dupd T{ shuffle f 2 0 { 0 0 1 } { } } }
+ { swapd T{ shuffle f 3 0 { 1 0 2 } { } } }
+ { nip T{ shuffle f 2 0 { 1 } { } } }
+ { 2nip T{ shuffle f 3 0 { 2 } { } } }
+ { tuck T{ shuffle f 2 0 { 1 0 1 } { } } }
+ { over T{ shuffle f 2 0 { 0 1 0 } { } } }
+ { pick T{ shuffle f 3 0 { 0 1 2 0 } { } } }
+ { swap T{ shuffle f 2 0 { 1 0 } { } } }
+ { >r T{ shuffle f 1 0 { } { 0 } } }
+ { r> T{ shuffle f 0 1 { 0 } { } } }
+} [ first2 define-shuffle ] each
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: inference
+USING: arrays errors generic hashtables interpreter kernel lists
+math math-internals namespaces parser prettyprint sequences
+strings vectors words ;
+
+: consume-values ( n node -- )
+ over ensure-values
+ over 0 rot node-inputs [ pop-d 2drop ] each ;
+
+: produce-values ( n node -- )
+ over [ drop <computed> push-d ] each 0 swap node-outputs ;
+
+: consume/produce ( word effect -- )
+ #! Add a node to the dataflow graph that consumes and
+ #! produces a number of values.
+ swap #call
+ over first length over consume-values
+ swap second length over produce-values
+ node, ;
+
+: no-effect ( word -- )
+ "Stack effect inference of the word " swap word-name
+ " was already attempted, and failed" append3
+ inference-error ;
+
+TUPLE: rstate label base-case? ;
+
+: nest-node ( -- dataflow current )
+ dataflow-graph get dataflow-graph off
+ current-node get current-node off ;
+
+: unnest-node ( new-node dataflow current -- new-node )
+ >r >r dataflow-graph get 1array over set-node-children
+ r> dataflow-graph set
+ r> current-node set ;
+
+: with-recursive-state ( word label base-case quot -- )
+ >r <rstate> 2array recursive-state [ cons ] change r>
+ nest-node 2slip unnest-node ; inline
+
+: inline-block ( word base-case -- node-block variables )
+ [
+ copy-inference
+ >r gensym 2dup r> [
+ dup #label >r
+ #entry node,
+ swap word-def infer-quot
+ #return node, r>
+ ] with-recursive-state
+ ] make-hash ;
+
+: apply-infer ( hash -- )
+ { meta-d meta-r d-in }
+ [ [ swap hash ] keep set ] each-with ;
+
+GENERIC: collect-recursion* ( label node -- )
+
+M: node collect-recursion* ( label node -- ) 2drop ;
+
+M: #call-label collect-recursion* ( label node -- )
+ tuck node-param = [ node-in-d , ] [ drop ] if ;
+
+: collect-recursion ( #label -- seq )
+ #! Collect the input stacks of all #call-label nodes that
+ #! call given label.
+ dup node-param swap
+ [ [ collect-recursion* ] each-node-with ] { } make ;
+
+: amend-d-in ( new old -- )
+ [ length ] 2apply - d-in [ + ] change ;
+
+: join-values ( node -- )
+ #! We have to infer recursive labels twice to determine
+ #! which literals survive the recursion (eg, quotations)
+ #! and which don't (loop indices, etc). The latter cannot
+ #! be folded.
+ meta-d get [
+ >r collect-recursion r> add unify-lengths
+ flip [ unify-values ] map dup meta-d set
+ ] keep amend-d-in ;
+
+: splice-node ( node -- )
+ #! Labels which do not call themselves are just spliced into
+ #! the IR, and no #label node is added.
+ dup node-successor [
+ dup node, penultimate-node f over set-node-successor
+ dup current-node set
+ ] when drop ;
+
+: inline-closure ( word -- )
+ #! This is not a closure in the lexical scope sense, but a
+ #! closure under recursive value substitution.
+ #! If the block does not call itself, there is no point in
+ #! having the block node in the IR. Just add its contents.
+ dup f inline-block over recursive-label? [
+ meta-d get >r
+ drop join-values f inline-block apply-infer
+ r> over set-node-in-d node,
+ ] [
+ apply-infer node-child node-successor splice-node drop
+ ] if ;
+
+: infer-compound ( word base-case -- terminates? effect )
+ #! Infer a word's stack effect in a separate inferencer
+ #! instance. Outputs a boolean if the word terminates
+ #! control flow by throwing an exception or restoring a
+ #! continuation.
+ [
+ dup inferring-base-case set
+ recursive-state get init-inference
+ over >r inline-block nip
+ [ terminated? get effect ] bind r>
+ ] with-scope over consume/produce over [ terminate ] when ;
+
+GENERIC: apply-word
+
+M: object apply-word ( word -- )
+ #! A primitive with an unknown stack effect.
+ no-effect ;
+
+: save-effect ( word terminates effect -- )
+ inferring-base-case get [
+ 3drop
+ ] [
+ >r dupd "terminates" set-word-prop r>
+ "infer-effect" set-word-prop
+ ] if ;
+
+M: compound apply-word ( word -- )
+ #! Infer a compound word's stack effect.
+ [
+ dup f infer-compound save-effect
+ ] [
+ swap t "no-effect" set-word-prop rethrow
+ ] recover ;
+
+: apply-default ( word -- )
+ dup "no-effect" word-prop [
+ no-effect
+ ] [
+ dup "infer-effect" word-prop [
+ over "infer" word-prop [
+ swap first length ensure-values call drop
+ ] [
+ dupd consume/produce
+ "terminates" word-prop [ terminate ] when
+ ] if*
+ ] [
+ apply-word
+ ] if*
+ ] if ;
+
+M: word apply-object ( word -- )
+ apply-default ;
+
+M: symbol apply-object ( word -- )
+ apply-literal ;
+
+: inline-base-case ( word label -- )
+ meta-d get clone >r over t inline-block apply-infer drop
+ [ #call-label ] [ #call ] ?if r> over set-node-in-d node, ;
+
+: base-case ( word label -- )
+ over "inline" word-prop [
+ inline-base-case
+ ] [
+ drop dup t infer-compound swap
+ [ 2drop ] [ "base-case" set-word-prop ] if
+ ] if ;
+
+: no-base-case ( word -- )
+ {
+ "The base case of a recursive word could not be inferred.\n"
+ "This means the word calls itself in every control flow path.\n"
+ "See the handbook for details."
+ } concat inference-error ;
+
+: notify-base-case ( -- )
+ base-case-continuation get
+ [ t swap continue-with ] [ no-base-case ] if* ;
+
+: recursive-word ( word rstate -- )
+ #! Handle a recursive call, by either applying a previously
+ #! inferred base case, or raising an error. If the recursive
+ #! call is to a local block, emit a label call node.
+ over "infer-effect" word-prop [
+ nip consume/produce
+ ] [
+ over "base-case" word-prop [
+ nip consume/produce
+ ] [
+ dup rstate-base-case? [
+ notify-base-case
+ ] [
+ rstate-label base-case
+ ] if
+ ] if*
+ ] if* ;
+
+M: compound apply-object ( word -- )
+ #! Apply the word's stack effect to the inferencer state.
+ dup recursive-state get assoc [
+ recursive-word
+ ] [
+ dup "inline" word-prop
+ [ inline-closure ] [ apply-default ] if
+ ] if* ;
--- /dev/null
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: optimizer
+USING: arrays errors generic hashtables inference kernel lists
+math math-internals sequences words ;
+
+! A system for associating dataflow optimizers with words.
+
+: optimizer-hooks ( node -- conditions )
+ node-param "optimizer-hooks" word-prop ;
+
+: optimize-hooks ( node -- node/t )
+ dup optimizer-hooks cond ;
+
+: define-optimizers ( word optimizers -- )
+ { [ t ] [ drop t ] } add "optimizer-hooks" set-word-prop ;
+
+: partial-eval? ( #call -- ? )
+ dup node-param "foldable" word-prop [
+ dup node-in-d [
+ dup value?
+ [ 2drop t ] [ swap node-literals ?hash* nip ] if
+ ] all-with?
+ ] [
+ drop f
+ ] if ;
+
+: literal-in-d ( #call -- inputs )
+ dup node-in-d [
+ dup value?
+ [ nip value-literal ] [ swap node-literals ?hash ] if
+ ] map-with ;
+
+: partial-eval ( #call -- node )
+ dup literal-in-d over node-param
+ [ with-datastack ] catch
+ [ 3drop t ] [ inline-literals ] if ;
+
+: flip-subst ( not -- )
+ #! Note: cloning the vectors, since subst-values will modify
+ #! them.
+ [ node-in-d clone ] keep
+ [ node-out-d clone ] keep
+ subst-values ;
+
+: flip-branches ( not -- #if )
+ #! If a not is followed by an #if, flip branches and
+ #! remove the not.
+ dup flip-subst node-successor dup
+ dup node-children reverse swap set-node-children ;
+
+\ not {
+ { [ dup node-successor #if? ] [ flip-branches ] }
+} define-optimizers
+
+: disjoint-eq? ( node -- ? )
+ dup node-classes swap node-in-d
+ [ swap ?hash ] map-with
+ first2 2dup and [ classes-intersect? not ] [ 2drop f ] if ;
+
+\ eq? {
+ { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
+} define-optimizers
+
+! Arithmetic identities
+SYMBOL: @
+
+: define-identities ( words identities -- )
+ swap [ swap "identities" set-word-prop ] each-with ;
+
+: literals-match? ( values template -- ? )
+ [
+ over value? [ >r value-literal r> ] [ nip @ ] if =
+ ] 2map [ ] all? ;
+
+: values-match? ( values template -- ? )
+ [ @ = [ drop f ] unless ] 2map [ ] subset all-eq? ;
+
+: apply-identity? ( values identity -- ? )
+ first 2dup literals-match? >r values-match? r> and ;
+
+: find-identity ( node -- values identity )
+ dup node-in-d swap node-param "identities" word-prop
+ [ dupd apply-identity? ] find nip ;
+
+: apply-identities ( node -- node/f )
+ dup find-identity dup [
+ second swap dataflow-with [ subst-node ] keep
+ ] [
+ 3drop f
+ ] if ;
+
+[ + fixnum+ bignum+ float+ ] {
+ { { @ 0 } [ drop ] }
+ { { 0 @ } [ nip ] }
+} define-identities
+
+[ - fixnum- bignum- float- ] {
+ { { @ 0 } [ drop ] }
+ { { @ @ } [ 2drop 0 ] }
+} define-identities
+
+[ * fixnum* bignum* float* ] {
+ { { @ 1 } [ drop ] }
+ { { 1 @ } [ nip ] }
+ { { @ 0 } [ nip ] }
+ { { 0 @ } [ drop ] }
+ { { @ -1 } [ drop 0 swap - ] }
+ { { -1 @ } [ nip 0 swap - ] }
+} define-identities
+
+[ / /i /f fixnum/i fixnum/f bignum/i bignum/f float/f ] {
+ { { @ 1 } [ drop ] }
+ { { @ -1 } [ drop 0 swap - ] }
+} define-identities
+
+[ fixnum-mod bignum-mod ] {
+ { { @ 1 } [ 2drop 0 ] }
+} define-identities
+
+[ bitand fixnum-bitand bignum-bitand ] {
+ { { @ -1 } [ drop ] }
+ { { -1 @ } [ nip ] }
+ { { @ @ } [ drop ] }
+ { { @ 0 } [ nip ] }
+ { { 0 @ } [ drop ] }
+} define-identities
+
+[ bitor fixnum-bitor bignum-bitor ] {
+ { { @ 0 } [ drop ] }
+ { { 0 @ } [ nip ] }
+ { { @ @ } [ drop ] }
+ { { @ -1 } [ nip ] }
+ { { -1 @ } [ drop ] }
+} define-identities
+
+[ bitxor fixnum-bitxor bignum-bitxor ] {
+ { { @ 0 } [ drop ] }
+ { { 0 @ } [ nip ] }
+ { { @ -1 } [ drop bitnot ] }
+ { { -1 @ } [ nip bitnot ] }
+ { { @ @ } [ 2drop 0 ] }
+} define-identities
+
+[ shift fixnum-shift bignum-shift ] {
+ { { 0 @ } [ drop ] }
+ { { @ 0 } [ drop ] }
+} define-identities
+
+[ < fixnum< bignum< float< ] {
+ { { @ @ } [ 2drop f ] }
+} define-identities
+
+[ <= fixnum<= bignum<= float<= ] {
+ { { @ @ } [ 2drop t ] }
+} define-identities
+
+[ > fixnum> bignum> float>= ] {
+ { { @ @ } [ 2drop f ] }
+} define-identities
+
+[ >= fixnum>= bignum>= float>= ] {
+ { { @ @ } [ 2drop t ] }
+} define-identities
+
+[ eq? number= = ] {
+ { { @ @ } [ 2drop t ] }
+} define-identities
+
+M: #call optimize-node* ( node -- node/t )
+ {
+ { [ dup partial-eval? ] [ partial-eval ] }
+ { [ dup find-identity nip ] [ apply-identities ] }
+ { [ dup optimizer-hooks ] [ optimize-hooks ] }
+ { [ dup inlining-class ] [ inline-method ] }
+ { [ dup optimize-predicate? ] [ optimize-predicate ] }
+ { [ t ] [ drop t ] }
+ } cond ;
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: optimizer
+USING: arrays generic hashtables inference kernel
+kernel-internals math namespaces sequences words ;
+
+! Infer possible classes of values in a dataflow IR.
+
+! Variables used by the class inferencer
+
+! Current value --> class mapping
+SYMBOL: value-classes
+
+! Current value --> literal mapping
+SYMBOL: value-literals
+
+! Maps ties to ties
+SYMBOL: ties
+
+GENERIC: apply-tie ( tie -- )
+
+M: f apply-tie ( f -- ) drop ;
+
+TUPLE: class-tie value class ;
+
+: set-value-class* ( class value -- )
+ 2dup swap <class-tie> ties get hash [ apply-tie ] when*
+ value-classes get set-hash ;
+
+M: class-tie apply-tie ( tie -- )
+ dup class-tie-class swap class-tie-value
+ set-value-class* ;
+
+TUPLE: literal-tie value literal ;
+
+: set-value-literal* ( literal value -- )
+ over class over set-value-class*
+ 2dup swap <literal-tie> ties get hash [ apply-tie ] when*
+ value-literals get set-hash ;
+
+M: literal-tie apply-tie ( tie -- )
+ dup literal-tie-literal swap literal-tie-value
+ set-value-literal* ;
+
+GENERIC: infer-classes* ( node -- )
+
+M: node infer-classes* ( node -- ) drop ;
+
+! For conditionals, a map of child node # --> possibility
+GENERIC: child-ties ( node -- seq )
+
+M: node child-ties ( node -- seq )
+ node-children length f <array> ;
+
+: value-class* ( value -- class )
+ value-classes get hash [ object ] unless* ;
+
+: value-literal* ( value -- class )
+ value-literals get hash ;
+
+: annotate-node ( node -- )
+ #! Annotate the node with the currently-inferred set of
+ #! value classes.
+ dup node-values
+ [ dup value-class* ] map>hash swap set-node-classes ;
+
+: intersect-classes ( classes values -- )
+ [
+ [ value-class* class-and ] keep set-value-class*
+ ] 2each ;
+
+: set-tie ( tie tie -- ) ties get set-hash ;
+
+: type/tag-ties ( node n -- )
+ over node-out-d first over [ <literal-tie> ] map-with
+ >r swap node-in-d first swap [ type>class <class-tie> ] map-with r>
+ [ set-tie ] 2each ;
+
+\ type [ num-types type/tag-ties ] "create-ties" set-word-prop
+
+\ tag [ num-tags type/tag-ties ] "create-ties" set-word-prop
+
+\ eq? [
+ dup node-in-d second value? [
+ dup node-in-d first2 value-literal* <literal-tie>
+ over node-out-d first general-t <class-tie>
+ set-tie
+ ] when drop
+] "create-ties" set-word-prop
+
+: create-ties ( #call -- )
+ #! If the node is calling a class test predicate, create a
+ #! tie.
+ dup node-param "create-ties" word-prop dup [
+ call
+ ] [
+ drop dup node-param "predicating" word-prop dup [
+ >r dup node-in-d first r> <class-tie>
+ swap node-out-d first general-t <class-tie>
+ set-tie
+ ] [
+ 2drop
+ ] if
+ ] if ;
+
+\ make-tuple [
+ dup node-in-d first value-literal 1array
+] "output-classes" set-word-prop
+
+: output-classes ( node -- seq )
+ dup node-param "output-classes" word-prop [
+ call
+ ] [
+ node-param "infer-effect" word-prop second
+ dup integer? [ drop f ] when
+ ] ?if ;
+
+M: #call infer-classes* ( node -- )
+ dup node-param [
+ dup create-ties
+ dup output-classes
+ [ over node-out-d intersect-classes ] when*
+ ] when drop ;
+
+M: #push infer-classes* ( node -- )
+ node-out-d
+ [ [ value-literal ] keep set-value-literal* ] each ;
+
+M: #if child-ties ( node -- seq )
+ node-in-d first dup general-t <class-tie>
+ swap f <literal-tie> 2array ;
+
+M: #dispatch child-ties ( node -- seq )
+ dup node-in-d first
+ swap node-children length [ <literal-tie> ] map-with ;
+
+DEFER: (infer-classes)
+
+: infer-children ( node -- )
+ dup node-children swap child-ties [
+ [
+ value-classes [ clone ] change
+ ties [ clone ] change
+ apply-tie
+ (infer-classes)
+ ] with-scope
+ ] 2each ;
+
+: (infer-classes) ( node -- )
+ [
+ dup infer-classes*
+ dup annotate-node
+ dup infer-children
+ node-successor (infer-classes)
+ ] when* ;
+
+: infer-classes ( node -- )
+ [
+ H{ } clone value-classes set
+ H{ } clone value-literals set
+ H{ } clone ties set
+ (infer-classes)
+ ] with-scope ;
--- /dev/null
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: optimizer
+USING: arrays generic hashtables inference kernel lists math
+namespaces sequences words ;
+
+! Method inlining optimization
+
+GENERIC: dispatching-values ( node word -- seq )
+
+M: object dispatching-values 2drop { } ;
+
+M: standard-generic dispatching-values
+ "combination" word-prop first swap
+ node-in-d reverse-slice nth 1array ;
+
+M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
+
+: node-classes* ( node seq -- seq )
+ >r node-classes r>
+ [ swap ?hash [ object ] unless* ] map-with ;
+
+: dispatching-classes ( node -- seq )
+ dup node-in-d empty? [
+ drop { }
+ ] [
+ dup dup node-param dispatching-values node-classes*
+ ] if ;
+
+: already-inlined? ( node -- ? )
+ #! Was this node inlined from definition of 'word'?
+ dup node-param swap node-history memq? ;
+
+: inlining-class ( #call -- class )
+ #! If the generic dispatch can be eliminated, return the
+ #! class of the method that will always be invoked here.
+ dup already-inlined? [
+ drop f
+ ] [
+ dup dispatching-classes dup empty? [
+ 2drop f
+ ] [
+ dup all-eq? [
+ first swap node-param order min-class
+ ] [
+ 2drop f
+ ] if
+ ] if
+ ] if ;
+
+: will-inline ( node -- quot )
+ dup inlining-class swap node-param "methods" word-prop hash ;
+
+: method-dataflow ( node -- dataflow )
+ dup will-inline swap node-in-d dataflow-with ;
+
+: post-inline ( #return/#values #call/#merge -- )
+ dup [
+ [
+ >r node-in-d r> node-out-d
+ 2array unify-lengths first2
+ ] keep subst-values
+ ] [
+ 2drop
+ ] if ;
+
+: subst-node ( old new -- )
+ #! The last node of 'new' becomes 'old', then values are
+ #! substituted. A subsequent optimizer phase kills the
+ #! last node of 'new' and the first node of 'old'.
+ last-node 2dup swap post-inline set-node-successor ;
+
+: inline-method ( node -- node )
+ #! We set the #call node's param to f so that it gets killed
+ #! later.
+ dup method-dataflow
+ [ >r node-param r> remember-node ] 2keep
+ [ subst-node ] keep ;
+
+: related? ( actual testing -- ? )
+ #! If actual is a subset of testing or if the two classes
+ #! are disjoint, return t.
+ 2dup class< >r classes-intersect? not r> or ;
+
+: optimize-predicate? ( #call -- ? )
+ dup node-param "predicating" word-prop dup [
+ >r dup node-in-d node-classes* first r> related?
+ ] [
+ 2drop f
+ ] if ;
+
+: inline-literals ( node literals -- node )
+ #! Make #push -> #return -> successor
+ over drop-inputs [
+ >r >list [ literalize ] map dataflow [ subst-node ] keep
+ r> set-node-successor
+ ] keep ;
+
+: optimize-predicate ( #call -- node )
+ dup node-param "predicating" word-prop >r
+ dup dup node-in-d node-classes* first r> class<
+ 1array inline-literals ;
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: optimizer
+USING: arrays generic hashtables inference kernel math
+namespaces sequences words ;
+
+: node-union ( node quot -- hash | quot: node -- )
+ [
+ swap [ swap call [ dup set ] each ] each-node-with
+ ] make-hash ; inline
+
+GENERIC: literals* ( node -- seq )
+
+: literals ( node -- hash )
+ [ literals* ] node-union ;
+
+! GENERIC: flushable-values* ( node -- seq )
+!
+! : flushable-values ( node -- hash )
+! [ flushable-values* ] node-union ;
+
+GENERIC: live-values* ( node -- seq )
+
+: live-values ( node -- hash )
+ #! All values that are returned or passed to calls.
+ [ live-values* ] node-union ;
+
+: kill-node* ( values node -- )
+ 2dup [ node-in-d remove-all ] keep set-node-in-d
+ 2dup [ node-out-d remove-all ] keep set-node-out-d
+ 2dup [ node-in-r remove-all ] keep set-node-in-r
+ [ node-out-r remove-all ] keep set-node-out-r ;
+
+: kill-node ( values node -- )
+ over hash-empty?
+ [ 2drop ] [ [ kill-node* ] each-node-with ] if ;
+
+: kill-unused-literals ( node -- )
+ \ live-values get over literals hash-diff swap kill-node ;
+
+: kill-values ( node -- )
+ dup live-values over literals hash-diff swap kill-node ;
+
+! Generic nodes
+M: node literals* ( node -- ) drop { } ;
+
+! M: node flushable-values* ( node -- ) drop { } ;
+
+M: node live-values* ( node -- ) node-values ;
+
+! #shuffle
+M: #shuffle literals* ( node -- seq )
+ dup node-out-d swap node-out-r
+ [ [ value? ] subset ] 2apply append ;
+
+! #push
+M: #push literals* ( node -- seq )
+ node-values ;
+
+! #call
+! M: #call flushable-values* ( node -- )
+! dup node-param "flushable" word-prop
+! [ node-out-d ] [ drop { } ] if ;
+
+! #return
+M: #return live-values* ( node -- seq )
+ #! Values returned by local labels can be killed.
+ dup node-param [ drop { } ] [ delegate live-values* ] if ;
+
+! nodes that don't use their values directly
+UNION: #killable
+ #push #shuffle #call-label #merge #values #entry ;
+
+M: #killable live-values* ( node -- seq ) drop { } ;
+
+: purge-invariants ( stacks -- seq )
+ #! Output a sequence of values which are not present in the
+ #! same position in each sequence of the stacks sequence.
+ unify-lengths flip [ all-eq? not ] subset concat ;
+
+! #label
+M: #label live-values* ( node -- seq )
+ dup node-child node-in-d over node-in-d 2array
+ swap collect-recursion append purge-invariants ;
+
+! branching
+UNION: #branch #if #dispatch ;
+
+M: #branch live-values* ( node -- )
+ #! This assumes that the last element of each branch is a
+ #! #return node.
+ dup delegate live-values* >r
+ node-children [ last-node node-in-d ] map purge-invariants
+ r> append ;
--- /dev/null
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: optimizer
+USING: compiler generic hashtables inference io kernel
+lists math namespaces sequences vectors ;
+
+SYMBOL: optimizer-changed
+
+GENERIC: optimize-node* ( node -- node/t )
+
+: keep-optimizing ( node -- node ? )
+ dup optimize-node* dup t =
+ [ drop f ] [ nip keep-optimizing t or ] if ;
+
+: optimize-node ( node -- node )
+ [
+ keep-optimizing [ optimizer-changed on ] when
+ ] map-nodes ;
+
+: optimize ( node -- node )
+ dup kill-values dup infer-classes [
+ optimizer-changed off
+ optimize-node
+ optimizer-changed get
+ ] with-node-iterator [ optimize ] when ;
+
+: prune-if ( node quot -- successor/t )
+ over >r call [ r> node-successor ] [ r> drop t ] if ;
+ inline
+
+! Generic nodes
+M: f optimize-node* drop t ;
+
+M: node optimize-node* ( node -- t ) drop t ;
+
+! #shuffle
+M: #shuffle optimize-node* ( node -- node/t )
+ [ node-values empty? ] prune-if ;
+
+! #push
+M: #push optimize-node* ( node -- node/t )
+ [ node-out-d empty? ] prune-if ;
+
+! #return
+M: #return optimize-node* ( node -- node/t )
+ node-successor [ node-successor ] [ t ] if* ;
--- /dev/null
+IN: optimizer
+USING: generic hashtables inference io kernel kernel-internals
+lists math namespaces prettyprint sequences styles vectors words ;
+
+! A simple tool for turning dataflow IR into quotations, for
+! debugging purposes.
+
+GENERIC: node>quot ( node -- )
+
+TUPLE: comment node text ;
+
+M: comment pprint* ( ann -- )
+ "( " over comment-text " )" append3
+ swap comment-node presented associate text ;
+
+: comment, ( ? node text -- )
+ rot [ <comment> , ] [ 2drop ] if ;
+
+: values% ( prefix values -- )
+ [
+ swap %
+ dup value? [
+ value-literal unparse %
+ ] [
+ "@" % #
+ ] if
+ ] each-with ;
+
+: effect-str ( node -- str )
+ [
+ " " over node-in-d values%
+ " r: " over node-in-r values%
+ " --" %
+ " " over node-out-d values%
+ " r: " swap node-out-r values%
+ ] "" make 1 swap tail ;
+
+M: #shuffle node>quot ( ? node -- )
+ >r drop t r> dup effect-str "#shuffle: " swap append comment, ;
+
+M: #push node>quot ( ? node -- ) nip >#push< % ;
+
+DEFER: dataflow>quot
+
+: #call>quot ( ? node -- )
+ dup node-param dup
+ [ , dup effect-str comment, ] [ 3drop ] if ;
+
+M: #call node>quot ( ? node -- ) #call>quot ;
+
+M: #call-label node>quot ( ? node -- ) #call>quot ;
+
+M: #label node>quot ( ? node -- )
+ [ "#label: " over node-param word-name append comment, ] 2keep
+ node-child swap dataflow>quot , \ call , ;
+
+M: #if node>quot ( ? node -- )
+ [ "#if" comment, ] 2keep
+ node-children [ swap dataflow>quot ] map-with % \ if , ;
+
+M: #dispatch node>quot ( ? node -- )
+ [ "#dispatch" comment, ] 2keep
+ node-children [ swap dataflow>quot ] map-with , \ dispatch , ;
+
+M: #return node>quot ( ? node -- )
+ dup node-param unparse "#return " swap append comment, ;
+
+M: #values node>quot ( ? node -- ) "#values" comment, ;
+
+M: #merge node>quot ( ? node -- ) "#merge" comment, ;
+
+M: #entry node>quot ( ? node -- ) "#entry" comment, ;
+
+M: #terminate node>quot ( ? node -- ) "#terminate" comment, ;
+
+: (dataflow>quot) ( ? node -- )
+ dup [
+ 2dup node>quot node-successor (dataflow>quot)
+ ] [
+ 2drop
+ ] if ;
+
+: dataflow>quot ( node ? -- quot )
+ [ swap (dataflow>quot) ] [ ] make ;
+
+: dataflow. ( quot ? -- )
+ #! Print dataflow IR for a quotation. Flag indicates if
+ #! annotations should be printed or not.
+ >r dataflow optimize r> dataflow>quot . ;
+++ /dev/null
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: arrays generic hashtables inference io kernel math
-namespaces prettyprint sequences vectors words ;
-
-SYMBOL: free-vregs
-
-! A data stack location.
-TUPLE: ds-loc n ;
-
-! A call stack location.
-TUPLE: cs-loc n ;
-
-UNION: loc ds-loc cs-loc ;
-
-TUPLE: phantom-stack height ;
-
-C: phantom-stack ( -- stack )
- 0 over set-phantom-stack-height
- V{ } clone over set-delegate ;
-
-GENERIC: finalize-height ( n stack -- )
-
-GENERIC: <loc> ( n stack -- loc )
-
-: (loc)
- #! Utility for methods on <loc>
- phantom-stack-height - ;
-
-: (finalize-height) ( stack word -- )
- #! We consolidate multiple stack height changes until the
- #! last moment, and we emit the final height changing
- #! instruction here.
- swap [
- phantom-stack-height
- dup zero? [ 2drop ] [ swap execute ] if
- 0
- ] keep set-phantom-stack-height ; inline
-
-TUPLE: phantom-datastack ;
-
-C: phantom-datastack
- [ >r <phantom-stack> r> set-delegate ] keep ;
-
-M: phantom-datastack <loc> (loc) <ds-loc> ;
-
-M: phantom-datastack finalize-height
- \ %inc-d (finalize-height) ;
-
-TUPLE: phantom-callstack ;
-
-C: phantom-callstack
- [ >r <phantom-stack> r> set-delegate ] keep ;
-
-M: phantom-callstack <loc> (loc) <cs-loc> ;
-
-M: phantom-callstack finalize-height
- \ %inc-r (finalize-height) ;
-
-: phantom-locs ( n phantom -- locs )
- #! A sequence of n ds-locs or cs-locs indexing the stack.
- swap reverse-slice [ swap <loc> ] map-with ;
-
-: phantom-locs* ( phantom -- locs )
- dup length swap phantom-locs ;
-
-: adjust-phantom ( n phantom -- )
- #! Change stack heiht.
- [ phantom-stack-height + ] keep set-phantom-stack-height ;
-
-GENERIC: cut-phantom ( n phantom -- seq )
-
-M: phantom-stack cut-phantom ( n phantom -- seq )
- [ delegate cut* swap ] keep set-delegate ;
-
-SYMBOL: phantom-d
-SYMBOL: phantom-r
-
-: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
-
-: init-templates ( -- )
- <phantom-datastack> phantom-d set
- <phantom-callstack> phantom-r set ;
-
-: finalize-heights ( -- )
- phantoms [ finalize-height ] 2apply ;
-
-: alloc-reg ( -- n ) free-vregs get pop ;
-
-: stack>vreg ( vreg# loc -- operand )
- >r <vreg> dup r> %peek ;
-
-: stack>new-vreg ( loc -- vreg )
- alloc-reg swap stack>vreg ;
-
-: vreg>stack ( value loc -- )
- over loc? [
- 2drop
- ] [
- over [ %replace ] [ 2drop ] if
- ] if ;
-
-: vregs>stack ( phantom -- )
- [
- dup phantom-locs* [ vreg>stack ] 2each 0
- ] keep set-length ;
-
-: (live-locs) ( seq -- seq )
- dup phantom-locs* [ 2array ] 2map
- [ first2 over loc? >r = not r> and ] subset
- [ first ] map ;
-
-: live-locs ( phantom phantom -- hash )
- [ (live-locs) ] 2apply append prune
- [ dup stack>new-vreg ] map>hash ;
-
-: lazy-store ( value loc -- )
- over loc? [
- 2dup = [
- 2drop
- ] [
- >r \ live-locs get hash r> vreg>stack
- ] if
- ] [
- 2drop
- ] if ;
-
-: flush-locs ( phantom phantom -- )
- 2dup live-locs \ live-locs set
- [ dup phantom-locs* [ lazy-store ] 2each ] 2apply ;
-
-: finalize-contents ( -- )
- phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
-
-: end-basic-block ( -- )
- finalize-contents finalize-heights ;
-
-: used-vregs ( -- seq )
- phantoms append [ vreg? ] subset [ vreg-n ] map ;
-
-: compute-free-vregs ( -- )
- used-vregs vregs length reverse diff
- >vector free-vregs set ;
-
-: requested-vregs ( template -- n )
- 0 [ [ 1+ ] unless ] reduce ;
-
-: template-vreg# ( template template -- n )
- [ requested-vregs ] 2apply + ;
-
-: alloc-regs ( template -- template )
- [ [ alloc-reg ] unless* ] map ;
-
-: alloc-reg# ( n -- regs )
- free-vregs [ cut ] change ;
-
-: additional-vregs# ( seq seq -- n )
- 2array phantoms 2array [ [ length ] map ] 2apply v-
- 0 [ 0 max + ] reduce ;
-
-: free-vregs* ( -- n )
- free-vregs get length
- phantoms [ [ loc? ] subset length ] 2apply + - ;
-
-: ensure-vregs ( n -- )
- compute-free-vregs free-vregs* <=
- [ finalize-contents compute-free-vregs ] unless ;
-
-: lazy-load ( value loc -- value )
- over loc?
- [ dupd = [ drop f ] [ stack>new-vreg ] if ] [ drop ] if ;
-
-: phantom-vregs ( values template -- )
- [ >r f lazy-load r> second set ] 2each ;
-
-: stack>vregs ( phantom template -- values )
- [
- [ first ] map alloc-regs
- dup length rot phantom-locs
- [ stack>vreg ] 2map
- ] 2keep length neg swap adjust-phantom ;
-
-: compatible-values? ( value template -- ? )
- {
- { [ over loc? ] [ 2drop t ] }
- { [ dup not ] [ 2drop t ] }
- { [ over not ] [ 2drop f ] }
- { [ dup integer? ] [ swap vreg-n = ] }
- } cond ;
-
-: template-match? ( template phantom -- ? )
- [ reverse-slice ] 2apply
- t [ swap first compatible-values? and ] 2reduce ;
-
-: split-template ( template phantom -- slow fast )
- over length over length <=
- [ drop { } swap ] [ length swap cut* ] if ;
-
-: match-template ( template -- slow fast )
- phantom-d get 2dup template-match?
- [ split-template ] [ drop { } ] if ;
-
-: fast-input ( template -- )
- phantom-d get
- over length neg over adjust-phantom
- over length swap cut-phantom
- swap phantom-vregs ;
-
-: phantom-append ( seq stack -- )
- over length over adjust-phantom swap nappend ;
-
-: (template-outputs) ( seq stack -- )
- phantoms swapd phantom-append phantom-append ;
-
-SYMBOL: +input
-SYMBOL: +output
-SYMBOL: +scratch
-SYMBOL: +clobber
-
-: fix-spec ( spec -- spec )
- H{
- { +input { } }
- { +output { } }
- { +scratch { } }
- { +clobber { } }
- } swap hash-union ;
-
-: adjust-free-vregs ( seq -- ) free-vregs [ diff ] change ;
-
-: output-vregs ( -- seq seq )
- +output +clobber [ get [ get ] map ] 2apply ;
-
-: outputs-clash? ( -- ? )
- output-vregs append phantoms append
- [ swap member? ] contains-with? ;
-
-: slow-input ( template -- )
- dup empty? [ finalize-contents ] unless
- outputs-clash? [ finalize-contents ] when
- phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
-
-: input-vregs ( -- seq )
- +input +scratch [ get [ second get vreg-n ] map ] 2apply
- append ;
-
-: template-inputs ( -- )
- +input get dup { } additional-vregs# ensure-vregs
- match-template fast-input
- used-vregs adjust-free-vregs
- slow-input
- input-vregs adjust-free-vregs ;
-
-: template-outputs ( -- )
- +output get [ get ] map { } (template-outputs) ;
-
-: with-template ( quot spec -- )
- fix-spec [ template-inputs call template-outputs ] bind
- compute-free-vregs ; inline
-
-: operand ( var -- op ) get v>operand ; inline
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: assembler errors generic hashtables kernel
-kernel-internals lists math namespaces prettyprint sequences
-strings vectors words ;
-
-: <label> ( -- label )
- #! Make a label.
- gensym dup t "label" set-word-prop ;
-
-: label? ( obj -- ? )
- dup word? [ "label" word-prop ] [ drop f ] if ;
-
-! We use a hashtable "compiled-xts" that maps words to
-! xt's that are currently being compiled. The commit-xt's word
-! sets the xt of each word in the hashtable to the value in the
-! hastable.
-SYMBOL: compiled-xts
-
-: save-xt ( word -- )
- compiled-offset swap compiled-xts get set-hash ;
-
-: commit-xts ( -- )
- #! We must flush the instruction cache on PowerPC.
- flush-icache
- compiled-xts get [ swap set-word-xt ] hash-each ;
-
-: compiled-xt ( word -- xt )
- dup compiled-xts get hash [ ] [ word-xt ] ?if ;
-
-! deferred-xts is a vector of objects responding to the fixup
-! generic.
-SYMBOL: deferred-xts
-
-: deferred-xt deferred-xts get push ;
-
-! To support saving compiled code to disk, generator words
-! append relocation instructions to this vector.
-SYMBOL: relocation-table
-
-: rel, ( n -- ) relocation-table get push ;
-
-: cell-just-compiled compiled-offset cell - ;
-
-: 4-just-compiled compiled-offset 4 - ;
-
-: rel-absolute-cell 0 ;
-: rel-absolute 1 ;
-: rel-relative 2 ;
-: rel-2/2 3 ;
-
-: rel-type, ( arg class type -- )
- #! Write a relocation instruction for the runtime image
- #! loader.
- over >r >r >r 16 shift r> 8 shift bitor r> bitor rel,
- compiled-offset r> rel-absolute-cell = cell 4 ? - rel, ;
-
-: rel-dlsym ( name dll class -- )
- >r cons add-literal compiled-base - cell / r>
- 1 rel-type, ;
-
-: rel-address ( class -- )
- #! Relocate address just compiled.
- dup rel-relative = [ drop ] [ 0 swap 2 rel-type, ] if ;
-
-: rel-word ( word class -- )
- over primitive? [
- >r word-primitive r> 0 rel-type,
- ] [
- rel-address drop
- ] if ;
-
-: rel-userenv ( n class -- ) 3 rel-type, ;
-
-: rel-cards ( class -- ) 0 swap 4 rel-type, ;
-
-! This is for fixing up forward references
-GENERIC: resolve ( fixup -- addr )
-
-TUPLE: absolute word ;
-
-M: absolute resolve absolute-word compiled-xt ;
-
-TUPLE: relative word to ;
-
-M: relative resolve
- [ relative-word compiled-xt ] keep relative-to - ;
-
-GENERIC: fixup ( addr fixup -- )
-
-TUPLE: fixup-cell at ;
-
-C: fixup-cell ( resolver at -- fixup )
- [ set-fixup-cell-at ] keep [ set-delegate ] keep ;
-
-M: fixup-cell fixup ( addr fixup -- )
- fixup-cell-at set-compiled-cell ;
-
-TUPLE: fixup-4 at ;
-
-C: fixup-4 ( resolver at -- fixup )
- [ set-fixup-4-at ] keep [ set-delegate ] keep ;
-
-M: fixup-4 fixup ( addr fixup -- )
- fixup-4-at set-compiled-4 ;
-
-TUPLE: fixup-bitfield at mask ;
-
-C: fixup-bitfield ( resolver at mask -- fixup )
- [ set-fixup-bitfield-mask ] keep
- [ set-fixup-bitfield-at ] keep
- [ set-delegate ] keep ;
-
-: <fixup-3> ( resolver at -- )
- #! Only for PowerPC branch instructions.
- BIN: 11111111111111111111111100 <fixup-bitfield> ;
-
-: <fixup-2> ( resolver at -- )
- #! Only for PowerPC conditional branch instructions.
- BIN: 1111111111111100 <fixup-bitfield> ;
-
-: or-compiled ( n off -- )
- [ compiled-cell bitor ] keep set-compiled-cell ;
-
-M: fixup-bitfield fixup ( addr fixup -- )
- [ fixup-bitfield-mask bitand ] keep
- fixup-bitfield-at or-compiled ;
-
-TUPLE: fixup-2/2 at ;
-
-C: fixup-2/2 ( resolver at -- fixup )
- [ set-fixup-2/2-at ] keep [ set-delegate ] keep ;
-
-M: fixup-2/2 fixup ( addr fixup -- )
- fixup-2/2-at >r w>h/h r> tuck 4 - or-compiled or-compiled ;
-
-: relative-4 ( word -- )
- dup rel-relative rel-word
- compiled-offset <relative>
- 4-just-compiled <fixup-4> deferred-xt ;
-
-: relative-3 ( word -- )
- #! Labels only -- no image relocation information saved
- 4-just-compiled <relative>
- 4-just-compiled <fixup-3> deferred-xt ;
-
-: relative-2 ( word -- )
- #! Labels only -- no image relocation information saved
- 4-just-compiled <relative>
- 4-just-compiled <fixup-2> deferred-xt ;
-
-: relative-2/2 ( word -- )
- #! Labels only -- no image relocation information saved
- compiled-offset <relative>
- 4-just-compiled <fixup-2/2> deferred-xt ;
-
-: absolute-4 ( word -- )
- dup rel-absolute rel-word
- <absolute> 4-just-compiled <fixup-4> deferred-xt ;
-
-: absolute-2/2 ( word -- )
- dup rel-2/2 rel-word
- <absolute> cell-just-compiled <fixup-2/2> deferred-xt ;
-
-: absolute-cell ( word -- )
- dup rel-absolute-cell rel-word
- <absolute> cell-just-compiled <fixup-cell> deferred-xt ;
-
-! When a word is encountered that has not been previously
-! compiled, it is pushed onto this vector. Compilation stops
-! when the vector is empty.
-SYMBOL: compile-words
-
-: compiling? ( word -- ? )
- #! A word that is compiling or already compiled will not be
- #! added to the list of words to be compiled.
- dup compiled?
- over label? or
- over compile-words get member? or
- swap compiled-xts get hash or ;
-
-: fixup-xts ( -- )
- deferred-xts get [ dup resolve swap fixup ] each ;
-
-: with-compiler ( quot -- )
- [
- V{ } clone deferred-xts set
- H{ } clone compiled-xts set
- V{ } clone compile-words set
- call
- fixup-xts
- commit-xts
- ] with-scope ;
-
-: postpone-word ( word -- )
- dup compiling? not over compound? and
- [ dup compile-words get push ] when drop ;
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: inference
-USING: arrays errors generic hashtables interpreter kernel math
-namespaces parser prettyprint sequences strings vectors words ;
-
-: unify-lengths ( seq -- seq )
- #! Pad all vectors to the same length. If one vector is
- #! shorter, pad it with unknown results at the bottom.
- dup 0 [ length max ] reduce swap [ add-inputs ] map-with ;
-
-: unify-values ( seq -- value )
- #! If all values in list are equal, return the value.
- #! Otherwise, unify.
- dup all-eq? [ first ] [ drop <computed> ] if ;
-
-: unify-stacks ( seq -- stack )
- #! Replace differing literals in stacks with unknown
- #! results.
- [ ] subset dup empty?
- [ drop f ] [ unify-lengths flip [ unify-values ] map ] if ;
-
-: balanced? ( in out -- ? )
- [ dup [ length - ] [ 2drop f ] if ] 2map
- [ ] subset all-equal? ;
-
-: unify-in-d ( seq -- n )
- #! Input is a sequence of positive integers or f.
- #! Output is the maximum or 0.
- 0 [ [ max ] when* ] reduce ;
-
-: unbalanced-branches ( in out -- )
- { "Unbalanced branches:" } -rot [
- swap unparse " " rot length unparse append3
- ] 2map append "\n" join inference-error ;
-
-: unify-effect ( in out -- in out )
- #! In is a sequence of integers; out is a sequence of stacks.
- 2dup balanced? [
- unify-stacks >r unify-in-d r>
- ] [
- unbalanced-branches
- ] if ;
-
-: active-variable ( seq symbol -- seq )
- swap [
- terminated? over hash [ 2drop f ] [ hash ] if
- ] map-with ;
-
-: datastack-effect ( seq -- )
- dup d-in active-variable
- swap meta-d active-variable
- unify-effect meta-d set d-in set ;
-
-: callstack-effect ( seq -- )
- dup length 0 <array>
- swap meta-r active-variable
- unify-effect meta-r set drop ;
-
-: unify-effects ( seq -- )
- dup datastack-effect dup callstack-effect
- [ terminated? swap hash ] all? terminated? set ;
-
-: unify-dataflow ( effects -- nodes )
- [ [ dataflow-graph get ] bind ] map ;
-
-: copy-inference ( -- )
- meta-r [ clone ] change
- meta-d [ clone ] change
- d-in [ ] change
- dataflow-graph off
- current-node off ;
-
-: infer-branch ( value -- namespace )
- #! Return a namespace with inferencer variables:
- #! meta-d, meta-r, d-in. They are set to f if
- #! terminate was called.
- [
- [
- base-case-continuation set
- copy-inference
- dup value-recursion recursive-state set
- dup value-literal infer-quot
- terminated? get [ #values node, ] unless
- f
- ] callcc1 [ terminate ] when drop
- ] make-hash ;
-
-: (infer-branches) ( branchlist -- list )
- [ infer-branch ] map dup unify-effects unify-dataflow ;
-
-: infer-branches ( branches node -- )
- #! Recursive stack effect inference is done here. If one of
- #! the branches has an undecidable stack effect, we set the
- #! base case to this stack effect and try again.
- [ >r (infer-branches) r> set-node-children ] keep
- node, #merge node, ;
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: optimizer
-USING: arrays errors generic hashtables inference kernel lists
-math math-internals sequences words ;
-
-! A system for associating dataflow optimizers with words.
-
-: optimizer-hooks ( node -- conditions )
- node-param "optimizer-hooks" word-prop ;
-
-: optimize-hooks ( node -- node/t )
- dup optimizer-hooks cond ;
-
-: define-optimizers ( word optimizers -- )
- { [ t ] [ drop t ] } add "optimizer-hooks" set-word-prop ;
-
-: partial-eval? ( #call -- ? )
- dup node-param "foldable" word-prop [
- dup node-in-d [
- dup value?
- [ 2drop t ] [ swap node-literals ?hash* nip ] if
- ] all-with?
- ] [
- drop f
- ] if ;
-
-: literal-in-d ( #call -- inputs )
- dup node-in-d [
- dup value?
- [ nip value-literal ] [ swap node-literals ?hash ] if
- ] map-with ;
-
-: partial-eval ( #call -- node )
- dup literal-in-d over node-param
- [ with-datastack ] catch
- [ 3drop t ] [ inline-literals ] if ;
-
-: flip-subst ( not -- )
- #! Note: cloning the vectors, since subst-values will modify
- #! them.
- [ node-in-d clone ] keep
- [ node-out-d clone ] keep
- subst-values ;
-
-: flip-branches ( not -- #if )
- #! If a not is followed by an #if, flip branches and
- #! remove the not.
- dup flip-subst node-successor dup
- dup node-children reverse swap set-node-children ;
-
-\ not {
- { [ dup node-successor #if? ] [ flip-branches ] }
-} define-optimizers
-
-: disjoint-eq? ( node -- ? )
- dup node-classes swap node-in-d
- [ swap ?hash ] map-with
- first2 2dup and [ classes-intersect? not ] [ 2drop f ] if ;
-
-\ eq? {
- { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
-} define-optimizers
-
-! Arithmetic identities
-SYMBOL: @
-
-: define-identities ( words identities -- )
- swap [ swap "identities" set-word-prop ] each-with ;
-
-: literals-match? ( values template -- ? )
- [
- over value? [ >r value-literal r> ] [ nip @ ] if =
- ] 2map [ ] all? ;
-
-: values-match? ( values template -- ? )
- [ @ = [ drop f ] unless ] 2map [ ] subset all-eq? ;
-
-: apply-identity? ( values identity -- ? )
- first 2dup literals-match? >r values-match? r> and ;
-
-: find-identity ( node -- values identity )
- dup node-in-d swap node-param "identities" word-prop
- [ dupd apply-identity? ] find nip ;
-
-: apply-identities ( node -- node/f )
- dup find-identity dup [
- second swap dataflow-with [ subst-node ] keep
- ] [
- 3drop f
- ] if ;
-
-[ + fixnum+ bignum+ float+ ] {
- { { @ 0 } [ drop ] }
- { { 0 @ } [ nip ] }
-} define-identities
-
-[ - fixnum- bignum- float- ] {
- { { @ 0 } [ drop ] }
- { { @ @ } [ 2drop 0 ] }
-} define-identities
-
-[ * fixnum* bignum* float* ] {
- { { @ 1 } [ drop ] }
- { { 1 @ } [ nip ] }
- { { @ 0 } [ nip ] }
- { { 0 @ } [ drop ] }
- { { @ -1 } [ drop 0 swap - ] }
- { { -1 @ } [ nip 0 swap - ] }
-} define-identities
-
-[ / /i /f fixnum/i fixnum/f bignum/i bignum/f float/f ] {
- { { @ 1 } [ drop ] }
- { { @ -1 } [ drop 0 swap - ] }
-} define-identities
-
-[ fixnum-mod bignum-mod ] {
- { { @ 1 } [ 2drop 0 ] }
-} define-identities
-
-[ bitand fixnum-bitand bignum-bitand ] {
- { { @ -1 } [ drop ] }
- { { -1 @ } [ nip ] }
- { { @ @ } [ drop ] }
- { { @ 0 } [ nip ] }
- { { 0 @ } [ drop ] }
-} define-identities
-
-[ bitor fixnum-bitor bignum-bitor ] {
- { { @ 0 } [ drop ] }
- { { 0 @ } [ nip ] }
- { { @ @ } [ drop ] }
- { { @ -1 } [ nip ] }
- { { -1 @ } [ drop ] }
-} define-identities
-
-[ bitxor fixnum-bitxor bignum-bitxor ] {
- { { @ 0 } [ drop ] }
- { { 0 @ } [ nip ] }
- { { @ -1 } [ drop bitnot ] }
- { { -1 @ } [ nip bitnot ] }
- { { @ @ } [ 2drop 0 ] }
-} define-identities
-
-[ shift fixnum-shift bignum-shift ] {
- { { 0 @ } [ drop ] }
- { { @ 0 } [ drop ] }
-} define-identities
-
-[ < fixnum< bignum< float< ] {
- { { @ @ } [ 2drop f ] }
-} define-identities
-
-[ <= fixnum<= bignum<= float<= ] {
- { { @ @ } [ 2drop t ] }
-} define-identities
-
-[ > fixnum> bignum> float>= ] {
- { { @ @ } [ 2drop f ] }
-} define-identities
-
-[ >= fixnum>= bignum>= float>= ] {
- { { @ @ } [ 2drop t ] }
-} define-identities
-
-[ eq? number= = ] {
- { { @ @ } [ 2drop t ] }
-} define-identities
-
-M: #call optimize-node* ( node -- node/t )
- {
- { [ dup partial-eval? ] [ partial-eval ] }
- { [ dup find-identity nip ] [ apply-identities ] }
- { [ dup optimizer-hooks ] [ optimize-hooks ] }
- { [ dup inlining-class ] [ inline-method ] }
- { [ dup optimize-predicate? ] [ optimize-predicate ] }
- { [ t ] [ drop t ] }
- } cond ;
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: optimizer
-USING: arrays generic hashtables inference kernel
-kernel-internals math namespaces sequences words ;
-
-! Infer possible classes of values in a dataflow IR.
-
-! Variables used by the class inferencer
-
-! Current value --> class mapping
-SYMBOL: value-classes
-
-! Current value --> literal mapping
-SYMBOL: value-literals
-
-! Maps ties to ties
-SYMBOL: ties
-
-GENERIC: apply-tie ( tie -- )
-
-M: f apply-tie ( f -- ) drop ;
-
-TUPLE: class-tie value class ;
-
-: set-value-class* ( class value -- )
- 2dup swap <class-tie> ties get hash [ apply-tie ] when*
- value-classes get set-hash ;
-
-M: class-tie apply-tie ( tie -- )
- dup class-tie-class swap class-tie-value
- set-value-class* ;
-
-TUPLE: literal-tie value literal ;
-
-: set-value-literal* ( literal value -- )
- over class over set-value-class*
- 2dup swap <literal-tie> ties get hash [ apply-tie ] when*
- value-literals get set-hash ;
-
-M: literal-tie apply-tie ( tie -- )
- dup literal-tie-literal swap literal-tie-value
- set-value-literal* ;
-
-GENERIC: infer-classes* ( node -- )
-
-M: node infer-classes* ( node -- ) drop ;
-
-! For conditionals, a map of child node # --> possibility
-GENERIC: child-ties ( node -- seq )
-
-M: node child-ties ( node -- seq )
- node-children length f <array> ;
-
-: value-class* ( value -- class )
- value-classes get hash [ object ] unless* ;
-
-: value-literal* ( value -- class )
- value-literals get hash ;
-
-: annotate-node ( node -- )
- #! Annotate the node with the currently-inferred set of
- #! value classes.
- dup node-values
- [ dup value-class* ] map>hash swap set-node-classes ;
-
-: intersect-classes ( classes values -- )
- [
- [ value-class* class-and ] keep set-value-class*
- ] 2each ;
-
-: set-tie ( tie tie -- ) ties get set-hash ;
-
-: type/tag-ties ( node n -- )
- over node-out-d first over [ <literal-tie> ] map-with
- >r swap node-in-d first swap [ type>class <class-tie> ] map-with r>
- [ set-tie ] 2each ;
-
-\ type [ num-types type/tag-ties ] "create-ties" set-word-prop
-
-\ tag [ num-tags type/tag-ties ] "create-ties" set-word-prop
-
-\ eq? [
- dup node-in-d second value? [
- dup node-in-d first2 value-literal* <literal-tie>
- over node-out-d first general-t <class-tie>
- set-tie
- ] when drop
-] "create-ties" set-word-prop
-
-: create-ties ( #call -- )
- #! If the node is calling a class test predicate, create a
- #! tie.
- dup node-param "create-ties" word-prop dup [
- call
- ] [
- drop dup node-param "predicating" word-prop dup [
- >r dup node-in-d first r> <class-tie>
- swap node-out-d first general-t <class-tie>
- set-tie
- ] [
- 2drop
- ] if
- ] if ;
-
-\ make-tuple [
- dup node-in-d first value-literal 1array
-] "output-classes" set-word-prop
-
-: output-classes ( node -- seq )
- dup node-param "output-classes" word-prop [
- call
- ] [
- node-param "infer-effect" word-prop second
- dup integer? [ drop f ] when
- ] ?if ;
-
-M: #call infer-classes* ( node -- )
- dup node-param [
- dup create-ties
- dup output-classes
- [ over node-out-d intersect-classes ] when*
- ] when drop ;
-
-M: #push infer-classes* ( node -- )
- node-out-d
- [ [ value-literal ] keep set-value-literal* ] each ;
-
-M: #if child-ties ( node -- seq )
- node-in-d first dup general-t <class-tie>
- swap f <literal-tie> 2array ;
-
-M: #dispatch child-ties ( node -- seq )
- dup node-in-d first
- swap node-children length [ <literal-tie> ] map-with ;
-
-DEFER: (infer-classes)
-
-: infer-children ( node -- )
- dup node-children swap child-ties [
- [
- value-classes [ clone ] change
- ties [ clone ] change
- apply-tie
- (infer-classes)
- ] with-scope
- ] 2each ;
-
-: (infer-classes) ( node -- )
- [
- dup infer-classes*
- dup annotate-node
- dup infer-children
- node-successor (infer-classes)
- ] when* ;
-
-: infer-classes ( node -- )
- [
- H{ } clone value-classes set
- H{ } clone value-literals set
- H{ } clone ties set
- (infer-classes)
- ] with-scope ;
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: inference
-USING: arrays generic hashtables interpreter kernel lists math
-namespaces parser sequences words ;
-
-! The dataflow IR is the first of the two intermediate
-! representations used by Factor. It annotates concatenative
-! code with stack flow information and types.
-
-TUPLE: node param shuffle
- classes literals history
- successor children ;
-
-M: node = eq? ;
-
-: make-node ( param in-d out-d in-r out-r node -- node )
- [ >r swapd <shuffle> f f f f f <node> r> set-delegate ] keep ;
-
-: node-in-d node-shuffle shuffle-in-d ;
-: node-in-r node-shuffle shuffle-in-r ;
-: node-out-d node-shuffle shuffle-out-d ;
-: node-out-r node-shuffle shuffle-out-r ;
-
-: set-node-in-d node-shuffle set-shuffle-in-d ;
-: set-node-in-r node-shuffle set-shuffle-in-r ;
-: set-node-out-d node-shuffle set-shuffle-out-d ;
-: set-node-out-r node-shuffle set-shuffle-out-r ;
-
-: empty-node f { } { } { } { } ;
-: param-node ( label) { } { } { } { } ;
-: in-node ( inputs) >r f r> { } { } { } ;
-: out-node ( outputs) >r f { } r> { } { } ;
-
-: d-tail ( n -- list ) meta-d get tail* ;
-: r-tail ( n -- list ) meta-r get tail* ;
-
-: node-child node-children first ;
-
-TUPLE: #label ;
-C: #label make-node ;
-: #label ( label -- node ) param-node <#label> ;
-
-TUPLE: #entry ;
-C: #entry make-node ;
-: #entry ( -- node ) meta-d get clone in-node <#entry> ;
-
-TUPLE: #call ;
-C: #call make-node ;
-: #call ( word -- node ) param-node <#call> ;
-
-TUPLE: #call-label ;
-C: #call-label make-node ;
-: #call-label ( label -- node ) param-node <#call-label> ;
-
-TUPLE: #push ;
-C: #push make-node ;
-: #push ( outputs -- node ) d-tail out-node <#push> ;
-: >#push< ( node -- seq ) node-out-d [ value-literal ] map ;
-
-TUPLE: #shuffle ;
-C: #shuffle make-node ;
-: #shuffle ( -- node ) empty-node <#shuffle> ;
-
-TUPLE: #values ;
-C: #values make-node ;
-: #values ( -- node ) meta-d get clone in-node <#values> ;
-
-TUPLE: #return ;
-C: #return make-node ;
-: #return ( label -- node )
- #! The parameter is the label we are returning from, or if
- #! f, this is a top-level return.
- meta-d get clone in-node <#return>
- [ set-node-param ] keep ;
-
-TUPLE: #if ;
-C: #if make-node ;
-: #if ( in -- node ) 1 d-tail in-node <#if> ;
-
-TUPLE: #dispatch ;
-C: #dispatch make-node ;
-: #dispatch ( in -- node ) 1 d-tail in-node <#dispatch> ;
-
-TUPLE: #merge ;
-C: #merge make-node ;
-: #merge ( -- node ) meta-d get clone out-node <#merge> ;
-
-TUPLE: #terminate ;
-C: #terminate make-node ;
-: #terminate ( -- node ) empty-node <#terminate> ;
-
-: node-inputs ( d-count r-count node -- )
- tuck
- >r r-tail r> set-node-in-r
- >r d-tail r> set-node-in-d ;
-
-: node-outputs ( d-count r-count node -- )
- tuck
- >r r-tail r> set-node-out-r
- >r d-tail r> set-node-out-d ;
-
-! Variable holding dataflow graph being built.
-SYMBOL: dataflow-graph
-! The most recently added node.
-SYMBOL: current-node
-
-: node, ( node -- )
- dataflow-graph get [
- dup current-node [ set-node-successor ] change
- ] [
- ! first node
- dup dataflow-graph set current-node set
- ] if ;
-
-: node-values ( node -- values )
- [
- dup node-in-d % dup node-out-d %
- dup node-in-r % node-out-r %
- ] { } make ;
-
-: uses-value? ( value node -- ? ) node-values memq? ;
-
-: outputs-value? ( value node -- ? )
- 2dup node-out-d member? >r node-out-r member? r> or ;
-
-: last-node ( node -- last )
- dup node-successor [ last-node ] [ ] ?if ;
-
-: penultimate-node ( node -- penultimate )
- dup node-successor dup [
- dup node-successor
- [ nip penultimate-node ] [ drop ] if
- ] [
- 2drop f
- ] if ;
-
-: drop-inputs ( node -- #shuffle )
- node-in-d clone in-node <#shuffle> ;
-
-: #drop ( n -- #shuffle )
- d-tail in-node <#shuffle> ;
-
-: each-node ( node quot -- | quot: node -- )
- over [
- [ call ] 2keep swap
- [ node-children [ swap each-node ] each-with ] 2keep
- node-successor swap each-node
- ] [
- 2drop
- ] if ; inline
-
-: each-node-with ( obj node quot -- | quot: obj node -- )
- swap [ with ] each-node 2drop ; inline
-
-: all-nodes? ( node quot -- ? | quot: node -- ? )
- over [
- [ call ] 2keep rot [
- [
- swap node-children [ swap all-nodes? ] all-with?
- ] 2keep rot [
- >r node-successor r> all-nodes?
- ] [
- 2drop f
- ] if
- ] [
- 2drop f
- ] if
- ] [
- 2drop t
- ] if ; inline
-
-: all-nodes-with? ( obj node quot -- ? | quot: obj node -- ? )
- swap [ with rot ] all-nodes? 2nip ; inline
-
-: remember-node ( word node -- )
- #! Annotate each node with the fact it was inlined from
- #! 'word'.
- [
- dup #call?
- [ [ node-history ?push ] keep set-node-history ]
- [ 2drop ] if
- ] each-node-with ;
-
-GENERIC: calls-label* ( label node -- ? )
-
-M: node calls-label* 2drop f ;
-
-M: #call-label calls-label* node-param eq? ;
-
-: calls-label? ( label node -- ? )
- [ calls-label* not ] all-nodes-with? not ;
-
-: recursive-label? ( node -- ? )
- dup node-param swap calls-label? ;
-
-SYMBOL: node-stack
-
-: >node node-stack get push ;
-: node> node-stack get pop ;
-: node@ node-stack get peek ;
-
-DEFER: iterate-nodes
-
-: iterate-children ( quot -- )
- node@ node-children [ swap iterate-nodes ] each-with ;
- inline
-
-: iterate-next ( -- node ) node@ node-successor ;
-
-: iterate-nodes ( node quot -- )
- over [
- [ swap >node call node> drop ] keep
- over [ iterate-nodes ] [ 2drop ] if
- ] [
- 2drop
- ] if ; inline
-
-: ?set-node-successor ( next prev -- )
- [ set-node-successor ] [ drop ] if* ;
-
-: map-node ( prev quot -- )
- swap >r node@ swap call dup r> ?set-node-successor
- node> drop >node ; inline
-
-DEFER: map-children
-DEFER: (map-nodes)
-
-: map-next ( quot -- )
- node@ [
- swap [ map-children ] keep
- node> node-successor >node (map-nodes)
- ] [
- drop
- ] if* ; inline
-
-: (map-nodes) ( prev quot -- | quot: node -- node )
- node@
- [ [ map-node ] keep map-next ]
- [ drop f swap ?set-node-successor ] if ; inline
-
-: map-first ( node quot -- node | quot: node -- node )
- call node> drop dup >node ; inline
-
-: map-nodes ( node quot -- node | quot: node -- node )
- over [
- over >node [ map-first ] keep map-next node>
- ] when drop ; inline
-
-: map-children ( quot -- | quot: node -- node )
- node@ [ node-children [ swap map-nodes ] map-with ] keep
- set-node-children ; inline
-
-: with-node-iterator ( quot -- )
- [ V{ } clone node-stack set call ] with-scope ; inline
-
-: (subst-values) ( new old node -- )
- [
- [ node-in-d subst ] 3keep [ node-in-r subst ] 3keep
- [ node-out-d subst ] 3keep [ node-out-r subst ] 3keep
- drop
- ] each-node 2drop ;
-
-: subst-values ( new old node -- )
- #! Mutates nodes.
- 1 node-stack get head* swap add
- [ >r 2dup r> node-successor (subst-values) ] each 2drop ;
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: inference
-USING: arrays errors generic inspector interpreter io kernel
-lists math namespaces parser prettyprint sequences strings
-vectors words ;
-
-! This variable takes a boolean value.
-SYMBOL: inferring-base-case
-
-! Called when a recursive call during base case inference is
-! found. Either tries to infer another branch, or gives up.
-SYMBOL: base-case-continuation
-
-TUPLE: inference-error message rstate data-stack call-stack ;
-
-: inference-error ( msg -- )
- recursive-state get meta-d get meta-r get
- <inference-error> throw ;
-
-M: inference-error error. ( error -- )
- "Inference error:" print
- dup inference-error-message print
- "Recursive state:" print
- inference-error-rstate describe ;
-
-M: object value-literal ( value -- )
- {
- "A literal value was expected where a computed value was found.\n"
- "This means the word you are inferring applies 'call' or 'execute'\n"
- "to a value that is not known at compile time.\n"
- "See the handbook for details."
- } concat inference-error ;
-
-! Word properties that affect inference:
-! - infer-effect -- must be set. controls number of inputs
-! expected, and number of outputs produced.
-! - infer - quotation with custom inference behavior; if uses
-! this. Word is passed on the stack.
-
-! Vector of results we had to add to the datastack. Ie, the
-! inputs.
-SYMBOL: d-in
-
-: pop-literal ( -- rstate obj )
- 1 #drop node,
- pop-d dup value-recursion swap value-literal ;
-
-: value-vector ( n -- vector ) [ drop <computed> ] map >vector ;
-
-: add-inputs ( n stack -- stack )
- tuck length - dup 0 >
- [ value-vector swap append ] [ drop ] if ;
-
-: ensure-values ( n -- )
- dup meta-d get length - 0 max d-in [ + ] change
- meta-d [ add-inputs ] change ;
-
-: effect ( -- { in# out# } )
- #! After inference is finished, collect information.
- d-in get meta-d get length 2array ;
-
-SYMBOL: terminated?
-
-: init-inference ( recursive-state -- )
- terminated? off
- V{ } clone meta-r set
- V{ } clone meta-d set
- 0 d-in set
- recursive-state set
- dataflow-graph off
- current-node off ;
-
-GENERIC: apply-object
-
-: apply-literal ( obj -- )
- #! Literals are annotated with the current recursive
- #! state.
- <value> push-d 1 #push node, ;
-
-M: object apply-object apply-literal ;
-
-M: wrapper apply-object wrapped apply-literal ;
-
-: terminate ( -- )
- #! Ignore this branch's stack effect.
- terminated? on #terminate node, ;
-
-GENERIC: infer-quot
-
-M: general-list infer-quot ( quot -- )
- #! Recursive calls to this word are made for nested
- #! quotations.
- [ terminated? get [ drop f ] [ apply-object t ] if ] all? drop ;
-
-: infer-quot-value ( rstate quot -- )
- recursive-state get >r swap recursive-state set
- infer-quot r> recursive-state set ;
-
-: check-return ( -- )
- #! Raise an error if word leaves values on return stack.
- meta-r get empty? [
- "Word leaves " meta-r get length number>string
- " element(s) on return stack. Check >r/r> usage." append3
- inference-error
- ] unless ;
-
-: with-infer ( quot -- )
- [
- inferring-base-case off
- base-case-continuation off
- f init-inference
- call
- check-return
- ] with-scope ;
-
-: infer ( quot -- effect )
- #! Stack effect of a quotation.
- [ infer-quot effect ] with-infer ;
-
-: (dataflow) ( quot -- dataflow )
- infer-quot f #return node, dataflow-graph get ;
-
-: dataflow ( quot -- dataflow )
- #! Data flow of a quotation.
- [ (dataflow) ] with-infer ;
-
-: dataflow-with ( quot stack -- effect )
- #! Infer starting from a stack of values.
- [ meta-d set (dataflow) ] with-infer ;
+++ /dev/null
-IN: inference
-USING: help ;
-
-HELP: infer "( quot -- effect )"
-{ $values { "quot" "a quotation" } { "effect" "a pair of integers" } }
-{ $description "Attempts to infer the quotation's stack effect, outputting a pair holding the correct of data stack inputs and outputs for the quotation." }
-{ $errors "Throws an error if stack effect inference fails. See " { $link "inference" } "." } ;
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: optimizer
-USING: arrays generic hashtables inference kernel lists math
-namespaces sequences words ;
-
-! Method inlining optimization
-
-GENERIC: dispatching-values ( node word -- seq )
-
-M: object dispatching-values 2drop { } ;
-
-M: standard-generic dispatching-values
- "combination" word-prop first swap
- node-in-d reverse-slice nth 1array ;
-
-M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
-
-: node-classes* ( node seq -- seq )
- >r node-classes r>
- [ swap ?hash [ object ] unless* ] map-with ;
-
-: dispatching-classes ( node -- seq )
- dup node-in-d empty? [
- drop { }
- ] [
- dup dup node-param dispatching-values node-classes*
- ] if ;
-
-: already-inlined? ( node -- ? )
- #! Was this node inlined from definition of 'word'?
- dup node-param swap node-history memq? ;
-
-: inlining-class ( #call -- class )
- #! If the generic dispatch can be eliminated, return the
- #! class of the method that will always be invoked here.
- dup already-inlined? [
- drop f
- ] [
- dup dispatching-classes dup empty? [
- 2drop f
- ] [
- dup all-eq? [
- first swap node-param order min-class
- ] [
- 2drop f
- ] if
- ] if
- ] if ;
-
-: will-inline ( node -- quot )
- dup inlining-class swap node-param "methods" word-prop hash ;
-
-: method-dataflow ( node -- dataflow )
- dup will-inline swap node-in-d dataflow-with ;
-
-: post-inline ( #return/#values #call/#merge -- )
- dup [
- [
- >r node-in-d r> node-out-d
- 2array unify-lengths first2
- ] keep subst-values
- ] [
- 2drop
- ] if ;
-
-: subst-node ( old new -- )
- #! The last node of 'new' becomes 'old', then values are
- #! substituted. A subsequent optimizer phase kills the
- #! last node of 'new' and the first node of 'old'.
- last-node 2dup swap post-inline set-node-successor ;
-
-: inline-method ( node -- node )
- #! We set the #call node's param to f so that it gets killed
- #! later.
- dup method-dataflow
- [ >r node-param r> remember-node ] 2keep
- [ subst-node ] keep ;
-
-: related? ( actual testing -- ? )
- #! If actual is a subset of testing or if the two classes
- #! are disjoint, return t.
- 2dup class< >r classes-intersect? not r> or ;
-
-: optimize-predicate? ( #call -- ? )
- dup node-param "predicating" word-prop dup [
- >r dup node-in-d node-classes* first r> related?
- ] [
- 2drop f
- ] if ;
-
-: inline-literals ( node literals -- node )
- #! Make #push -> #return -> successor
- over drop-inputs [
- >r >list [ literalize ] map dataflow [ subst-node ] keep
- r> set-node-successor
- ] keep ;
-
-: optimize-predicate ( #call -- node )
- dup node-param "predicating" word-prop >r
- dup dup node-in-d node-classes* first r> class<
- 1array inline-literals ;
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: optimizer
-USING: arrays generic hashtables inference kernel math
-namespaces sequences words ;
-
-: node-union ( node quot -- hash | quot: node -- )
- [
- swap [ swap call [ dup set ] each ] each-node-with
- ] make-hash ; inline
-
-GENERIC: literals* ( node -- seq )
-
-: literals ( node -- hash )
- [ literals* ] node-union ;
-
-! GENERIC: flushable-values* ( node -- seq )
-!
-! : flushable-values ( node -- hash )
-! [ flushable-values* ] node-union ;
-
-GENERIC: live-values* ( node -- seq )
-
-: live-values ( node -- hash )
- #! All values that are returned or passed to calls.
- [ live-values* ] node-union ;
-
-: kill-node* ( values node -- )
- 2dup [ node-in-d remove-all ] keep set-node-in-d
- 2dup [ node-out-d remove-all ] keep set-node-out-d
- 2dup [ node-in-r remove-all ] keep set-node-in-r
- [ node-out-r remove-all ] keep set-node-out-r ;
-
-: kill-node ( values node -- )
- over hash-empty?
- [ 2drop ] [ [ kill-node* ] each-node-with ] if ;
-
-: kill-unused-literals ( node -- )
- \ live-values get over literals hash-diff swap kill-node ;
-
-: kill-values ( node -- )
- dup live-values over literals hash-diff swap kill-node ;
-
-! Generic nodes
-M: node literals* ( node -- ) drop { } ;
-
-! M: node flushable-values* ( node -- ) drop { } ;
-
-M: node live-values* ( node -- ) node-values ;
-
-! #shuffle
-M: #shuffle literals* ( node -- seq )
- dup node-out-d swap node-out-r
- [ [ value? ] subset ] 2apply append ;
-
-! #push
-M: #push literals* ( node -- seq )
- node-values ;
-
-! #call
-! M: #call flushable-values* ( node -- )
-! dup node-param "flushable" word-prop
-! [ node-out-d ] [ drop { } ] if ;
-
-! #return
-M: #return live-values* ( node -- seq )
- #! Values returned by local labels can be killed.
- dup node-param [ drop { } ] [ delegate live-values* ] if ;
-
-! nodes that don't use their values directly
-UNION: #killable
- #push #shuffle #call-label #merge #values #entry ;
-
-M: #killable live-values* ( node -- seq ) drop { } ;
-
-: purge-invariants ( stacks -- seq )
- #! Output a sequence of values which are not present in the
- #! same position in each sequence of the stacks sequence.
- unify-lengths flip [ all-eq? not ] subset concat ;
-
-! #label
-M: #label live-values* ( node -- seq )
- dup node-child node-in-d over node-in-d 2array
- swap collect-recursion append purge-invariants ;
-
-! branching
-UNION: #branch #if #dispatch ;
-
-M: #branch live-values* ( node -- )
- #! This assumes that the last element of each branch is a
- #! #return node.
- dup delegate live-values* >r
- node-children [ last-node node-in-d ] map purge-invariants
- r> append ;
+++ /dev/null
-IN: inference
-USING: arrays alien assembler errors generic hashtables
-hashtables-internals interpreter io io-internals kernel
-kernel-internals lists math math-internals memory parser
-sequences strings vectors words prettyprint ;
-
-! We transform calls to these words into 'branched' forms;
-! eg, there is no VOP for fixnum<=, only fixnum<= followed
-! by an #if, so if we have a 'bare' fixnum<= we add
-! [ t ] [ f ] if at the end.
-
-! This transformation really belongs in the optimizer, but it
-! is simpler to do it here.
-\ fixnum< [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
-\ fixnum< t "flushable" set-word-prop
-\ fixnum< t "foldable" set-word-prop
-
-\ fixnum<= [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
-\ fixnum<= t "flushable" set-word-prop
-\ fixnum<= t "foldable" set-word-prop
-
-\ fixnum> [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
-\ fixnum> t "flushable" set-word-prop
-\ fixnum> t "foldable" set-word-prop
-
-\ fixnum>= [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
-\ fixnum>= t "flushable" set-word-prop
-\ fixnum>= t "foldable" set-word-prop
-
-\ eq? [ [ object object ] [ object ] ] "infer-effect" set-word-prop
-\ eq? t "flushable" set-word-prop
-\ eq? t "foldable" set-word-prop
-
-: manual-branch ( word -- )
- dup "infer-effect" word-prop consume/produce
- [ [ t ] [ f ] if ] infer-quot ;
-
-! { fixnum<= fixnum< fixnum>= fixnum> eq? }
-! [ dup [ manual-branch ] curry "infer" set-word-prop ] each
-
-! Primitive combinators
-\ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop
-
-\ call [ pop-literal infer-quot-value ] "infer" set-word-prop
-
-\ execute [ [ word ] [ ] ] "infer-effect" set-word-prop
-
-\ execute [
- pop-literal unit infer-quot-value
-] "infer" set-word-prop
-
-\ if [ [ object general-list general-list ] [ ] ] "infer-effect" set-word-prop
-
-\ if [
- 2 #drop node, pop-d pop-d swap 2array
- #if pop-d drop infer-branches
-] "infer" set-word-prop
-
-\ cond [ [ object ] [ ] ] "infer-effect" set-word-prop
-
-\ cond [
- pop-literal reverse-slice
- [ no-cond ] swap alist>quot infer-quot-value
-] "infer" set-word-prop
-
-\ dispatch [ [ fixnum array ] [ ] ] "infer-effect" set-word-prop
-
-\ dispatch [
- pop-literal nip [ <value> ] map
- #dispatch pop-d drop infer-branches
-] "infer" set-word-prop
-
-! Non-standard control flow
-\ throw [ [ object ] [ ] ] "infer-effect" set-word-prop
-
-\ throw [
- \ throw dup "infer-effect" word-prop consume/produce
- terminate
-] "infer" set-word-prop
-
-! Stack effects for all primitives
-\ cons [ [ object object ] [ cons ] ] "infer-effect" set-word-prop
-\ cons t "foldable" set-word-prop
-\ cons t "flushable" set-word-prop
-
-\ <vector> [ [ integer ] [ vector ] ] "infer-effect" set-word-prop
-\ <vector> t "flushable" set-word-prop
-
-\ rehash-string [ [ string ] [ ] ] "infer-effect" set-word-prop
-
-\ <sbuf> [ [ integer ] [ sbuf ] ] "infer-effect" set-word-prop
-\ <sbuf> t "flushable" set-word-prop
-
-\ >fixnum [ [ number ] [ fixnum ] ] "infer-effect" set-word-prop
-\ >fixnum t "flushable" set-word-prop
-\ >fixnum t "foldable" set-word-prop
-
-\ >bignum [ [ number ] [ bignum ] ] "infer-effect" set-word-prop
-\ >bignum t "flushable" set-word-prop
-\ >bignum t "foldable" set-word-prop
-
-\ >float [ [ number ] [ float ] ] "infer-effect" set-word-prop
-\ >float t "flushable" set-word-prop
-\ >float t "foldable" set-word-prop
-
-\ (fraction>) [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
-\ (fraction>) t "flushable" set-word-prop
-\ (fraction>) t "foldable" set-word-prop
-
-\ string>float [ [ string ] [ float ] ] "infer-effect" set-word-prop
-\ string>float t "flushable" set-word-prop
-\ string>float t "foldable" set-word-prop
-
-\ float>string [ [ float ] [ string ] ] "infer-effect" set-word-prop
-\ float>string t "flushable" set-word-prop
-\ float>string t "foldable" set-word-prop
-
-\ float>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop
-\ float>bits t "flushable" set-word-prop
-\ float>bits t "foldable" set-word-prop
-
-\ double>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop
-\ double>bits t "flushable" set-word-prop
-\ double>bits t "foldable" set-word-prop
-
-\ bits>float [ [ integer ] [ float ] ] "infer-effect" set-word-prop
-\ bits>float t "flushable" set-word-prop
-\ bits>float t "foldable" set-word-prop
-
-\ bits>double [ [ integer ] [ float ] ] "infer-effect" set-word-prop
-\ bits>double t "flushable" set-word-prop
-\ bits>double t "foldable" set-word-prop
-
-\ <complex> [ [ real real ] [ number ] ] "infer-effect" set-word-prop
-\ <complex> t "flushable" set-word-prop
-\ <complex> t "foldable" set-word-prop
-
-\ fixnum+ [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
-\ fixnum+ t "flushable" set-word-prop
-\ fixnum+ t "foldable" set-word-prop
-
-\ fixnum+fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
-\ fixnum+fast t "flushable" set-word-prop
-\ fixnum+fast t "foldable" set-word-prop
-
-\ fixnum- [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
-\ fixnum- t "flushable" set-word-prop
-\ fixnum- t "foldable" set-word-prop
-
-\ fixnum-fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
-\ fixnum-fast t "flushable" set-word-prop
-\ fixnum-fast t "foldable" set-word-prop
-
-\ fixnum* [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
-\ fixnum* t "flushable" set-word-prop
-\ fixnum* t "foldable" set-word-prop
-
-\ fixnum/i [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
-\ fixnum/i t "flushable" set-word-prop
-\ fixnum/i t "foldable" set-word-prop
-
-\ fixnum/f [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
-\ fixnum/f t "flushable" set-word-prop
-\ fixnum/f t "foldable" set-word-prop
-
-\ fixnum-mod [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
-\ fixnum-mod t "flushable" set-word-prop
-\ fixnum-mod t "foldable" set-word-prop
-
-\ fixnum/mod [ [ fixnum fixnum ] [ integer fixnum ] ] "infer-effect" set-word-prop
-\ fixnum/mod t "flushable" set-word-prop
-\ fixnum/mod t "foldable" set-word-prop
-
-\ fixnum-bitand [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
-\ fixnum-bitand t "flushable" set-word-prop
-\ fixnum-bitand t "foldable" set-word-prop
-
-\ fixnum-bitor [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
-\ fixnum-bitor t "flushable" set-word-prop
-\ fixnum-bitor t "foldable" set-word-prop
-
-\ fixnum-bitxor [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
-\ fixnum-bitxor t "flushable" set-word-prop
-\ fixnum-bitxor t "foldable" set-word-prop
-
-\ fixnum-bitnot [ [ fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
-\ fixnum-bitnot t "flushable" set-word-prop
-\ fixnum-bitnot t "foldable" set-word-prop
-
-\ fixnum-shift [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
-\ fixnum-shift t "flushable" set-word-prop
-\ fixnum-shift t "foldable" set-word-prop
-
-\ bignum= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
-\ bignum= t "flushable" set-word-prop
-\ bignum= t "foldable" set-word-prop
-
-\ bignum+ [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
-\ bignum+ t "flushable" set-word-prop
-\ bignum+ t "foldable" set-word-prop
-
-\ bignum- [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
-\ bignum- t "flushable" set-word-prop
-\ bignum- t "foldable" set-word-prop
-
-\ bignum* [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
-\ bignum* t "flushable" set-word-prop
-\ bignum* t "foldable" set-word-prop
-
-\ bignum/i [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
-\ bignum/i t "flushable" set-word-prop
-\ bignum/i t "foldable" set-word-prop
-
-\ bignum/f [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
-\ bignum/f t "flushable" set-word-prop
-\ bignum/f t "foldable" set-word-prop
-
-\ bignum-mod [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
-\ bignum-mod t "flushable" set-word-prop
-\ bignum-mod t "foldable" set-word-prop
-
-\ bignum/mod [ [ bignum bignum ] [ bignum bignum ] ] "infer-effect" set-word-prop
-\ bignum/mod t "flushable" set-word-prop
-\ bignum/mod t "foldable" set-word-prop
-
-\ bignum-bitand [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
-\ bignum-bitand t "flushable" set-word-prop
-\ bignum-bitand t "foldable" set-word-prop
-
-\ bignum-bitor [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
-\ bignum-bitor t "flushable" set-word-prop
-\ bignum-bitor t "foldable" set-word-prop
-
-\ bignum-bitxor [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
-\ bignum-bitxor t "flushable" set-word-prop
-\ bignum-bitxor t "foldable" set-word-prop
-
-\ bignum-bitnot [ [ bignum ] [ bignum ] ] "infer-effect" set-word-prop
-\ bignum-bitnot t "flushable" set-word-prop
-\ bignum-bitnot t "foldable" set-word-prop
-
-\ bignum-shift [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
-\ bignum-shift t "flushable" set-word-prop
-\ bignum-shift t "foldable" set-word-prop
-
-\ bignum< [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
-\ bignum< t "flushable" set-word-prop
-\ bignum< t "foldable" set-word-prop
-
-\ bignum<= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
-\ bignum<= t "flushable" set-word-prop
-\ bignum<= t "foldable" set-word-prop
-
-\ bignum> [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
-\ bignum> t "flushable" set-word-prop
-\ bignum> t "foldable" set-word-prop
-
-\ bignum>= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
-\ bignum>= t "flushable" set-word-prop
-\ bignum>= t "foldable" set-word-prop
-
-\ float+ [ [ float float ] [ float ] ] "infer-effect" set-word-prop
-\ float+ t "flushable" set-word-prop
-\ float+ t "foldable" set-word-prop
-
-\ float- [ [ float float ] [ float ] ] "infer-effect" set-word-prop
-\ float- t "flushable" set-word-prop
-\ float- t "foldable" set-word-prop
-
-\ float* [ [ float float ] [ float ] ] "infer-effect" set-word-prop
-\ float* t "flushable" set-word-prop
-\ float* t "foldable" set-word-prop
-
-\ float/f [ [ float float ] [ float ] ] "infer-effect" set-word-prop
-\ float/f t "flushable" set-word-prop
-\ float/f t "foldable" set-word-prop
-
-\ float< [ [ float float ] [ object ] ] "infer-effect" set-word-prop
-\ float< t "flushable" set-word-prop
-\ float< t "foldable" set-word-prop
-
-\ float-mod [ [ float float ] [ float ] ] "infer-effect" set-word-prop
-\ float-mod t "flushable" set-word-prop
-\ float-mod t "foldable" set-word-prop
-
-\ float<= [ [ float float ] [ object ] ] "infer-effect" set-word-prop
-\ float<= t "flushable" set-word-prop
-\ float<= t "foldable" set-word-prop
-
-\ float> [ [ float float ] [ object ] ] "infer-effect" set-word-prop
-\ float> t "flushable" set-word-prop
-\ float> t "foldable" set-word-prop
-
-\ float>= [ [ float float ] [ object ] ] "infer-effect" set-word-prop
-\ float>= t "flushable" set-word-prop
-\ float>= t "foldable" set-word-prop
-
-\ facos [ [ real ] [ float ] ] "infer-effect" set-word-prop
-\ facos t "flushable" set-word-prop
-\ facos t "foldable" set-word-prop
-
-\ fasin [ [ real ] [ float ] ] "infer-effect" set-word-prop
-\ fasin t "flushable" set-word-prop
-\ fasin t "foldable" set-word-prop
-
-\ fatan [ [ real ] [ float ] ] "infer-effect" set-word-prop
-\ fatan t "flushable" set-word-prop
-\ fatan t "foldable" set-word-prop
-
-\ fatan2 [ [ real real ] [ float ] ] "infer-effect" set-word-prop
-\ fatan2 t "flushable" set-word-prop
-\ fatan2 t "foldable" set-word-prop
-
-\ fcos [ [ real ] [ float ] ] "infer-effect" set-word-prop
-\ fcos t "flushable" set-word-prop
-\ fcos t "foldable" set-word-prop
-
-\ fexp [ [ real ] [ float ] ] "infer-effect" set-word-prop
-\ fexp t "flushable" set-word-prop
-\ fexp t "foldable" set-word-prop
-
-\ fcosh [ [ real ] [ float ] ] "infer-effect" set-word-prop
-\ fcosh t "flushable" set-word-prop
-\ fcosh t "foldable" set-word-prop
-
-\ flog [ [ real ] [ float ] ] "infer-effect" set-word-prop
-\ flog t "flushable" set-word-prop
-\ flog t "foldable" set-word-prop
-
-\ fpow [ [ real real ] [ float ] ] "infer-effect" set-word-prop
-\ fpow t "flushable" set-word-prop
-\ fpow t "foldable" set-word-prop
-
-\ fsin [ [ real ] [ float ] ] "infer-effect" set-word-prop
-\ fsin t "flushable" set-word-prop
-\ fsin t "foldable" set-word-prop
-
-\ fsinh [ [ real ] [ float ] ] "infer-effect" set-word-prop
-\ fsinh t "flushable" set-word-prop
-\ fsinh t "foldable" set-word-prop
-
-\ fsqrt [ [ real ] [ float ] ] "infer-effect" set-word-prop
-\ fsqrt t "flushable" set-word-prop
-\ fsqrt t "foldable" set-word-prop
-
-\ <word> [ [ object object ] [ word ] ] "infer-effect" set-word-prop
-\ <word> t "flushable" set-word-prop
-
-\ update-xt [ [ word ] [ ] ] "infer-effect" set-word-prop
-\ compiled? [ [ word ] [ object ] ] "infer-effect" set-word-prop
-
-\ getenv [ [ fixnum ] [ object ] ] "infer-effect" set-word-prop
-\ setenv [ [ object fixnum ] [ ] ] "infer-effect" set-word-prop
-\ stat [ [ string ] [ general-list ] ] "infer-effect" set-word-prop
-\ (directory) [ [ string ] [ general-list ] ] "infer-effect" set-word-prop
-\ gc [ [ fixnum ] [ ] ] "infer-effect" set-word-prop
-\ gc-time [ [ string ] [ ] ] "infer-effect" set-word-prop
-\ save-image [ [ string ] [ ] ] "infer-effect" set-word-prop
-\ exit [ [ integer ] [ ] ] "infer-effect" set-word-prop
-\ room [ [ ] [ integer integer integer integer general-list ] ] "infer-effect" set-word-prop
-\ os-env [ [ string ] [ object ] ] "infer-effect" set-word-prop
-\ millis [ [ ] [ integer ] ] "infer-effect" set-word-prop
-
-\ type [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
-\ type t "flushable" set-word-prop
-\ type t "foldable" set-word-prop
-
-\ tag [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
-\ tag t "flushable" set-word-prop
-\ tag t "foldable" set-word-prop
-
-\ cwd [ [ ] [ string ] ] "infer-effect" set-word-prop
-\ cd [ [ string ] [ ] ] "infer-effect" set-word-prop
-
-\ compiled-offset [ [ ] [ integer ] ] "infer-effect" set-word-prop
-\ compiled-offset t "flushable" set-word-prop
-
-\ set-compiled-offset [ [ integer ] [ ] ] "infer-effect" set-word-prop
-
-\ literal-top [ [ ] [ integer ] ] "infer-effect" set-word-prop
-\ literal-top t "flushable" set-word-prop
-
-\ set-literal-top [ [ integer ] [ ] ] "infer-effect" set-word-prop
-
-\ address [ [ object ] [ integer ] ] "infer-effect" set-word-prop
-\ address t "flushable" set-word-prop
-
-\ dlopen [ [ string ] [ dll ] ] "infer-effect" set-word-prop
-\ dlsym [ [ string object ] [ integer ] ] "infer-effect" set-word-prop
-\ dlclose [ [ dll ] [ ] ] "infer-effect" set-word-prop
-
-\ <byte-array> [ [ integer ] [ byte-array ] ] "infer-effect" set-word-prop
-\ <byte-array> t "flushable" set-word-prop
-
-\ <displaced-alien> [ [ integer c-ptr ] [ c-ptr ] ] "infer-effect" set-word-prop
-\ <displaced-alien> t "flushable" set-word-prop
-
-\ alien-signed-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
-\ alien-signed-cell t "flushable" set-word-prop
-
-\ set-alien-signed-cell [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-unsigned-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
-\ alien-unsigned-cell t "flushable" set-word-prop
-
-\ set-alien-unsigned-cell [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-signed-8 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
-\ alien-signed-8 t "flushable" set-word-prop
-
-\ set-alien-signed-8 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-unsigned-8 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
-\ alien-unsigned-8 t "flushable" set-word-prop
-
-\ set-alien-unsigned-8 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-signed-4 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
-\ alien-signed-4 t "flushable" set-word-prop
-
-\ set-alien-signed-4 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-unsigned-4 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
-\ alien-unsigned-4 t "flushable" set-word-prop
-
-\ set-alien-unsigned-4 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-signed-2 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
-\ alien-signed-2 t "flushable" set-word-prop
-
-\ set-alien-signed-2 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-unsigned-2 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
-\ alien-unsigned-2 t "flushable" set-word-prop
-
-\ set-alien-unsigned-2 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-signed-1 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
-\ alien-signed-1 t "flushable" set-word-prop
-
-\ set-alien-signed-1 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-unsigned-1 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
-\ alien-unsigned-1 t "flushable" set-word-prop
-
-\ set-alien-unsigned-1 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-float [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
-\ alien-float t "flushable" set-word-prop
-
-\ set-alien-float [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-float [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
-\ alien-float t "flushable" set-word-prop
-
-\ set-alien-double [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-double [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
-\ alien-double t "flushable" set-word-prop
-
-\ alien>string [ [ c-ptr ] [ string ] ] "infer-effect" set-word-prop
-\ alien>string t "flushable" set-word-prop
-
-\ string>alien [ [ string ] [ byte-array ] ] "infer-effect" set-word-prop
-\ string>alien t "flushable" set-word-prop
-
-\ string>memory [ [ string integer ] [ ] ] "infer-effect" set-word-prop
-\ memory>string [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
-
-\ alien-address [ [ alien ] [ integer ] ] "infer-effect" set-word-prop
-
-\ slot [ [ object fixnum ] [ object ] ] "infer-effect" set-word-prop
-\ slot t "flushable" set-word-prop
-
-\ set-slot [ [ object object fixnum ] [ ] ] "infer-effect" set-word-prop
-
-\ integer-slot [ [ object fixnum ] [ integer ] ] "infer-effect" set-word-prop
-\ integer-slot t "flushable" set-word-prop
-
-\ set-integer-slot [ [ integer object fixnum ] [ ] ] "infer-effect" set-word-prop
-
-\ char-slot [ [ fixnum object ] [ fixnum ] ] "infer-effect" set-word-prop
-\ char-slot t "flushable" set-word-prop
-
-\ set-char-slot [ [ fixnum fixnum object ] [ ] ] "infer-effect" set-word-prop
-\ resize-array [ [ fixnum array ] [ array ] ] "infer-effect" set-word-prop
-\ resize-string [ [ fixnum string ] [ string ] ] "infer-effect" set-word-prop
-
-\ (hashtable) [ [ ] [ hashtable ] ] "infer-effect" set-word-prop
-\ (hashtable) t "flushable" set-word-prop
-
-\ <array> [ [ integer object ] [ array ] ] "infer-effect" set-word-prop
-\ <array> t "flushable" set-word-prop
-
-\ <tuple> [ [ integer ] [ tuple ] ] "infer-effect" set-word-prop
-\ <tuple> t "flushable" set-word-prop
-
-\ begin-scan [ [ ] [ ] ] "infer-effect" set-word-prop
-\ next-object [ [ ] [ object ] ] "infer-effect" set-word-prop
-\ end-scan [ [ ] [ ] ] "infer-effect" set-word-prop
-
-\ size [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
-\ size t "flushable" set-word-prop
-
-\ die [ [ ] [ ] ] "infer-effect" set-word-prop
-\ fopen [ [ string string ] [ alien ] ] "infer-effect" set-word-prop
-\ fgetc [ [ alien ] [ object ] ] "infer-effect" set-word-prop
-\ fwrite [ [ string alien ] [ ] ] "infer-effect" set-word-prop
-\ fflush [ [ alien ] [ ] ] "infer-effect" set-word-prop
-\ fclose [ [ alien ] [ ] ] "infer-effect" set-word-prop
-\ expired? [ [ object ] [ object ] ] "infer-effect" set-word-prop
-
-\ <wrapper> [ [ object ] [ wrapper ] ] "infer-effect" set-word-prop
-\ <wrapper> t "flushable" set-word-prop
-\ <wrapper> t "foldable" set-word-prop
-
-\ (clone) [ [ object ] [ object ] ] "infer-effect" set-word-prop
-\ (clone) t "flushable" set-word-prop
-
-\ array>tuple [ [ array ] [ tuple ] ] "infer-effect" set-word-prop
-\ array>tuple t "flushable" set-word-prop
-
-\ tuple>array [ [ tuple ] [ array ] ] "infer-effect" set-word-prop
-\ tuple>array t "flushable" set-word-prop
-
-\ array>vector [ [ array ] [ vector ] ] "infer-effect" set-word-prop
-\ array>vector t "flushable" set-word-prop
-
-\ flush-icache [ [ ] [ ] ] "infer-effect" set-word-prop
-
-\ <string> [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
-\ <string> t "flushable" set-word-prop
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: optimizer
-USING: compiler generic hashtables inference io kernel
-lists math namespaces sequences vectors ;
-
-SYMBOL: optimizer-changed
-
-GENERIC: optimize-node* ( node -- node/t )
-
-: keep-optimizing ( node -- node ? )
- dup optimize-node* dup t =
- [ drop f ] [ nip keep-optimizing t or ] if ;
-
-: optimize-node ( node -- node )
- [
- keep-optimizing [ optimizer-changed on ] when
- ] map-nodes ;
-
-: optimize ( node -- node )
- dup kill-values dup infer-classes [
- optimizer-changed off
- optimize-node
- optimizer-changed get
- ] with-node-iterator [ optimize ] when ;
-
-: prune-if ( node quot -- successor/t )
- over >r call [ r> node-successor ] [ r> drop t ] if ;
- inline
-
-! Generic nodes
-M: f optimize-node* drop t ;
-
-M: node optimize-node* ( node -- t ) drop t ;
-
-! #shuffle
-M: #shuffle optimize-node* ( node -- node/t )
- [ node-values empty? ] prune-if ;
-
-! #push
-M: #push optimize-node* ( node -- node/t )
- [ node-out-d empty? ] prune-if ;
-
-! #return
-M: #return optimize-node* ( node -- node/t )
- node-successor [ node-successor ] [ t ] if* ;
+++ /dev/null
-IN: optimizer
-USING: generic hashtables inference io kernel kernel-internals
-lists math namespaces prettyprint sequences styles vectors words ;
-
-! A simple tool for turning dataflow IR into quotations, for
-! debugging purposes.
-
-GENERIC: node>quot ( node -- )
-
-TUPLE: comment node text ;
-
-M: comment pprint* ( ann -- )
- "( " over comment-text " )" append3
- swap comment-node presented associate text ;
-
-: comment, ( ? node text -- )
- rot [ <comment> , ] [ 2drop ] if ;
-
-: values% ( prefix values -- )
- [
- swap %
- dup value? [
- value-literal unparse %
- ] [
- "@" % #
- ] if
- ] each-with ;
-
-: effect-str ( node -- str )
- [
- " " over node-in-d values%
- " r: " over node-in-r values%
- " --" %
- " " over node-out-d values%
- " r: " swap node-out-r values%
- ] "" make 1 swap tail ;
-
-M: #shuffle node>quot ( ? node -- )
- >r drop t r> dup effect-str "#shuffle: " swap append comment, ;
-
-M: #push node>quot ( ? node -- ) nip >#push< % ;
-
-DEFER: dataflow>quot
-
-: #call>quot ( ? node -- )
- dup node-param dup
- [ , dup effect-str comment, ] [ 3drop ] if ;
-
-M: #call node>quot ( ? node -- ) #call>quot ;
-
-M: #call-label node>quot ( ? node -- ) #call>quot ;
-
-M: #label node>quot ( ? node -- )
- [ "#label: " over node-param word-name append comment, ] 2keep
- node-child swap dataflow>quot , \ call , ;
-
-M: #if node>quot ( ? node -- )
- [ "#if" comment, ] 2keep
- node-children [ swap dataflow>quot ] map-with % \ if , ;
-
-M: #dispatch node>quot ( ? node -- )
- [ "#dispatch" comment, ] 2keep
- node-children [ swap dataflow>quot ] map-with , \ dispatch , ;
-
-M: #return node>quot ( ? node -- )
- dup node-param unparse "#return " swap append comment, ;
-
-M: #values node>quot ( ? node -- ) "#values" comment, ;
-
-M: #merge node>quot ( ? node -- ) "#merge" comment, ;
-
-M: #entry node>quot ( ? node -- ) "#entry" comment, ;
-
-M: #terminate node>quot ( ? node -- ) "#terminate" comment, ;
-
-: (dataflow>quot) ( ? node -- )
- dup [
- 2dup node>quot node-successor (dataflow>quot)
- ] [
- 2drop
- ] if ;
-
-: dataflow>quot ( node ? -- quot )
- [ swap (dataflow>quot) ] [ ] make ;
-
-: dataflow. ( quot ? -- )
- #! Print dataflow IR for a quotation. Flag indicates if
- #! annotations should be printed or not.
- >r dataflow optimize r> dataflow>quot . ;
+++ /dev/null
-! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: inference
-USING: hashtables kernel math namespaces sequences ;
-
-! Recursive state. An alist, mapping words to labels.
-SYMBOL: recursive-state
-
-: <computed> \ <computed> counter ;
-
-TUPLE: value uid literal recursion ;
-
-C: value ( obj -- value )
- <computed> over set-value-uid
- recursive-state get over set-value-recursion
- [ set-value-literal ] keep ;
-
-M: value hashcode value-uid ;
-
-M: value = eq? ;
-
-M: integer value-uid ;
-
-M: integer value-recursion drop f ;
-
-TUPLE: shuffle in-d in-r out-d out-r ;
-
-: load-shuffle ( d r shuffle -- )
- tuck shuffle-in-r [ set ] 2each shuffle-in-d [ set ] 2each ;
-
-: shuffled-values ( values -- values )
- [ [ namespace hash dup ] keep ? ] map ;
-
-: store-shuffle ( shuffle -- d r )
- dup shuffle-out-d shuffled-values
- swap shuffle-out-r shuffled-values ;
-
-: shuffle* ( d r shuffle -- d r )
- [ [ load-shuffle ] keep store-shuffle ] with-scope ;
-
-: split-shuffle ( d r shuffle -- d' r' d r )
- tuck shuffle-in-r length swap cut*
- >r >r shuffle-in-d length swap cut*
- r> swap r> ;
-
-: join-shuffle ( d' r' d r -- d r )
- swapd append >r append r> ;
-
-: shuffle ( d r shuffle -- d r )
- #! d and r lengths must be at least the required length for
- #! the shuffle.
- [ split-shuffle ] keep shuffle* join-shuffle ;
-
-M: shuffle clone ( shuffle -- shuffle )
- [ shuffle-in-d clone ] keep
- [ shuffle-in-r clone ] keep
- [ shuffle-out-d clone ] keep
- shuffle-out-r clone
- <shuffle> ;
+++ /dev/null
-IN: inference
-USING: arrays generic interpreter kernel math namespaces
-sequences words ;
-
-: infer-shuffle-inputs ( shuffle node -- )
- >r dup shuffle-in-d length swap shuffle-in-r length r>
- node-inputs ;
-
-: shuffle-stacks ( shuffle -- )
- #! Shuffle simulated stacks.
- meta-d get meta-r get rot shuffle meta-r set meta-d set ;
-
-: infer-shuffle-outputs ( shuffle node -- )
- >r dup shuffle-out-d length swap shuffle-out-r length r>
- node-outputs ;
-
-: infer-shuffle ( shuffle -- )
- #shuffle
- 2dup infer-shuffle-inputs
- over shuffle-stacks
- tuck infer-shuffle-outputs
- node, ;
-
-: shuffle>effect ( shuffle -- effect )
- dup shuffle-in-d [ drop object ] map
- swap shuffle-out-d [ drop object ] map 2array ;
-
-: define-shuffle ( word shuffle -- )
- [ shuffle>effect "infer-effect" set-word-prop ] 2keep
- [ , \ infer-shuffle , ] [ ] make "infer" set-word-prop ;
-
-{
- { drop T{ shuffle f 1 0 { } { } } }
- { 2drop T{ shuffle f 2 0 { } { } } }
- { 3drop T{ shuffle f 3 0 { } { } } }
- { dup T{ shuffle f 1 0 { 0 0 } { } } }
- { 2dup T{ shuffle f 2 0 { 0 1 0 1 } { } } }
- { 3dup T{ shuffle f 3 0 { 0 1 2 0 1 2 } { } } }
- { rot T{ shuffle f 3 0 { 1 2 0 } { } } }
- { -rot T{ shuffle f 3 0 { 2 0 1 } { } } }
- { dupd T{ shuffle f 2 0 { 0 0 1 } { } } }
- { swapd T{ shuffle f 3 0 { 1 0 2 } { } } }
- { nip T{ shuffle f 2 0 { 1 } { } } }
- { 2nip T{ shuffle f 3 0 { 2 } { } } }
- { tuck T{ shuffle f 2 0 { 1 0 1 } { } } }
- { over T{ shuffle f 2 0 { 0 1 0 } { } } }
- { pick T{ shuffle f 3 0 { 0 1 2 0 } { } } }
- { swap T{ shuffle f 2 0 { 1 0 } { } } }
- { >r T{ shuffle f 1 0 { } { 0 } } }
- { r> T{ shuffle f 0 1 { 0 } { } } }
-} [ first2 define-shuffle ] each
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: inference
-USING: arrays errors generic hashtables interpreter kernel lists
-math math-internals namespaces parser prettyprint sequences
-strings vectors words ;
-
-: consume-values ( n node -- )
- over ensure-values
- over 0 rot node-inputs [ pop-d 2drop ] each ;
-
-: produce-values ( n node -- )
- over [ drop <computed> push-d ] each 0 swap node-outputs ;
-
-: consume/produce ( word effect -- )
- #! Add a node to the dataflow graph that consumes and
- #! produces a number of values.
- swap #call
- over first length over consume-values
- swap second length over produce-values
- node, ;
-
-: no-effect ( word -- )
- "Stack effect inference of the word " swap word-name
- " was already attempted, and failed" append3
- inference-error ;
-
-TUPLE: rstate label base-case? ;
-
-: nest-node ( -- dataflow current )
- dataflow-graph get dataflow-graph off
- current-node get current-node off ;
-
-: unnest-node ( new-node dataflow current -- new-node )
- >r >r dataflow-graph get 1array over set-node-children
- r> dataflow-graph set
- r> current-node set ;
-
-: with-recursive-state ( word label base-case quot -- )
- >r <rstate> 2array recursive-state [ cons ] change r>
- nest-node 2slip unnest-node ; inline
-
-: inline-block ( word base-case -- node-block variables )
- [
- copy-inference
- >r gensym 2dup r> [
- dup #label >r
- #entry node,
- swap word-def infer-quot
- #return node, r>
- ] with-recursive-state
- ] make-hash ;
-
-: apply-infer ( hash -- )
- { meta-d meta-r d-in }
- [ [ swap hash ] keep set ] each-with ;
-
-GENERIC: collect-recursion* ( label node -- )
-
-M: node collect-recursion* ( label node -- ) 2drop ;
-
-M: #call-label collect-recursion* ( label node -- )
- tuck node-param = [ node-in-d , ] [ drop ] if ;
-
-: collect-recursion ( #label -- seq )
- #! Collect the input stacks of all #call-label nodes that
- #! call given label.
- dup node-param swap
- [ [ collect-recursion* ] each-node-with ] { } make ;
-
-: amend-d-in ( new old -- )
- [ length ] 2apply - d-in [ + ] change ;
-
-: join-values ( node -- )
- #! We have to infer recursive labels twice to determine
- #! which literals survive the recursion (eg, quotations)
- #! and which don't (loop indices, etc). The latter cannot
- #! be folded.
- meta-d get [
- >r collect-recursion r> add unify-lengths
- flip [ unify-values ] map dup meta-d set
- ] keep amend-d-in ;
-
-: splice-node ( node -- )
- #! Labels which do not call themselves are just spliced into
- #! the IR, and no #label node is added.
- dup node-successor [
- dup node, penultimate-node f over set-node-successor
- dup current-node set
- ] when drop ;
-
-: inline-closure ( word -- )
- #! This is not a closure in the lexical scope sense, but a
- #! closure under recursive value substitution.
- #! If the block does not call itself, there is no point in
- #! having the block node in the IR. Just add its contents.
- dup f inline-block over recursive-label? [
- meta-d get >r
- drop join-values f inline-block apply-infer
- r> over set-node-in-d node,
- ] [
- apply-infer node-child node-successor splice-node drop
- ] if ;
-
-: infer-compound ( word base-case -- terminates? effect )
- #! Infer a word's stack effect in a separate inferencer
- #! instance. Outputs a boolean if the word terminates
- #! control flow by throwing an exception or restoring a
- #! continuation.
- [
- dup inferring-base-case set
- recursive-state get init-inference
- over >r inline-block nip
- [ terminated? get effect ] bind r>
- ] with-scope over consume/produce over [ terminate ] when ;
-
-GENERIC: apply-word
-
-M: object apply-word ( word -- )
- #! A primitive with an unknown stack effect.
- no-effect ;
-
-: save-effect ( word terminates effect -- )
- inferring-base-case get [
- 3drop
- ] [
- >r dupd "terminates" set-word-prop r>
- "infer-effect" set-word-prop
- ] if ;
-
-M: compound apply-word ( word -- )
- #! Infer a compound word's stack effect.
- [
- dup f infer-compound save-effect
- ] [
- swap t "no-effect" set-word-prop rethrow
- ] recover ;
-
-: apply-default ( word -- )
- dup "no-effect" word-prop [
- no-effect
- ] [
- dup "infer-effect" word-prop [
- over "infer" word-prop [
- swap first length ensure-values call drop
- ] [
- dupd consume/produce
- "terminates" word-prop [ terminate ] when
- ] if*
- ] [
- apply-word
- ] if*
- ] if ;
-
-M: word apply-object ( word -- )
- apply-default ;
-
-M: symbol apply-object ( word -- )
- apply-literal ;
-
-: inline-base-case ( word label -- )
- meta-d get clone >r over t inline-block apply-infer drop
- [ #call-label ] [ #call ] ?if r> over set-node-in-d node, ;
-
-: base-case ( word label -- )
- over "inline" word-prop [
- inline-base-case
- ] [
- drop dup t infer-compound swap
- [ 2drop ] [ "base-case" set-word-prop ] if
- ] if ;
-
-: no-base-case ( word -- )
- {
- "The base case of a recursive word could not be inferred.\n"
- "This means the word calls itself in every control flow path.\n"
- "See the handbook for details."
- } concat inference-error ;
-
-: notify-base-case ( -- )
- base-case-continuation get
- [ t swap continue-with ] [ no-base-case ] if* ;
-
-: recursive-word ( word rstate -- )
- #! Handle a recursive call, by either applying a previously
- #! inferred base case, or raising an error. If the recursive
- #! call is to a local block, emit a label call node.
- over "infer-effect" word-prop [
- nip consume/produce
- ] [
- over "base-case" word-prop [
- nip consume/produce
- ] [
- dup rstate-base-case? [
- notify-base-case
- ] [
- rstate-label base-case
- ] if
- ] if*
- ] if* ;
-
-M: compound apply-object ( word -- )
- #! Apply the word's stack effect to the inferencer state.
- dup recursive-state get assoc [
- recursive-word
- ] [
- dup "inline" word-prop
- [ inline-closure ] [ apply-default ] if
- ] if* ;
projects / factor.git / commitdiff