steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

vm: fix conflict in image.cpp

db4
Slava Pestov 2009-10-18 20:54:13 -05:00
parent 918e6a78e0 2e65366c6b
commit a81f757a62
90 changed files with 911 additions and 685 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/alien/c-types/c-types.factor
View File

@ -81,9 +81,13 @@ M: string resolve-pointer-type
dup void? [ no-c-type ] when
dup c-type-name? [ c-type ] when ;
<PRIVATE
: parse-array-type ( name -- dims c-type )
"[" split unclip
[ [ "]" ?tail drop parse-word ] map ] dip ;
[ [ "]" ?tail drop string>number ] map ] dip ;
PRIVATE>
M: string c-type ( name -- c-type )
CHAR: ] over member? [

24
basis/alien/parser/parser.factor
View File

@ -10,16 +10,26 @@ IN: alien.parser
: parse-c-type-name ( name -- word )
dup search [ ] [ no-word ] ?if ;
: parse-c-type ( string -- type )
: parse-array-type ( name -- dims c-type )
"[" split unclip
[ [ "]" ?tail drop parse-word ] map ] dip ;
: (parse-c-type) ( string -- type )
{
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ dup search c-type-word? ] [ parse-c-type-name ] }
{ [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
[ dup search [ no-c-type ] [ no-word ] ?if ]
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ dup search ] [ parse-c-type-name ] }
{ [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
[ dup search [ ] [ no-word ] ?if ]
} cond ;
: valid-c-type? ( c-type -- ? )
{ [ array? ] [ c-type-name? ] [ void? ] } 1|| ;
: parse-c-type ( string -- type )
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
: scan-c-type ( -- c-type )
scan dup "{" =
[ drop \ } parse-until >array ]

2
basis/cpu/ppc/assembler/assembler.factor
View File

@ -97,6 +97,8 @@ X: XOR 0 316 31
X: XOR. 1 316 31
X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31
: FRSP ( a s -- ) [ 0 ] 2dip 0 12 63 x-insn ;
: FRSP. ( a s -- ) [ 0 ] 2dip 1 12 63 x-insn ;
: FMR ( a s -- ) [ 0 ] 2dip 0 72 63 x-insn ;
: FMR. ( a s -- ) [ 0 ] 2dip 1 72 63 x-insn ;
: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;

2
basis/cpu/ppc/ppc.factor
View File

@ -251,7 +251,7 @@ M:: ppc %binary-float-function ( dst src1 src2 func -- )
! Internal format is always double-precision on PowerPC
M: ppc %single>double-float double-rep %copy ;
M: ppc %double>single-float double-rep %copy ;
M: ppc %double>single-float FRSP ;
M: ppc %unbox-alien ( dst src -- )
alien-offset LWZ ;

19
basis/cpu/x86/32/32.factor
View File

@ -250,10 +250,10 @@ M:: x86.32 %unbox-large-struct ( n c-type -- )
] with-aligned-stack ;
M: x86.32 %nest-stacks ( -- )
! Save current frame. See comment in vm/contexts.hpp
EAX stack-reg stack-frame get total-size>> 3 cells - [+] LEA
8 [
push-vm-ptr
! Save current frame. See comment in vm/contexts.hpp
EAX stack-reg stack-frame get total-size>> [+] LEA
EAX PUSH
"nest_stacks" f %alien-invoke
] with-aligned-stack ;
@ -265,20 +265,19 @@ M: x86.32 %unnest-stacks ( -- )
] with-aligned-stack ;
M: x86.32 %prepare-alien-indirect ( -- )
push-vm-ptr "unbox_alien" f %alien-invoke
temp-reg POP
4 [
push-vm-ptr
"unbox_alien" f %alien-invoke
] with-aligned-stack
EBP EAX MOV ;
M: x86.32 %alien-indirect ( -- )
EBP CALL ;
M: x86.32 %alien-callback ( quot -- )
4 [
EAX swap %load-reference
EAX PUSH
param-reg-2 %mov-vm-ptr
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
param-reg-1 swap %load-reference
param-reg-2 %mov-vm-ptr
"c_to_factor" f %alien-invoke ;
M: x86.32 %callback-value ( ctype -- )
! Align C stack

2
basis/io/files/unix/unix-tests.factor
View File

@ -2,7 +2,7 @@ USING: tools.test io.files io.files.temp io.pathnames
io.directories io.files.info io.files.info.unix continuations
kernel io.files.unix math.bitwise calendar accessors
math.functions math unix.users unix.groups arrays sequences
grouping ;
grouping io.pathnames.private ;
IN: io.files.unix.tests
[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test

2
basis/io/files/windows/nt/nt-tests.factor
View File

@ -1,5 +1,5 @@
USING: io.files io.pathnames kernel tools.test io.backend
io.files.windows.nt splitting sequences ;
io.files.windows.nt splitting sequences io.pathnames.private ;
IN: io.files.windows.nt.tests
[ f ] [ "\\foo" absolute-path? ] unit-test

4
basis/math/vectors/simd/functor/functor.factor
View File

@ -283,8 +283,10 @@ simd new
{ { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
{ { +vector+ +literal+ -> +vector+ } A-vn->v-op }
{ { +vector+ +vector+ -> +scalar+ } A-vv->n-op }
{ { +vector+ +vector+ -> +boolean+ } A-vv->n-op }
{ { +vector+ -> +vector+ } A-v->v-op }
{ { +vector+ -> +scalar+ } A-v->n-op }
{ { +vector+ -> +boolean+ } A-v->n-op }
{ { +vector+ -> +nonnegative+ } A-v->n-op }
} >>schema-wrappers
(define-simd-128)
@ -325,7 +327,7 @@ FUNCTOR: define-simd-256 ( T -- )
N [ 32 T c:heap-size /i ]
N/2 [ N 2 / ]
N/2 [ N 2 /i ]
A/2 IS ${T}-${N/2}
A/2-boa IS ${A/2}-boa
A/2-with IS ${A/2}-with

6
basis/math/vectors/simd/intrinsics/intrinsics.factor
View File

@ -8,7 +8,7 @@ sequences sets effects accessors namespaces
lexer parser vocabs.parser words arrays math.vectors ;
IN: math.vectors.simd.intrinsics
ERROR: bad-simd-call ;
ERROR: bad-simd-call word ;
<<
@ -24,7 +24,7 @@ V{ } clone simd-ops set-global
: (SIMD-OP:) ( accum quot -- accum )
[
scan-word dup name>> "(simd-" ")" surround create-in
[ nip [ bad-simd-call ] define ]
[ nip dup '[ _ bad-simd-call ] define ]
] dip
'[ _ dip set-stack-effect ]
[ 2array simd-ops get push ]
@ -147,7 +147,7 @@ GENERIC# supported-simd-op? 1 ( rep intrinsic -- ? )
cc> %compare-vector-reps [ int-vector-rep? ] filter
%xor-vector-reps [ float-vector-rep? ] filter
union
{ uchar-16-rep ushort-8-rep uint-4-rep ulonglong-2-rep } union ;
[ { } ] [ { uchar-16-rep ushort-8-rep uint-4-rep ulonglong-2-rep } union ] if-empty ;
: (%shuffle-imm-reps) ( -- reps )
%shuffle-vector-reps %shuffle-vector-imm-reps union ;

53
basis/math/vectors/simd/simd-tests.factor
View File

@ -48,11 +48,6 @@ cpu x86? [
float-4{ 0 1 0 2 }
[ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
] unit-test
[ 33.0 ] [
double-2{ 1 2 } double-2{ 10 20 }
[ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
] unit-test
] when
! Fuzz testing
@ -193,22 +188,18 @@ CONSTANT: simd-classes
'[ first2 inputs _ _ check-vector-op ]
] dip check-optimizer ; inline
: approx= ( x y -- ? )
: (approx=) ( x y -- ? )
{
{ [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
{ [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
{ [ 2dup [ fp-nan? ] either? ] [ 2drop f ] }
{ [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
{ [ 2dup [ sequence? ] both? ] [
[
{
{ [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
{ [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
{ [ 2dup [ fp-nan? ] either? not ] [ -1.e8 ~ ] }
} cond
] 2all?
] }
{ [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
} cond ;
: approx= ( x y -- ? )
2dup [ sequence? ] both?
[ [ (approx=) ] 2all? ] [ (approx=) ] if ;
: exact= ( x y -- ? )
{
{ [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
@ -289,23 +280,23 @@ simd-classes&reps [
"== Checking shifts and permutations" print
[ int-4{ 256 512 1024 2048 } ]
[ int-4{ 1 2 4 8 } 1 hlshift ] unit-test
[ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
[ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hlshift ] unit-test
[ int-4{ 256 512 1024 2048 } ]
[ int-4{ 1 2 4 8 } [ { int-4 } declare 1 hlshift ] compile-call ] unit-test
[ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
[ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } [ { char-16 } declare 1 hlshift ] compile-call ] unit-test
[ int-4{ 256 512 1024 2048 } ]
[ int-4{ 1 2 4 8 } 1 [ { int-4 fixnum } declare hlshift ] compile-call ] unit-test
[ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
[ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 [ { char-16 fixnum } declare hlshift ] compile-call ] unit-test
[ int-4{ 1 2 4 8 } ]
[ int-4{ 256 512 1024 2048 } 1 hrshift ] unit-test
[ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
[ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hrshift ] unit-test
[ int-4{ 1 2 4 8 } ]
[ int-4{ 256 512 1024 2048 } [ { int-4 } declare 1 hrshift ] compile-call ] unit-test
[ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
[ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } [ { char-16 } declare 1 hrshift ] compile-call ] unit-test
[ int-4{ 1 2 4 8 } ]
[ int-4{ 256 512 1024 2048 } 1 [ { int-4 fixnum } declare hrshift ] compile-call ] unit-test
[ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
[ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 [ { char-16 fixnum } declare hrshift ] compile-call ] unit-test
! Invalid inputs should not cause the compiler to throw errors
[ ] [
@ -394,10 +385,10 @@ simd-classes [
[ [ declaration declare vany? [ yes ] [ no ] if ] compile-call ]
[ [ declaration declare vall? [ yes ] [ no ] if ] compile-call ] tri ; inline
SYMBOL: !!inconsistent!!
TUPLE: inconsistent-vector-test bool branch ;
: ?inconsistent ( a b -- ab/inconsistent )
2dup = [ drop ] [ 2drop !!inconsistent!! ] if ;
: ?inconsistent ( bool branch -- ?/inconsistent )
2dup = [ drop ] [ inconsistent-vector-test boa ] if ;
:: test-vector-tests ( vector decl -- none? any? all? )
vector decl test-vector-tests-bool :> bool-all :> bool-any :> bool-none

10
basis/math/vectors/specialization/specialization.factor
View File

@ -7,13 +7,14 @@ namespaces assocs fry splitting classes.algebra generalizations
locals compiler.tree.propagation.info ;
IN: math.vectors.specialization
SYMBOLS: -> +vector+ +scalar+ +nonnegative+ +literal+ ;
SYMBOLS: -> +vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
: signature-for-schema ( array-type elt-type schema -- signature )
[
{
{ +vector+ [ drop ] }
{ +scalar+ [ nip ] }
{ +boolean+ [ 2drop boolean ] }
{ +nonnegative+ [ nip ] }
{ +literal+ [ 2drop f ] }
} case
@ -32,6 +33,7 @@ SYMBOLS: -> +vector+ +scalar+ +nonnegative+ +literal+ ;
{
{ +vector+ [ drop <class-info> ] }
{ +scalar+ [ nip <class-info> ] }
{ +boolean+ [ 2drop boolean <class-info> ] }
{
+nonnegative+
[
@ -115,9 +117,9 @@ H{
{ v> { +vector+ +vector+ -> +vector+ } }
{ v>= { +vector+ +vector+ -> +vector+ } }
{ vunordered? { +vector+ +vector+ -> +vector+ } }
{ vany? { +vector+ -> +scalar+ } }
{ vall? { +vector+ -> +scalar+ } }
{ vnone? { +vector+ -> +scalar+ } }
{ vany? { +vector+ -> +boolean+ } }
{ vall? { +vector+ -> +boolean+ } }
{ vnone? { +vector+ -> +boolean+ } }
}
PREDICATE: vector-word < word vector-words key? ;

3
basis/specialized-arrays/specialized-arrays-tests.factor
View File

@ -36,6 +36,9 @@ SPECIALIZED-ARRAYS: bool ushort char uint float ulonglong ;
int-array{ 3 1 3 3 7 } malloc-byte-array 5 <direct-int-array> >array
] unit-test
[ float-array{ HEX: 1.222,222 HEX: 1.111,112 } ]
[ float-array{ HEX: 1.222,222,2 HEX: 1.111,111,1 } ] unit-test
[ f ] [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] unit-test
[ f ] [ [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] compile-call ] unit-test

4
basis/tools/deploy/deploy-tests.factor
View File

@ -112,4 +112,6 @@ os macosx? [
{ "a" "b" "c" } append
ascii [ lines ] with-process-reader
rest
] unit-test
] unit-test
[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test

10
basis/tools/deploy/shaker/shaker.factor
View File

@ -85,6 +85,13 @@ IN: tools.deploy.shaker
run-file
] when ;
: strip-specialized-arrays ( -- )
strip-dictionary? "specialized-arrays" vocab and [
"Stripping specialized arrays" show
"vocab:tools/deploy/shaker/strip-specialized-arrays.factor"
run-file
] when ;
: strip-word-names ( words -- )
"Stripping word names" show
[ f >>name f >>vocabulary drop ] each ;
@ -180,6 +187,8 @@ IN: tools.deploy.shaker
"transform-n"
"transform-quot"
"type"
"typed-def"
"typed-word"
"writer"
"writing"
} %
@ -503,6 +512,7 @@ SYMBOL: deploy-vocab
strip-call
strip-cocoa
strip-debugger
strip-specialized-arrays
compute-next-methods
strip-init-hooks
add-command-line-hook

5
basis/tools/deploy/shaker/strip-specialized-arrays.factor Normal file
View File

@ -0,0 +1,5 @@
IN: specialized-arrays
ERROR: cannot-define-array-in-deployed-app type ;
: define-array-vocab ( type -- ) cannot-define-array-in-deployed-app ;

8
basis/tools/deploy/test/16/16.factor Normal file
View File

@ -0,0 +1,8 @@
IN: tools.deploy.test.16
USING: typed sequences math strings io ;
TYPED: typed-test ( x: integer y: string -- ) <repetition> concat print ;
: typed-main ( -- ) 3 "hi" typed-test ;
MAIN: typed-main

14
basis/tools/deploy/test/16/deploy.factor Normal file
View File

@ -0,0 +1,14 @@
USING: tools.deploy.config ;
H{
{ deploy-name "tools.deploy.test.16" }
{ deploy-ui? f }
{ deploy-c-types? f }
{ deploy-unicode? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-math? f }
{ deploy-threads? f }
{ deploy-word-defs? f }
}

2
basis/tools/deploy/test/test.factor
View File

@ -15,7 +15,7 @@ IN: tools.deploy.test
[
cell 4 / *
cpu ppc? [ 100000 + ] when
os windows? [ 150000 + ] when
os windows? [ 250000 + ] when
] bi*
<= ;

0
extra/typed/authors.txt → basis/typed/authors.txt
View File

0
extra/typed/debugger/debugger.factor → basis/typed/debugger/debugger.factor
View File

11
basis/typed/prettyprint/prettyprint.factor Normal file
View File

@ -0,0 +1,11 @@
USING: definitions kernel locals.definitions see see.private typed words ;
IN: typed.prettyprint
PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
M: typed-word definer drop \ TYPED: \ ; ;
M: typed-lambda-word definer drop \ TYPED:: \ ; ;
M: typed-word definition "typed-def" word-prop ;
M: typed-word declarations. "typed-word" word-prop declarations. ;

0
extra/typed/summary.txt → basis/typed/summary.txt
View File

69
basis/typed/typed-docs.factor Normal file
View File

@ -0,0 +1,69 @@
! (c)2009 Joe Groff bsd license
USING: arrays effects help.markup help.syntax locals math quotations words ;
IN: typed
HELP: TYPED:
{ $syntax
"""TYPED: word ( a b: class ... -- x: class y ... )
body ;""" }
{ $description "Like " { $link POSTPONE: : } ", defines a new word with a given stack effect in the current vocabulary. The inputs and outputs of the stack effect can additionally be given type annotations in the form " { $snippet "a: class" } ". When invoked, the word will attempt to coerce its input values to the declared input types before executing the body, throwing an " { $link input-mismatch-error } " if the types cannot be made to match. The word will likewise attempt to coerce its outputs to their declared types and throw an " { $link output-mismatch-error } " if the types cannot be made to match." }
{ $notes "The aforementioned type conversions and checks are structured in such a way that they will be eliminated by the compiler if it can statically determine that the types of the inputs at a call site or of the outputs in the word definition are always correct." }
{ $examples
"A version of " { $link + } " specialized for floats, converting other real number types:"
{ $example
"""USING: math prettyprint typed ;
IN: scratchpad
TYPED: add-floats ( a: float b: float -- c: float )
+ ;
1 2+1/2 add-floats ."""
"3.5" } } ;
HELP: TYPED::
{ $syntax
"""TYPED:: word ( a b: class ... -- x: class y ... )
body ;""" }
{ $description "Like " { $link POSTPONE: :: } ", defines a new word with named inputs in the current vocabulary. The inputs and outputs of the stack effect can additionally be given type annotations in the form " { $snippet "a: class" } ". When invoked, the word will attempt to coerce its input values to the declared input types before executing the body, throwing an " { $link input-mismatch-error } " if the types cannot be made to match. The word will likewise attempt to coerce its outputs to their declared types and throw an " { $link output-mismatch-error } " if the types cannot be made to match." }
{ $notes "The aforementioned type conversions and checks are structured in such a way that they will be eliminated by the compiler if it can statically determine that the types of the inputs at a call site or of the outputs in the word definition are always correct." }
{ $examples
"A version of the quadratic formula specialized for floats, converting other real number types:"
{ $example
"""USING: kernel math math.libm prettyprint typed ;
IN: scratchpad
TYPED:: quadratic-roots ( a: float b: float c: float -- q1: float q2: float )
b neg
b sq 4.0 a * c * - fsqrt
[ + ] [ - ] 2bi
[ 2.0 a * / ] bi@ ;
1 0 -9/4 quadratic-roots [ . ] bi@"""
"""1.5
-1.5""" } } ;
HELP: define-typed
{ $values { "word" word } { "def" quotation } { "effect" effect } }
{ $description "The runtime equivalent to " { $link POSTPONE: TYPED: } " and " { $link POSTPONE: TYPED:: } ". Defines " { $snippet "word" } " with " { $snippet "def" } " as its body and " { $snippet "effect" } " as its stack effect. The word will check that its inputs and outputs correspond to the types specified in " { $snippet "effect" } " as described in the " { $link POSTPONE: TYPED: } " documentation." } ;
HELP: input-mismatch-error
{ $values { "word" word } { "expected-types" array } }
{ $class-description "Errors of this class are raised at runtime by " { $link POSTPONE: TYPED: } " words when they are invoked with input values that do not match their type annotations. The " { $snippet "word" } " slot indicates the word that failed, and the " { $snippet "expected-types" } " slot specifies the input types expected." } ;
HELP: output-mismatch-error
{ $values { "word" word } { "expected-types" array } }
{ $class-description "Errors of this class are raised at runtime by " { $link POSTPONE: TYPED: } " words when they attempt to output values that do not match their type annotations. The " { $snippet "word" } " slot indicates the word that failed, and the " { $snippet "expected-types" } " slot specifies the output types expected." } ;
{ POSTPONE: TYPED: POSTPONE: TYPED:: define-typed } related-words
ARTICLE: "typed" "Strongly-typed word definitions"
"The Factor compiler supports advanced compiler optimizations that take advantage of the type information it can glean from source code. The " { $vocab-link "typed" } " vocabulary provides syntax that allows words to provide checked type information about their inputs and outputs and improve the performance of compiled code."
{ $subsections
POSTPONE: TYPED:
POSTPONE: TYPED::
define-typed
input-mismatch-error
output-mismatch-error
} ;
ABOUT: "typed"

0
extra/typed/typed-tests.factor → basis/typed/typed-tests.factor
View File

35
extra/typed/typed.factor → basis/typed/typed.factor
View File

@ -2,7 +2,7 @@
USING: accessors arrays classes classes.tuple combinators
combinators.short-circuit definitions effects fry hints
math kernel kernel.private namespaces parser quotations
see.private sequences slots words locals locals.definitions
sequences slots words locals
locals.parser macros stack-checker.state ;
IN: typed
@ -10,6 +10,11 @@ ERROR: type-mismatch-error word expected-types ;
ERROR: input-mismatch-error < type-mismatch-error ;
ERROR: output-mismatch-error < type-mismatch-error ;
PREDICATE: typed-gensym < word "typed-gensym" word-prop ;
PREDICATE: typed-word < word "typed-word" word-prop ;
<PRIVATE
: unboxable-tuple-class? ( type -- ? )
{
[ all-slots empty? not ]
@ -93,9 +98,7 @@ MACRO: (typed) ( word def effect -- quot )
dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
] 2bi ;
PREDICATE: typed-gensym < word "typed-gensym" word-prop ;
: typed-gensym ( parent-word -- word )
: <typed-gensym> ( parent-word -- word )
[ name>> "( typed " " )" surround f <word> dup ]
[ "typed-gensym" set-word-prop ] bi ;
@ -103,21 +106,16 @@ PREDICATE: typed-gensym < word "typed-gensym" word-prop ;
[ effect-in-types unboxed-types [ "in" swap 2array ] map ]
[ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi <effect> ;
PREDICATE: typed-standard-word < word "typed-word" word-prop ;
PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
M: typed-gensym stack-effect
call-next-method unboxed-effect ;
M: typed-gensym crossref?
"typed-gensym" word-prop crossref? ;
: define-typed-gensym ( word def effect -- gensym )
[ 2drop typed-gensym dup ]
[ 2drop <typed-gensym> dup ]
[ [ (typed) ] 3curry ]
[ 2nip ] 3tri define-declared ;
UNION: typed-word typed-standard-word typed-lambda-word ;
MACRO: typed ( quot word effect -- quot' )
[ effect-in-types (depends-on) dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
[
@ -136,6 +134,12 @@ MACRO: typed ( quot word effect -- quot' )
[ effect-out-types typed-stack-effect? ]
} 1|| [ (typed-def) ] [ drop nip ] if ;
M: typed-word subwords
[ call-next-method ]
[ "typed-word" word-prop ] bi suffix ;
PRIVATE>
: define-typed ( word def effect -- )
[ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
[ drop "typed-def" set-word-prop ]
@ -146,13 +150,6 @@ SYNTAX: TYPED:
SYNTAX: TYPED::
(::) define-typed ;
M: typed-standard-word definer drop \ TYPED: \ ; ;
M: typed-lambda-word definer drop \ TYPED:: \ ; ;
M: typed-word definition "typed-def" word-prop ;
M: typed-word declarations. "typed-word" word-prop declarations. ;
M: typed-word subwords
[ call-next-method ]
[ "typed-word" word-prop ] bi suffix ;
USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "typed.prettyprint" require ] when

4
core/io/backend/backend.factor
View File

@ -21,9 +21,9 @@ HOOK: init-stdio io-backend ( -- )
HOOK: io-multiplex io-backend ( us -- )
HOOK: normalize-directory io-backend ( str -- newstr )
HOOK: normalize-directory io-backend ( path -- path' )
HOOK: normalize-path io-backend ( str -- newstr )
HOOK: normalize-path io-backend ( path -- path' )
M: object normalize-directory normalize-path ;

64
core/io/pathnames/pathnames-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io.backend io.files io.directories strings
sequences ;
sequences io.pathnames.private ;
IN: io.pathnames
HELP: path-separator?
@ -46,12 +46,24 @@ HELP: path-components
{ $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ;
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ;
{ $values { "path1" "a pathname string" } { "path2" "a pathname string" } { "path" "a pathname string" } }
{ $description "Appends " { $snippet "path1" } " and " { $snippet "path2" } " to form a pathname." }
{ $examples
{ $unchecked-example """USING: io.pathnames prettyprint ;
"first" "second.txt" append-path ."""
"first/second.txt"
}
} ;
HELP: prepend-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Appends " { $snippet "str2" } " and " { $snippet "str1" } " to form a pathname." } ;
{ $values { "path1" "a pathname string" } { "path2" "a pathname string" } { "path" "a pathname string" } }
{ $description "Appends " { $snippet "path2" } " and " { $snippet "path1" } " to form a pathname." }
{ $examples
{ $unchecked-example """USING: io.pathnames prettyprint ;
"second.txt" "first" prepend-path ."""
"first/second.txt"
}
} ;
{ append-path prepend-path } related-words
@ -77,9 +89,10 @@ HELP: pathname
{ $class-description "Class of path name objects. Path name objects can be created by calling " { $link <pathname> } "." } ;
HELP: normalize-path
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Prepends the " { $link current-directory } " to the pathname, resolves a " { $snippet "resource:" } " prefix, if present, and performs any platform-specific pathname normalization." }
{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } }
{ $description "Prepends the " { $link current-directory } " to the pathname, resolves a " { $snippet "resource:" } " or " { $snippet "voacb:" } " prefix, if present, and performs any platform-specific pathname normalization." }
{ $notes "High-level words, such as " { $link <file-reader> } " and " { $link delete-file } " call this word for you. It only needs to be called directly when passing pathnames to C functions or external processes. This is because Factor does not use the operating system's notion of a current directory, and instead maintains its own dynamically-scoped " { $link current-directory } " variable." }
{ $notes "On Windows NT platforms, this word does prepends the Unicode path prefix." }
{ $examples
"For example, if you create a file named " { $snippet "data.txt" } " in the current directory, and wish to pass it to a process, you must normalize it:"
{ $code
@ -88,9 +101,18 @@ HELP: normalize-path
}
} ;
HELP: (normalize-path)
{ $values
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Prepends the " { $link current-directory } " to the pathname and resolves a " { $snippet "resource:" } " prefix, if present." }
{ $notes "On Windows NT platforms, this word does not prepend the Unicode path prefix." } ;
HELP: canonicalize-path
{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } }
{ $description "Returns an canonical name for a path. The canonical name is an absolute path containing no symlinks." } ;
{ $description "Outputs a path where none of the path components are symlinks. This word is useful for determining the actual path on disk where a file is stored; the root of this absolute path is a mount point in the file-system." }
{ $notes "Most code should not need to call this word except in very special circumstances. One use case is finding the actual file-system on which a file is stored." } ;
HELP: <pathname>
{ $values { "string" "a pathname string" } { "pathname" pathname } }
@ -98,20 +120,28 @@ HELP: <pathname>
HELP: home
{ $values { "dir" string } }
{ $description "Outputs the user's home directory." } ;
{ $description "Outputs the user's home directory." }
{ $examples
{ $unchecked-example "USING: io.pathnames prettyprint ;"
"home ."
"/home/factor-user"
}
} ;
ARTICLE: "io.pathnames" "Pathname manipulation"
"Pathname manipulation:"
ARTICLE: "io.pathnames" "Pathnames"
"Pathnames are objects that contain a string representing the path to a file on disk. Pathnames are cross-platform; Windows accepts both forward and backward slashes as directory separators and new separators are added as a forward slash on all platforms. Clicking a pathname object in the UI brings up the file in one of the supported editors, but otherwise, pathnames and strings are interchangeable. See " { $link "editor" } " for more details." $nl
"Pathname introspection:"
{ $subsections
parent-directory
file-name
file-stem
file-extension
last-path-separator
path-components
}
"Appending pathnames:"
{ $subsections
prepend-path
append-path
canonicalize-path
}
"Pathname presentations:"
{ $subsections
@ -120,7 +150,11 @@ ARTICLE: "io.pathnames" "Pathname manipulation"
}
"Literal pathnames:"
{ $subsections POSTPONE: P" }
"Low-level word:"
{ $subsections normalize-path } ;
"Low-level words:"
{ $subsections
normalize-path
(normalize-path)
canonicalize-path
} ;
ABOUT: "io.pathnames"

2
core/io/pathnames/pathnames-tests.factor
View File

@ -1,6 +1,6 @@
USING: io.pathnames io.files.temp io.directories
continuations math io.files.private kernel
namespaces tools.test ;
namespaces tools.test io.pathnames.private ;
IN: io.pathnames.tests
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test

12
core/io/pathnames/pathnames.factor
View File

@ -10,10 +10,10 @@ SYMBOL: current-directory
: path-separator ( -- string ) os windows? "\\" "/" ? ;
: trim-tail-separators ( str -- newstr )
: trim-tail-separators ( string -- string' )
[ path-separator? ] trim-tail ;
: trim-head-separators ( str -- newstr )
: trim-head-separators ( string -- string' )
[ path-separator? ] trim-head ;
: last-path-separator ( path -- n ? )
@ -61,8 +61,6 @@ ERROR: no-parent-directory path ;
[ nip ]
} cond ;
PRIVATE>
: windows-absolute-path? ( path -- path ? )
{
{ [ dup "\\\\?\\" head? ] [ t ] }
@ -87,7 +85,9 @@ PRIVATE>
[ f ]
} cond nip ;
: append-path ( str1 str2 -- str )
PRIVATE>
: append-path ( path1 path2 -- path )
{
{ [ over empty? ] [ append-path-empty ] }
{ [ dup empty? ] [ drop ] }
@ -107,7 +107,7 @@ PRIVATE>
]
} cond ;
: prepend-path ( str1 str2 -- str )
: prepend-path ( path1 path2 -- path )
swap append-path ; inline
: file-name ( path -- string )

4
core/syntax/syntax-docs.factor
View File

@ -371,7 +371,7 @@ HELP: POSTPONE:
HELP: :
{ $syntax ": word ( stack -- effect ) definition... ;" }
{ $values { "word" "a new word to define" } { "definition" "a word definition" } }
{ $description "Defines a word with the given stack effect in the current vocabulary. The stack effect is optional for words which only push literals on the stack." }
{ $description "Defines a word with the given stack effect in the current vocabulary." }
{ $examples { $code ": ask-name ( -- name )\n \"What is your name? \" write readln ;\n: greet ( name -- )\n \"Greetings, \" write print ;\n: friend ( -- )\n ask-name greet ;" } } ;
{ POSTPONE: : POSTPONE: ; define } related-words
@ -574,7 +574,7 @@ HELP: SBUF"
HELP: P"
{ $syntax "P\" pathname\"" }
{ $values { "pathname" "a pathname string" } }
{ $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", creates a new " { $link pathname } ", and appends it to the parse tree." }
{ $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", creates a new " { $link pathname } ", and appends it to the parse tree. Pathnames presented in the UI are clickable, which opens them in a text editor configured with " { $link "editor" } "." }
{ $examples { $example "USING: accessors io io.files ;" "P\" foo.txt\" string>> print" "foo.txt" } } ;
HELP: (

24
extra/alien/data/map/map-tests.factor
View File

@ -1,6 +1,6 @@
! (c)Joe Groff bsd license
USING: alien.data.map fry generalizations kernel locals math.vectors
math.vectors.conversion math math.vectors.simd
math.vectors.conversion math math.vectors.simd sequences
specialized-arrays tools.test ;
FROM: alien.c-types => uchar short int float ;
SIMDS: float int short uchar ;
@ -13,6 +13,28 @@ IN: alien.data.map.tests
byte-array>float-array
] unit-test
[
float-4-array{
float-4{ 0.0 0.0 0.0 0.0 }
float-4{ 1.0 1.0 1.0 1.0 }
float-4{ 2.0 2.0 2.0 2.0 }
}
] [
3 iota [ float-4-with ] data-map( object -- float-4 )
byte-array>float-4-array
] unit-test
[
float-4-array{
float-4{ 0.0 1.0 2.0 3.0 }
float-4{ 4.0 5.0 6.0 7.0 }
float-4{ 8.0 9.0 10.0 11.0 }
}
] [
12 iota [ float-4-boa ] data-map( object[4] -- float-4 )
byte-array>float-4-array
] unit-test
[ float-array{ 1.0 1.0 3.0 3.0 5.0 5.0 0.0 0.0 } ]
[
int-array{ 1 3 5 } float-array{ 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 }

48
extra/alien/data/map/map.factor
View File

@ -1,6 +1,6 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data alien.parser arrays
byte-arrays combinators effects.parser fry generalizations kernel
byte-arrays combinators effects.parser fry generalizations grouping kernel
lexer locals macros make math math.ranges parser sequences sequences.private ;
FROM: alien.arrays => array-length ;
IN: alien.data.map
@ -19,8 +19,6 @@ TUPLE: data-map-param
{ iter-length fixnum read-only }
{ iter-count fixnum read-only } ;
ERROR: bad-data-map-param param remainder ;
M: data-map-param length
iter-count>> ; inline
@ -34,12 +32,14 @@ M: data-map-param nth-unsafe
INSTANCE: data-map-param immutable-sequence
: c-type-count ( in/out -- c-type count iter-length )
dup array? [ unclip swap array-length >fixnum ] [ 1 ] if
2dup swap heap-size * >fixnum ; inline
: c-type-count ( in/out -- c-type count )
dup array? [ unclip swap array-length >fixnum ] [ 1 ] if ; inline
MACRO: >param ( in -- quot: ( array -- param ) )
c-type-count '[
: c-type-iter-length ( c-type count -- iter-length )
swap heap-size * >fixnum ; inline
: [>c-type-param] ( c-type count -- quot )
2dup c-type-iter-length '[
[ _ _ ] dip
[ ]
[ >c-ptr ]
@ -49,8 +49,18 @@ MACRO: >param ( in -- quot: ( array -- param ) )
data-map-param boa
] ;
MACRO: alloc-param ( out -- quot: ( len -- param ) )
c-type-count dup '[
: [>object-param] ( class count -- quot )
nip '[ _ <sliced-groups> ] ;
: [>param] ( type -- quot )
c-type-count over c-type-name?
[ [>c-type-param] ] [ [>object-param] ] if ;
MACRO: >param ( in -- quot: ( array -- param ) )
[>param] ;
: [alloc-c-type-param] ( c-type count -- quot )
2dup c-type-iter-length dup '[
[ _ _ ] dip
[
_ * >fixnum [ (byte-array) dup ] keep
@ -59,11 +69,21 @@ MACRO: alloc-param ( out -- quot: ( len -- param ) )
data-map-param boa
] ;
: [alloc-object-param] ( type count -- quot )
"Factor sequences as data-map outputs not supported" throw ;
: [alloc-param] ( type -- quot )
c-type-count over c-type-name?
[ [alloc-c-type-param] ] [ [alloc-object-param] ] if ;
MACRO: alloc-param ( out -- quot: ( len -- param ) )
[alloc-param] ;
MACRO: unpack-params ( ins -- )
[ c-type-count drop nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ;
[ c-type-count nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ;
MACRO: pack-params ( outs -- )
[ ] [ c-type-count drop nip dup [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
[ ] [ c-type-count nip dup [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
fry [ call ] compose ;
:: [data-map] ( ins outs param-quot -- quot )
@ -97,8 +117,8 @@ MACRO: data-map! ( ins outs -- )
: parse-data-map-effect ( accum -- accum )
")" parse-effect
[ in>> [ parse-c-type ] map parsed ]
[ out>> [ parse-c-type ] map parsed ] bi ;
[ in>> [ (parse-c-type) ] map parsed ]
[ out>> [ (parse-c-type) ] map parsed ] bi ;
PRIVATE>

50
extra/gpu/shaders/shaders.factor
View File

@ -432,33 +432,49 @@ PRIVATE>
: <program-instance> ( program -- instance )
[ find-program-instance dup world get ] keep instances>> set-at ;
<PRIVATE
: old-instances ( name -- instances )
dup constant? [
execute( -- s/p ) dup { [ shader? ] [ program? ] } 1||
[ instances>> ] [ drop H{ } clone ] if
] [ drop H{ } clone ] if ;
PRIVATE>
SYNTAX: GLSL-SHADER:
CREATE-WORD dup
scan-word
f
lexer get line>>
parse-here
H{ } clone
CREATE dup
dup old-instances [
scan-word
f
lexer get line>>
parse-here
] dip
shader boa
over reset-generic
define-constant ;
SYNTAX: GLSL-SHADER-FILE:
CREATE-WORD dup
scan-word execute( -- kind )
scan-object in-word's-path
0
over ascii file-contents
H{ } clone
CREATE dup
dup old-instances [
scan-word execute( -- kind )
scan-object in-word's-path
0
over ascii file-contents
] dip
shader boa
over reset-generic
define-constant ;
SYNTAX: GLSL-PROGRAM:
CREATE-WORD dup
f
lexer get line>>
\ ; parse-until >array shaders-and-feedback-format
H{ } clone
CREATE dup
dup old-instances [
f
lexer get line>>
\ ; parse-until >array shaders-and-feedback-format
] dip
program boa
over reset-generic
define-constant ;
M: shader-instance dispose

29
extra/grid-meshes/grid-meshes.factor
View File

@ -1,31 +1,26 @@
! (c)2009 Joe Groff bsd license
USING: accessors arrays destructors kernel math opengl
opengl.gl sequences sequences.product specialized-arrays ;
USING: accessors alien.data.map arrays destructors fry grouping
kernel math math.ranges math.vectors.simd opengl opengl.gl sequences
sequences.product specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SIMD: float
SPECIALIZED-ARRAY: float-4
IN: grid-meshes
TUPLE: grid-mesh dim buffer row-length ;
<PRIVATE
: vertex-array-vertex ( dim x z -- vertex )
[ swap first /f ]
[ swap second /f ] bi-curry* bi
[ 0 ] dip float-array{ } 3sequence ;
: vertex-array-row ( dim z -- vertices )
dup 1 + 2array
over first 1 + iota
2array [ first2 swap vertex-array-vertex ] with product-map
concat ;
: vertex-array-row ( range z0 z1 -- vertices )
'[ _ _ [ 0.0 swap 1.0 float-4-boa ] bi-curry@ bi ]
data-map( object -- float-4[2] ) ; inline
: vertex-array ( dim -- vertices )
dup second iota
[ vertex-array-row ] with map concat ;
first2 [ [ 0.0 1.0 1.0 ] dip /f <range> ] bi@
2 <sliced-clumps> [ first2 vertex-array-row ] with map concat ;
: >vertex-buffer ( bytes -- buffer )
[ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ;
[ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ; inline
: draw-vertex-buffer-row ( grid-mesh i -- )
swap [ GL_TRIANGLE_STRIP ] 2dip
@ -36,7 +31,7 @@ PRIVATE>
: draw-grid-mesh ( grid-mesh -- )
GL_ARRAY_BUFFER over buffer>> [
[ 3 GL_FLOAT 0 f glVertexPointer ] dip
[ 4 GL_FLOAT 0 f glVertexPointer ] dip
dup dim>> second iota [ draw-vertex-buffer-row ] with each
] with-gl-buffer ;

61
extra/noise/noise.factor
View File

@ -4,32 +4,13 @@ math.libm math.matrices.simd math.vectors math.vectors.conversion math.vectors.s
memoize random random.mersenne-twister sequences sequences.private specialized-arrays
typed ;
QUALIFIED-WITH: alien.c-types c
SIMDS: c:float c:int c:short c:uchar ;
SIMDS: c:float c:int c:short c:ushort c:uchar ;
SPECIALIZED-ARRAYS: c:float c:uchar float-4 uchar-16 ;
IN: noise
: with-seed ( seed quot -- )
[ <mersenne-twister> ] dip with-random ; inline
: random-int-4 ( -- v )
16 random-bytes underlying>> int-4 boa ; inline
: (random-float-4) ( -- v )
random-int-4 int-4 float-4 vconvert ; inline
! XXX redundant add
: uniform-random-float-4 ( min max -- n )
(random-float-4) (random-float-4)
2.0 31 ^ v+n 2.0 32 ^ v*n v+
[ over - 2.0 -64 ^ * ] dip n*v n+v ; inline
: normal-random-float-4 ( mean sigma -- n )
0.0 1.0 uniform-random-float-4
0.0 1.0 uniform-random-float-4
[ 2 pi * v*n [ fcos ] map ]
[ 1.0 swap n-v [ flog ] map -2.0 v*n vsqrt ]
bi* v* n*v n+v ; inline
: float-map>byte-map ( floats: float-array scale: float bias: float -- bytes: byte-array )
'[
[ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply
@ -37,32 +18,34 @@ IN: noise
short-8 uchar-16 vconvert
] data-map( float-4[4] -- uchar-16 ) ; inline
TYPED:: float-map>image ( floats: float-array dim scale: float bias: float -- image: image )
TYPED: byte-map>image ( bytes: byte-array dim -- image: image )
image new
dim >>dim
floats scale bias float-map>byte-map >>bitmap
swap >>dim
swap >>bitmap
L >>component-order
ubyte-components >>component-type ;
TYPED: uniform-noise-map ( seed: integer dim -- map: float-array )
'[
_ product 4 / [ 0.0 1.0 uniform-random-float-4 ]
float-4-array{ } replicate-as
byte-array>float-array
] with-seed ;
:: float-map>image ( floats: float-array dim scale: float bias: float -- image: image )
floats scale bias float-map>byte-map dim byte-map>image ; inline
: uniform-noise-image ( seed dim -- image )
[ uniform-noise-map ] [ 1.0 0.0 float-map>image ] bi ; inline
[ '[ _ product random-bytes >byte-array ] with-seed ]
[ byte-map>image ] bi ; inline
TYPED: normal-noise-map ( seed: integer sigma: float dim -- map: float-array )
swap '[
_ product 4 / [ 0.5 _ normal-random-float-4 ]
float-4-array{ } replicate-as
byte-array>float-array
] with-seed ;
CONSTANT: normal-noise-pow 2
CONSTANT: normal-noise-count 4
: normal-noise-image ( seed sigma dim -- image )
[ normal-noise-map ] [ 1.0 0.0 float-map>image ] bi ; inline
TYPED: normal-noise-map ( seed: integer dim -- bytes )
'[ _ product normal-noise-count * random-bytes >byte-array ] with-seed
[
[ short-8{ 0 0 0 0 0 0 0 0 } short-8{ 0 0 0 0 0 0 0 0 } ] normal-noise-count ndip
[ uchar-16 short-8 vconvert [ v+ ] bi-curry@ bi* ] normal-noise-count napply
[ normal-noise-pow vrshift ] bi@
short-8 uchar-16 vconvert
] data-map( uchar-16[normal-noise-count] -- uchar-16 ) ; inline
: normal-noise-image ( seed dim -- image )
[ normal-noise-map ] [ byte-map>image ] bi ; inline
ERROR: invalid-perlin-noise-table table ;
@ -73,7 +56,7 @@ ERROR: invalid-perlin-noise-table table ;
dup { [ byte-array? ] [ length 512 >= ] } 1&&
[ invalid-perlin-noise-table ] unless ;
! XXX doesn't work for NaNs or very large floats
! XXX doesn't work for NaNs or floats > 2^31
: floor-vector ( v -- v' )
[ float-4 int-4 vconvert int-4 float-4 vconvert ]
[ [ v> -1.0 float-4-with vand ] curry keep v+ ] bi ; inline

9
extra/random/cmwc/cmwc-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel random random.cmwc sequences tools.test ;
USING: alien.c-types arrays kernel random random.cmwc sequences
specialized-arrays specialized-arrays.instances.uint tools.test ;
IN: random.cmwc.tests
[ ] [
@ -24,18 +25,18 @@ IN: random.cmwc.tests
}
] [
cmwc-4096
4096 iota >array 362436 <cmwc-seed> seed-random [
4096 iota >uint-array 362436 <cmwc-seed> seed-random [
10 [ random-32 ] replicate
] with-random
] unit-test
[ t ] [
cmwc-4096 [
4096 iota >array 362436 <cmwc-seed> seed-random [
4096 iota >uint-array 362436 <cmwc-seed> seed-random [
10 [ random-32 ] replicate
] with-random
] [
4096 iota >array 362436 <cmwc-seed> seed-random [
4096 iota >uint-array 362436 <cmwc-seed> seed-random [
10 [ random-32 ] replicate
] with-random
] bi =

42
extra/random/cmwc/cmwc.factor
View File

@ -1,28 +1,34 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays fry kernel locals math math.bitwise
random sequences ;
USING: accessors alien.c-types arrays fry kernel locals math
math.bitwise random sequences sequences.private
specialized-arrays specialized-arrays.instances.uint ;
IN: random.cmwc
! Multiply-with-carry RNG
TUPLE: cmwc Q a b c i r mod ;
TUPLE: cmwc
{ Q uint-array }
{ a integer }
{ b integer }
{ c integer }
{ i integer }
{ r integer }
{ mod fixnum } ;
TUPLE: cmwc-seed Q c ;
TUPLE: cmwc-seed { Q uint-array read-only } { c read-only } ;
: <cmwc> ( length a b c -- cmwc )
cmwc new
swap >>c
swap >>b
swap >>a
swap [ 1 - >>i ] [ 0 <array> >>Q ] bi
swap [ 1 - >>i ] [ <uint-array> >>Q ] bi
dup b>> 1 - >>r
dup Q>> length 1 - >>mod ;
dup Q>> length 1 - >>mod ; inline
: <cmwc-seed> ( Q c -- cmwc-seed )
cmwc-seed new
swap >>c
swap >>Q ; inline
cmwc-seed boa ; inline
M: cmwc seed-random
[ Q>> >>Q ]
@ -32,23 +38,25 @@ M: cmwc seed-random
M:: cmwc random-32* ( cmwc -- n )
cmwc dup mod>> '[ 1 + _ bitand ] change-i
[ a>> ]
[ [ i>> ] [ Q>> ] bi nth * ]
[ c>> + ] tri :> t!
[ [ i>> ] [ Q>> ] bi nth-unsafe * ]
[ c>> + ] tri
t -32 shift cmwc (>>c)
[ >fixnum -32 shift cmwc (>>c) ]
[ cmwc [ b>> bitand ] [ c>> + ] bi 32 bits ] bi
t cmwc [ b>> bitand ] [ c>> + ] bi 64 bits t!
t cmwc r>> > [
dup cmwc r>> > [
cmwc [ 1 + ] change-c drop
t cmwc b>> - 64 bits t!
cmwc b>> - 32 bits
] when
cmwc [ r>> t - 32 bits dup ] [ i>> ] [ Q>> ] tri set-nth ;
cmwc swap '[ r>> _ - 32 bits dup ] [ i>> ] [ Q>> ] tri set-nth-unsafe ;
: cmwc-4096 ( -- cmwc )
4096
[ 18782 4294967295 362436 <cmwc> ]
[
'[ [ random-32 ] replicate ] with-system-random
'[ [ random-32 ] uint-array{ } replicate-as ] with-system-random
362436 <cmwc-seed> seed-random
] bi ;
: default-cmwc ( -- cmwc ) cmwc-4096 ;

32
extra/random/lagged-fibonacci/lagged-fibonacci.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types fry kernel literals locals math
random sequences specialized-arrays namespaces ;
random sequences specialized-arrays namespaces sequences.private ;
SPECIALIZED-ARRAY: double
IN: random.lagged-fibonacci
TUPLE: lagged-fibonacci u pt0 pt1 ;
TUPLE: lagged-fibonacci { u double-array } { pt0 fixnum } { pt1 fixnum } ;
<PRIVATE
@ -17,10 +17,10 @@ CONSTANT: lagged-fibonacci-max-seed 900000000
CONSTANT: lagged-fibonacci-sig-bits 24
: normalize-seed ( seed -- seed' )
abs lagged-fibonacci-max-seed mod ;
abs lagged-fibonacci-max-seed mod ; inline
: adjust-ptr ( ptr -- ptr' )
1 - dup 0 < [ drop p-r ] when ;
1 - dup 0 < [ drop p-r ] when ; inline
PRIVATE>
@ -50,22 +50,26 @@ M:: lagged-fibonacci seed-random ( lagged-fibonacci seed! -- lagged-fibonacci )
s
] change-each
lagged-fibonacci p-r >>pt0
q-r >>pt1 ;
q-r >>pt1 ; inline
: <lagged-fibonacci> ( seed -- lagged-fibonacci )
lagged-fibonacci new
p-r 1 + <double-array> >>u
swap seed-random ;
swap seed-random ; inline
GENERIC: random-float* ( tuple -- r )
: random-float ( -- n ) random-generator get random-float* ;
: random-float ( -- n ) random-generator get random-float* ; inline
M:: lagged-fibonacci random-float* ( lagged-fibonacci -- x )
lagged-fibonacci [ pt0>> ] [ u>> ] bi nth
lagged-fibonacci [ pt1>> ] [ u>> ] bi nth - :> uni!
uni 0.0 < [ uni 1.0 + uni! ] when
uni lagged-fibonacci [ pt0>> ] [ u>> ] bi set-nth
lagged-fibonacci [ adjust-ptr ] change-pt0 drop
lagged-fibonacci [ adjust-ptr ] change-pt1 drop
uni ; inline
lagged-fibonacci [ pt0>> ] [ u>> ] bi nth-unsafe
lagged-fibonacci [ pt1>> ] [ u>> ] bi nth-unsafe -
dup 0.0 < [ 1.0 + ] when
[
lagged-fibonacci [ pt0>> ] [ u>> ] bi set-nth-unsafe
lagged-fibonacci [ adjust-ptr ] change-pt0 drop
lagged-fibonacci [ adjust-ptr ] change-pt1 drop
] keep ; inline
: default-lagged-fibonacci ( -- obj )
[ random-32 ] with-system-random <lagged-fibonacci> ; inline

16
extra/terrain/deploy.factor
View File

@ -1,14 +1,14 @@
USING: tools.deploy.config ;
H{
{ deploy-ui? t }
{ deploy-reflection 1 }
{ deploy-unicode? f }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-c-types? f }
{ deploy-name "Terrain" }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-ui? t }
{ deploy-c-types? f }
{ deploy-unicode? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-math? t }
{ deploy-threads? t }
{ deploy-word-defs? f }
}

8
extra/terrain/generation/generation.factor
View File

@ -1,13 +1,13 @@
USING: accessors alien.data.map arrays byte-arrays combinators
combinators.smart fry grouping images kernel math
math.matrices.simd math.order math.vectors noise random
sequences math.vectors.simd ;
sequences math.vectors.simd typed ;
FROM: alien.c-types => float uchar ;
SIMDS: float uchar ;
IN: terrain.generation
CONSTANT: terrain-segment-size { 512 512 }
CONSTANT: terrain-segment-size-vector { 512.0 512.0 1.0 1.0 }
CONSTANT: terrain-segment-size-vector float-4{ 512.0 512.0 1.0 1.0 }
CONSTANT: terrain-big-noise-scale float-4{ 0.002 0.002 0.002 0.002 }
CONSTANT: terrain-small-noise-scale float-4{ 0.05 0.05 0.05 0.05 }
@ -32,7 +32,7 @@ TUPLE: terrain
terrain-segment-size-vector v* translation-matrix4 m4.
terrain-segment-size perlin-noise-image bitmap>> ; inline
: tiny-noise-segment ( terrain at -- bytes )
[ tiny-noise-seed>> ] dip seed-at 0.1
[ tiny-noise-seed>> ] dip seed-at
terrain-segment-size normal-noise-image bitmap>> ; inline
: padding ( terrain at -- padding )
2drop terrain-segment-size product 255 <repetition> >byte-array ; inline
@ -51,7 +51,7 @@ TUPLE: segment image ;
ubyte-components >>component-type
terrain-segment-size >>dim ;
: terrain-segment ( terrain at -- image )
TYPED: terrain-segment ( terrain: terrain at: float-4 -- image )
{
[ big-noise-segment ]
[ small-noise-segment ]

26
extra/terrain/terrain.factor
View File

@ -20,6 +20,7 @@ CONSTANT: FAR-PLANE 2.0
CONSTANT: PLAYER-START-LOCATION float-4{ 0.5 0.51 0.5 1.0 }
CONSTANT: VELOCITY-MODIFIER-NORMAL float-4{ 1.0 1.0 1.0 0.0 }
CONSTANT: VELOCITY-MODIFIER-FAST float-4{ 2.0 1.0 2.0 0.0 }
CONSTANT: BOUNCE float-4{ 1.0 -0.2 1.0 1.0 }
CONSTANT: PLAYER-HEIGHT 1/256.
CONSTANT: GRAVITY float-4{ 0.0 -1/4096. 0.0 0.0 }
CONSTANT: JUMP 1/1024.
@ -177,10 +178,23 @@ terrain-world H{
indices [ pixels nth COMPONENT-SCALE v. 255.0 / ] map
first4 pixel-mantissa bilerp ;
: collide ( segment location -- location' )
[ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ]
[ [ 1 ] 2dip [ max ] with change-nth ]
[ ] tri ;
: (collide) ( segment location -- location' )
[
{ 0 2 3 3 } vshuffle terrain-height-at PLAYER-HEIGHT +
-1/0. swap -1/0. -1/0. float-4-boa
] keep vmax ;
:: collide ( world player -- )
world terrain-segment>> :> segment
player location>> :> location
segment location (collide) :> location'
location location' = not [
player
location' >>location
[ BOUNCE v* ] change-velocity
drop
] when ;
: scaled-velocity ( player -- velocity )
[ velocity>> ] [ velocity-modifier>> ] bi v* ;
@ -199,8 +213,8 @@ terrain-world H{
: tick-player-forward ( world player -- )
2dup save-history
[ apply-friction apply-gravity ] change-velocity
dup scaled-velocity [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
drop ;
dup scaled-velocity [ v+ ] curry change-location
collide ;
: tick-player ( world player -- )
dup reverse-time>>

12
vm/aging_collector.hpp
View File

@ -2,13 +2,13 @@ namespace factor
{
struct aging_policy {
factor_vm *myvm;
factor_vm *parent;
zone *aging, *tenured;
aging_policy(factor_vm *myvm_) :
myvm(myvm_),
aging(myvm->data->aging),
tenured(myvm->data->tenured) {}
aging_policy(factor_vm *parent_) :
parent(parent_),
aging(parent->data->aging),
tenured(parent->data->tenured) {}
bool should_copy_p(object *untagged)
{
@ -17,7 +17,7 @@ struct aging_policy {
};
struct aging_collector : copying_collector<aging_space,aging_policy> {
aging_collector(factor_vm *myvm_);
aging_collector(factor_vm *parent_);
};
}

66
vm/alien.cpp
View File

@ -12,8 +12,8 @@ char *factor_vm::pinned_alien_offset(cell obj)
case ALIEN_TYPE:
{
alien *ptr = untag<alien>(obj);
if(ptr->expired != F)
general_error(ERROR_EXPIRED,obj,F,NULL);
if(to_boolean(ptr->expired))
general_error(ERROR_EXPIRED,obj,false_object,NULL);
return pinned_alien_offset(ptr->base) + ptr->displacement;
}
case F_TYPE:
@ -40,7 +40,7 @@ cell factor_vm::allot_alien(cell delegate_, cell displacement)
new_alien->base = delegate.value();
new_alien->displacement = displacement;
new_alien->expired = F;
new_alien->expired = false_object;
return new_alien.value();
}
@ -51,8 +51,8 @@ void factor_vm::primitive_displaced_alien()
cell alien = dpop();
cell displacement = to_cell(dpop());
if(alien == F && displacement == 0)
dpush(F);
if(!to_boolean(alien) && displacement == 0)
dpush(false_object);
else
{
switch(tagged<object>(alien).type())
@ -87,12 +87,12 @@ void *factor_vm::alien_pointer()
#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
PRIMITIVE(alien_##name) \
{ \
((factor_vm*)myvm)->boxer(*(type*)((factor_vm*)myvm)->alien_pointer()); \
parent->boxer(*(type*)(parent->alien_pointer())); \
} \
PRIMITIVE(set_alien_##name) \
{ \
type *ptr = (type *)((factor_vm*)myvm)->alien_pointer(); \
type value = ((factor_vm*)myvm)->to(dpop()); \
type *ptr = (type *)parent->alien_pointer(); \
type value = parent->to(dpop()); \
*ptr = value; \
}
@ -130,17 +130,17 @@ void factor_vm::primitive_dlsym()
symbol_char *sym = name->data<symbol_char>();
if(library.value() == F)
box_alien(ffi_dlsym(NULL,sym));
else
if(to_boolean(library.value()))
{
dll *d = untag_check<dll>(library.value());
if(d->dll == NULL)
dpush(F);
dpush(false_object);
else
box_alien(ffi_dlsym(d,sym));
}
else
box_alien(ffi_dlsym(NULL,sym));
}
/* close a native library handle */
@ -154,10 +154,10 @@ void factor_vm::primitive_dlclose()
void factor_vm::primitive_dll_validp()
{
cell library = dpop();
if(library == F)
dpush(T);
if(to_boolean(library))
dpush(tag_boolean(untag_check<dll>(library)->dll != NULL));
else
dpush(untag_check<dll>(library)->dll == NULL ? F : T);
dpush(true_object);
}
/* gets the address of an object representing a C pointer */
@ -170,8 +170,8 @@ char *factor_vm::alien_offset(cell obj)
case ALIEN_TYPE:
{
alien *ptr = untag<alien>(obj);
if(ptr->expired != F)
general_error(ERROR_EXPIRED,obj,F,NULL);
if(to_boolean(ptr->expired))
general_error(ERROR_EXPIRED,obj,false_object,NULL);
return alien_offset(ptr->base) + ptr->displacement;
}
case F_TYPE:
@ -182,9 +182,9 @@ char *factor_vm::alien_offset(cell obj)
}
}
VM_C_API char *alien_offset(cell obj, factor_vm *myvm)
VM_C_API char *alien_offset(cell obj, factor_vm *parent)
{
return myvm->alien_offset(obj);
return parent->alien_offset(obj);
}
/* pop an object representing a C pointer */
@ -193,23 +193,23 @@ char *factor_vm::unbox_alien()
return alien_offset(dpop());
}
VM_C_API char *unbox_alien(factor_vm *myvm)
VM_C_API char *unbox_alien(factor_vm *parent)
{
return myvm->unbox_alien();
return parent->unbox_alien();
}
/* make an alien and push */
void factor_vm::box_alien(void *ptr)
{
if(ptr == NULL)
dpush(F);
dpush(false_object);
else
dpush(allot_alien(F,(cell)ptr));
dpush(allot_alien(false_object,(cell)ptr));
}
VM_C_API void box_alien(void *ptr, factor_vm *myvm)
VM_C_API void box_alien(void *ptr, factor_vm *parent)
{
return myvm->box_alien(ptr);
return parent->box_alien(ptr);
}
/* for FFI calls passing structs by value */
@ -218,9 +218,9 @@ void factor_vm::to_value_struct(cell src, void *dest, cell size)
memcpy(dest,alien_offset(src),size);
}
VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *myvm)
VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *parent)
{
return myvm->to_value_struct(src,dest,size);
return parent->to_value_struct(src,dest,size);
}
/* for FFI callbacks receiving structs by value */
@ -231,9 +231,9 @@ void factor_vm::box_value_struct(void *src, cell size)
dpush(tag<byte_array>(bytes));
}
VM_C_API void box_value_struct(void *src, cell size,factor_vm *myvm)
VM_C_API void box_value_struct(void *src, cell size,factor_vm *parent)
{
return myvm->box_value_struct(src,size);
return parent->box_value_struct(src,size);
}
/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
@ -245,9 +245,9 @@ void factor_vm::box_small_struct(cell x, cell y, cell size)
box_value_struct(data,size);
}
VM_C_API void box_small_struct(cell x, cell y, cell size, factor_vm *myvm)
VM_C_API void box_small_struct(cell x, cell y, cell size, factor_vm *parent)
{
return myvm->box_small_struct(x,y,size);
return parent->box_small_struct(x,y,size);
}
/* On OS X/PPC, complex numbers are returned in registers. */
@ -261,9 +261,9 @@ void factor_vm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
box_value_struct(data,size);
}
VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *myvm)
VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent)
{
return myvm->box_medium_struct(x1, x2, x3, x4, size);
return parent->box_medium_struct(x1, x2, x3, x4, size);
}
void factor_vm::primitive_vm_ptr()

20
vm/arrays.cpp
View File

@ -71,33 +71,33 @@ void factor_vm::primitive_resize_array()
void growable_array::add(cell elt_)
{
factor_vm *parent_vm = elements.parent_vm;
gc_root<object> elt(elt_,parent_vm);
factor_vm *parent = elements.parent;
gc_root<object> elt(elt_,parent);
if(count == array_capacity(elements.untagged()))
elements = parent_vm->reallot_array(elements.untagged(),count * 2);
elements = parent->reallot_array(elements.untagged(),count * 2);
parent_vm->set_array_nth(elements.untagged(),count++,elt.value());
parent->set_array_nth(elements.untagged(),count++,elt.value());
}
void growable_array::append(array *elts_)
{
factor_vm *parent_vm = elements.parent_vm;
gc_root<array> elts(elts_,parent_vm);
factor_vm *parent = elements.parent;
gc_root<array> elts(elts_,parent);
cell capacity = array_capacity(elts.untagged());
if(count + capacity > array_capacity(elements.untagged()))
{
elements = parent_vm->reallot_array(elements.untagged(),
elements = parent->reallot_array(elements.untagged(),
(count + capacity) * 2);
}
for(cell index = 0; index < capacity; index++)
parent_vm->set_array_nth(elements.untagged(),count++,array_nth(elts.untagged(),index));
parent->set_array_nth(elements.untagged(),count++,array_nth(elts.untagged(),index));
}
void growable_array::trim()
{
factor_vm *parent_vm = elements.parent_vm;
elements = parent_vm->reallot_array(elements.untagged(),count);
factor_vm *parent = elements.parent;
elements = parent->reallot_array(elements.untagged(),count);
}
}

3
vm/arrays.hpp
View File

@ -26,7 +26,8 @@ struct growable_array {
cell count;
gc_root<array> elements;
explicit growable_array(factor_vm *myvm, cell capacity = 10) : count(0), elements(myvm->allot_array(capacity,F),myvm) {}
explicit growable_array(factor_vm *parent, cell capacity = 10) :
count(0), elements(parent->allot_array(capacity,false_object),parent) {}
void add(cell elt);
void append(array *elts);

15
vm/booleans.cpp
View File

@ -5,22 +5,17 @@ namespace factor
void factor_vm::box_boolean(bool value)
{
dpush(value ? T : F);
dpush(tag_boolean(value));
}
VM_C_API void box_boolean(bool value, factor_vm *myvm)
VM_C_API void box_boolean(bool value, factor_vm *parent)
{
return myvm->box_boolean(value);
return parent->box_boolean(value);
}
bool factor_vm::to_boolean(cell value)
VM_C_API bool to_boolean(cell value, factor_vm *parent)
{
return value != F;
}
VM_C_API bool to_boolean(cell value, factor_vm *myvm)
{
return myvm->to_boolean(value);
return parent->to_boolean(value);
}
}

7
vm/booleans.hpp
View File

@ -6,7 +6,12 @@ VM_C_API bool to_boolean(cell value, factor_vm *vm);
inline cell factor_vm::tag_boolean(cell untagged)
{
return (untagged ? T : F);
return (untagged ? true_object : false_object);
}
inline bool factor_vm::to_boolean(cell value)
{
return value != false_object;
}
}

14
vm/byte_arrays.cpp
View File

@ -32,9 +32,9 @@ void factor_vm::primitive_resize_byte_array()
void growable_byte_array::append_bytes(void *elts, cell len)
{
cell new_size = count + len;
factor_vm *parent_vm = elements.parent_vm;
factor_vm *parent = elements.parent;
if(new_size >= array_capacity(elements.untagged()))
elements = parent_vm->reallot_array(elements.untagged(),new_size * 2);
elements = parent->reallot_array(elements.untagged(),new_size * 2);
memcpy(&elements->data<u8>()[count],elts,len);
@ -43,13 +43,13 @@ void growable_byte_array::append_bytes(void *elts, cell len)
void growable_byte_array::append_byte_array(cell byte_array_)
{
gc_root<byte_array> byte_array(byte_array_,elements.parent_vm);
gc_root<byte_array> byte_array(byte_array_,elements.parent);
cell len = array_capacity(byte_array.untagged());
cell new_size = count + len;
factor_vm *parent_vm = elements.parent_vm;
factor_vm *parent = elements.parent;
if(new_size >= array_capacity(elements.untagged()))
elements = parent_vm->reallot_array(elements.untagged(),new_size * 2);
elements = parent->reallot_array(elements.untagged(),new_size * 2);
memcpy(&elements->data<u8>()[count],byte_array->data<u8>(),len);
@ -58,8 +58,8 @@ void growable_byte_array::append_byte_array(cell byte_array_)
void growable_byte_array::trim()
{
factor_vm *parent_vm = elements.parent_vm;
elements = parent_vm->reallot_array(elements.untagged(),count);
factor_vm *parent = elements.parent;
elements = parent->reallot_array(elements.untagged(),count);
}
}

2
vm/byte_arrays.hpp
View File

@ -5,7 +5,7 @@ struct growable_byte_array {
cell count;
gc_root<byte_array> elements;
explicit growable_byte_array(factor_vm *myvm,cell capacity = 40) : count(0), elements(myvm->allot_byte_array(capacity),myvm) { }
explicit growable_byte_array(factor_vm *parent,cell capacity = 40) : count(0), elements(parent->allot_byte_array(capacity),parent) { }
void append_bytes(void *elts, cell len);
void append_byte_array(cell elts);

10
vm/callbacks.cpp
View File

@ -3,10 +3,10 @@
namespace factor
{
callback_heap::callback_heap(cell size, factor_vm *myvm_) :
callback_heap::callback_heap(cell size, factor_vm *parent_) :
seg(new segment(size,true)),
here(seg->start),
myvm(myvm_) {}
parent(parent_) {}
callback_heap::~callback_heap()
{
@ -21,12 +21,12 @@ void factor_vm::init_callbacks(cell size)
void callback_heap::update(callback *stub)
{
tagged<array> code_template(myvm->userenv[CALLBACK_STUB]);
tagged<array> code_template(parent->userenv[CALLBACK_STUB]);
cell rel_class = untag_fixnum(array_nth(code_template.untagged(),1));
cell offset = untag_fixnum(array_nth(code_template.untagged(),3));
myvm->store_address_in_code_block(rel_class,
parent->store_address_in_code_block(rel_class,
(cell)(stub + 1) + offset,
(cell)(stub->compiled + 1));
@ -35,7 +35,7 @@ void callback_heap::update(callback *stub)
callback *callback_heap::add(code_block *compiled)
{
tagged<array> code_template(myvm->userenv[CALLBACK_STUB]);
tagged<array> code_template(parent->userenv[CALLBACK_STUB]);
tagged<byte_array> insns(array_nth(code_template.untagged(),0));
cell size = array_capacity(insns.untagged());

4
vm/callbacks.hpp
View File

@ -10,9 +10,9 @@ struct callback {
struct callback_heap {
segment *seg;
cell here;
factor_vm *myvm;
factor_vm *parent;
explicit callback_heap(cell size, factor_vm *myvm);
explicit callback_heap(cell size, factor_vm *parent);
~callback_heap();
callback *add(code_block *compiled);

24
vm/callstack.cpp
View File

@ -100,22 +100,22 @@ cell factor_vm::frame_scan(stack_frame *frame)
case QUOTATION_TYPE:
{
cell quot = frame_executing(frame);
if(quot == F)
return F;
else
if(to_boolean(quot))
{
char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame,this);
char *quot_xt = (char *)(frame_code(frame) + 1);
return tag_fixnum(quot_code_offset_to_scan(
quot,(cell)(return_addr - quot_xt)));
}
}
else
return false_object;
}
case WORD_TYPE:
return F;
return false_object;
default:
critical_error("Bad frame type",frame_type(frame));
return F;
return false_object;
}
}
@ -123,15 +123,15 @@ namespace
{
struct stack_frame_accumulator {
factor_vm *myvm;
factor_vm *parent;
growable_array frames;
explicit stack_frame_accumulator(factor_vm *myvm_) : myvm(myvm_), frames(myvm_) {}
explicit stack_frame_accumulator(factor_vm *parent_) : parent(parent_), frames(parent_) {}
void operator()(stack_frame *frame)
{
gc_root<object> executing(myvm->frame_executing(frame),myvm);
gc_root<object> scan(myvm->frame_scan(frame),myvm);
gc_root<object> executing(parent->frame_executing(frame),parent);
gc_root<object> scan(parent->frame_scan(frame),parent);
frames.add(executing.value());
frames.add(scan.value());
@ -204,9 +204,9 @@ void factor_vm::save_callstack_bottom(stack_frame *callstack_bottom)
ctx->callstack_bottom = callstack_bottom;
}
VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *myvm)
VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *parent)
{
return myvm->save_callstack_bottom(callstack_bottom);
return parent->save_callstack_bottom(callstack_bottom);
}
}

56
vm/code_block.cpp
View File

@ -66,7 +66,7 @@ void *factor_vm::object_xt(cell obj)
void *factor_vm::xt_pic(word *w, cell tagged_quot)
{
if(tagged_quot == F || max_pic_size == 0)
if(!to_boolean(tagged_quot) || max_pic_size == 0)
return w->xt;
else
{
@ -92,7 +92,7 @@ void *factor_vm::word_xt_pic_tail(word *w)
image load */
void factor_vm::undefined_symbol()
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
general_error(ERROR_UNDEFINED_SYMBOL,false_object,false_object,NULL);
}
void undefined_symbol()
@ -106,7 +106,7 @@ void *factor_vm::get_rel_symbol(array *literals, cell index)
cell symbol = array_nth(literals,index);
cell library = array_nth(literals,index + 1);
dll *d = (library == F ? NULL : untag<dll>(library));
dll *d = (to_boolean(library) ? untag<dll>(library) : NULL);
if(d != NULL && !d->dll)
return (void *)factor::undefined_symbol;
@ -147,8 +147,8 @@ void *factor_vm::get_rel_symbol(array *literals, cell index)
cell factor_vm::compute_relocation(relocation_entry rel, cell index, code_block *compiled)
{
array *literals = (compiled->literals == F
? NULL : untag<array>(compiled->literals));
array *literals = (to_boolean(compiled->literals)
? untag<array>(compiled->literals) : NULL);
cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
#define ARG array_nth(literals,index)
@ -196,7 +196,7 @@ cell factor_vm::compute_relocation(relocation_entry rel, cell index, code_block
template<typename Iterator> void factor_vm::iterate_relocations(code_block *compiled, Iterator &iter)
{
if(compiled->relocation != F)
if(to_boolean(compiled->relocation))
{
byte_array *relocation = untag<byte_array>(compiled->relocation);
@ -277,18 +277,18 @@ void factor_vm::store_address_in_code_block(cell klass, cell offset, fixnum abso
}
struct literal_references_updater {
factor_vm *myvm;
factor_vm *parent;
explicit literal_references_updater(factor_vm *myvm_) : myvm(myvm_) {}
explicit literal_references_updater(factor_vm *parent_) : parent(parent_) {}
void operator()(relocation_entry rel, cell index, code_block *compiled)
{
if(myvm->relocation_type_of(rel) == RT_IMMEDIATE)
if(parent->relocation_type_of(rel) == RT_IMMEDIATE)
{
cell offset = myvm->relocation_offset_of(rel) + (cell)(compiled + 1);
array *literals = myvm->untag<array>(compiled->literals);
cell offset = parent->relocation_offset_of(rel) + (cell)(compiled + 1);
array *literals = parent->untag<array>(compiled->literals);
fixnum absolute_value = array_nth(literals,index);
myvm->store_address_in_code_block(myvm->relocation_class_of(rel),offset,absolute_value);
parent->store_address_in_code_block(parent->relocation_class_of(rel),offset,absolute_value);
}
}
};
@ -308,9 +308,9 @@ void factor_vm::update_literal_references(code_block *compiled)
void factor_vm::relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
{
#ifdef FACTOR_DEBUG
if(compiled->literals != F)
if(to_boolean(compiled->literals))
tagged<array>(compiled->literals).untag_check(this);
if(compiled->relocation != F)
if(to_boolean(compiled->relocation))
tagged<byte_array>(compiled->relocation).untag_check(this);
#endif
@ -320,14 +320,14 @@ void factor_vm::relocate_code_block_step(relocation_entry rel, cell index, code_
}
struct word_references_updater {
factor_vm *myvm;
factor_vm *parent;
explicit word_references_updater(factor_vm *myvm_) : myvm(myvm_) {}
explicit word_references_updater(factor_vm *parent_) : parent(parent_) {}
void operator()(relocation_entry rel, cell index, code_block *compiled)
{
relocation_type type = myvm->relocation_type_of(rel);
relocation_type type = parent->relocation_type_of(rel);
if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
myvm->relocate_code_block_step(rel,index,compiled);
parent->relocate_code_block_step(rel,index,compiled);
}
};
@ -358,20 +358,20 @@ void factor_vm::update_word_references(code_block *compiled)
/* This runs after a full collection */
struct literal_and_word_references_updater {
factor_vm *myvm;
factor_vm *parent;
explicit literal_and_word_references_updater(factor_vm *myvm_) : myvm(myvm_) {}
explicit literal_and_word_references_updater(factor_vm *parent_) : parent(parent_) {}
void operator()(relocation_entry rel, cell index, code_block *compiled)
{
relocation_type type = myvm->relocation_type_of(rel);
relocation_type type = parent->relocation_type_of(rel);
switch(type)
{
case RT_IMMEDIATE:
case RT_XT:
case RT_XT_PIC:
case RT_XT_PIC_TAIL:
myvm->relocate_code_block_step(rel,index,compiled);
parent->relocate_code_block_step(rel,index,compiled);
break;
default:
break;
@ -399,13 +399,13 @@ void factor_vm::check_code_address(cell address)
}
struct code_block_relocator {
factor_vm *myvm;
factor_vm *parent;
explicit code_block_relocator(factor_vm *myvm_) : myvm(myvm_) {}
explicit code_block_relocator(factor_vm *parent_) : parent(parent_) {}
void operator()(relocation_entry rel, cell index, code_block *compiled)
{
myvm->relocate_code_block_step(rel,index,compiled);
parent->relocate_code_block_step(rel,index,compiled);
}
};
@ -484,12 +484,12 @@ code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell
/* slight space optimization */
if(relocation.type() == BYTE_ARRAY_TYPE && array_capacity(relocation.untagged()) == 0)
compiled->relocation = F;
compiled->relocation = false_object;
else
compiled->relocation = relocation.value();
if(literals.type() == ARRAY_TYPE && array_capacity(literals.untagged()) == 0)
compiled->literals = F;
compiled->literals = false_object;
else
compiled->literals = literals.value();
@ -497,7 +497,7 @@ code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell
memcpy(compiled + 1,code.untagged() + 1,code_length);
/* fixup labels */
if(labels.value() != F)
if(to_boolean(labels.value()))
fixup_labels(labels.as<array>().untagged(),compiled);
/* next time we do a minor GC, we have to scan the code heap for

24
vm/code_heap.cpp
View File

@ -51,17 +51,17 @@ void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate)
word->code = def->code;
if(word->pic_def != F) jit_compile(word->pic_def,relocate);
if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate);
if(to_boolean(word->pic_def)) jit_compile(word->pic_def,relocate);
if(to_boolean(word->pic_tail_def)) jit_compile(word->pic_tail_def,relocate);
}
struct word_updater {
factor_vm *myvm;
factor_vm *parent;
explicit word_updater(factor_vm *myvm_) : myvm(myvm_) {}
explicit word_updater(factor_vm *parent_) : parent(parent_) {}
void operator()(code_block *compiled)
{
myvm->update_word_references(compiled);
parent->update_word_references(compiled);
}
};
@ -143,18 +143,18 @@ code_block *code_heap::forward_code_block(code_block *compiled)
}
struct callframe_forwarder {
factor_vm *myvm;
factor_vm *parent;
explicit callframe_forwarder(factor_vm *myvm_) : myvm(myvm_) {}
explicit callframe_forwarder(factor_vm *parent_) : parent(parent_) {}
void operator()(stack_frame *frame)
{
cell offset = (cell)FRAME_RETURN_ADDRESS(frame,myvm) - (cell)frame->xt;
cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->xt;
code_block *forwarded = myvm->code->forward_code_block(myvm->frame_code(frame));
code_block *forwarded = parent->code->forward_code_block(parent->frame_code(frame));
frame->xt = forwarded->xt();
FRAME_RETURN_ADDRESS(frame,myvm) = (void *)((cell)frame->xt + offset);
FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->xt + offset);
}
};
@ -164,7 +164,7 @@ void factor_vm::forward_object_xts()
cell obj;
while((obj = next_object()) != F)
while(to_boolean(obj = next_object()))
{
switch(tagged<object>(obj).type())
{
@ -251,7 +251,7 @@ struct stack_trace_stripper {
void operator()(code_block *compiled)
{
compiled->owner = F;
compiled->owner = false_object;
}
};

40
vm/collector.hpp
View File

@ -2,7 +2,7 @@ namespace factor
{
template<typename TargetGeneration, typename Policy> struct collector {
factor_vm *myvm;
factor_vm *parent;
data_heap *data;
code_heap *code;
gc_state *current_gc;
@ -10,18 +10,18 @@ template<typename TargetGeneration, typename Policy> struct collector {
TargetGeneration *target;
Policy policy;
explicit collector(factor_vm *myvm_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
myvm(myvm_),
data(myvm_->data),
code(myvm_->code),
current_gc(myvm_->current_gc),
explicit collector(factor_vm *parent_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
parent(parent_),
data(parent_->data),
code(parent_->code),
current_gc(parent_->current_gc),
stats(stats_),
target(target_),
policy(policy_) {}
object *resolve_forwarding(object *untagged)
{
myvm->check_data_pointer(untagged);
parent->check_data_pointer(untagged);
/* is there another forwarding pointer? */
while(untagged->h.forwarding_pointer_p())
@ -38,7 +38,7 @@ template<typename TargetGeneration, typename Policy> struct collector {
if(immediate_p(pointer)) return;
object *untagged = myvm->untag<object>(pointer);
object *untagged = parent->untag<object>(pointer);
if(!policy.should_copy_p(untagged))
return;
@ -57,7 +57,7 @@ template<typename TargetGeneration, typename Policy> struct collector {
void trace_slots(object *ptr)
{
cell *slot = (cell *)ptr;
cell *end = (cell *)((cell)ptr + myvm->binary_payload_start(ptr));
cell *end = (cell *)((cell)ptr + parent->binary_payload_start(ptr));
if(slot != end)
{
@ -68,7 +68,7 @@ template<typename TargetGeneration, typename Policy> struct collector {
object *promote_object(object *untagged)
{
cell size = myvm->untagged_object_size(untagged);
cell size = parent->untagged_object_size(untagged);
object *newpointer = target->allot(size);
/* XXX not exception-safe */
if(!newpointer) longjmp(current_gc->gc_unwind,1);
@ -90,8 +90,8 @@ template<typename TargetGeneration, typename Policy> struct collector {
void trace_registered_locals()
{
std::vector<cell>::const_iterator iter = myvm->gc_locals.begin();
std::vector<cell>::const_iterator end = myvm->gc_locals.end();
std::vector<cell>::const_iterator iter = parent->gc_locals.begin();
std::vector<cell>::const_iterator end = parent->gc_locals.end();
for(; iter < end; iter++)
trace_handle((cell *)(*iter));
@ -99,8 +99,8 @@ template<typename TargetGeneration, typename Policy> struct collector {
void trace_registered_bignums()
{
std::vector<cell>::const_iterator iter = myvm->gc_bignums.begin();
std::vector<cell>::const_iterator end = myvm->gc_bignums.end();
std::vector<cell>::const_iterator iter = parent->gc_bignums.begin();
std::vector<cell>::const_iterator end = parent->gc_bignums.end();
for(; iter < end; iter++)
{
@ -119,20 +119,20 @@ template<typename TargetGeneration, typename Policy> struct collector {
the user environment and extra roots registered by local_roots.hpp */
void trace_roots()
{
trace_handle(&myvm->T);
trace_handle(&myvm->bignum_zero);
trace_handle(&myvm->bignum_pos_one);
trace_handle(&myvm->bignum_neg_one);
trace_handle(&parent->true_object);
trace_handle(&parent->bignum_zero);
trace_handle(&parent->bignum_pos_one);
trace_handle(&parent->bignum_neg_one);
trace_registered_locals();
trace_registered_bignums();
for(int i = 0; i < USER_ENV; i++) trace_handle(&myvm->userenv[i]);
for(int i = 0; i < USER_ENV; i++) trace_handle(&parent->userenv[i]);
}
void trace_contexts()
{
context *ctx = myvm->ctx;
context *ctx = parent->ctx;
while(ctx)
{

18
vm/contexts.cpp
View File

@ -91,9 +91,9 @@ void factor_vm::nest_stacks(stack_frame *magic_frame)
reset_retainstack();
}
void nest_stacks(stack_frame *magic_frame, factor_vm *myvm)
void nest_stacks(stack_frame *magic_frame, factor_vm *parent)
{
return myvm->nest_stacks(magic_frame);
return parent->nest_stacks(magic_frame);
}
/* called when leaving a compiled callback */
@ -111,9 +111,9 @@ void factor_vm::unnest_stacks()
dealloc_context(old_ctx);
}
void unnest_stacks(factor_vm *myvm)
void unnest_stacks(factor_vm *parent)
{
return myvm->unnest_stacks();
return parent->unnest_stacks();
}
/* called on startup */
@ -143,13 +143,13 @@ bool factor_vm::stack_to_array(cell bottom, cell top)
void factor_vm::primitive_datastack()
{
if(!stack_to_array(ds_bot,ds))
general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
general_error(ERROR_DS_UNDERFLOW,false_object,false_object,NULL);
}
void factor_vm::primitive_retainstack()
{
if(!stack_to_array(rs_bot,rs))
general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
general_error(ERROR_RS_UNDERFLOW,false_object,false_object,NULL);
}
/* returns pointer to top of stack */
@ -180,7 +180,7 @@ void factor_vm::primitive_check_datastack()
fixnum saved_height = array_capacity(saved_datastack);
fixnum current_height = (ds - ds_bot + sizeof(cell)) / sizeof(cell);
if(current_height - height != saved_height)
dpush(F);
dpush(false_object);
else
{
fixnum i;
@ -188,11 +188,11 @@ void factor_vm::primitive_check_datastack()
{
if(((cell *)ds_bot)[i] != array_nth(saved_datastack,i))
{
dpush(F);
dpush(false_object);
return;
}
}
dpush(T);
dpush(true_object);
}
}

24
vm/copying_collector.hpp
View File

@ -15,8 +15,8 @@ template<typename TargetGeneration, typename Policy>
struct copying_collector : collector<TargetGeneration,Policy> {
cell scan;
explicit copying_collector(factor_vm *myvm_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
collector<TargetGeneration,Policy>(myvm_,stats_,target_,policy_), scan(target_->here) {}
explicit copying_collector(factor_vm *parent_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
collector<TargetGeneration,Policy>(parent_,stats_,target_,policy_), scan(target_->here) {}
inline cell first_card_in_deck(cell deck)
{
@ -82,7 +82,7 @@ struct copying_collector : collector<TargetGeneration,Policy> {
{
if(decks[deck_index] & mask)
{
this->myvm->gc_stats.decks_scanned++;
this->parent->gc_stats.decks_scanned++;
cell first_card = first_card_in_deck(deck_index);
cell last_card = last_card_in_deck(deck_index);
@ -91,13 +91,13 @@ struct copying_collector : collector<TargetGeneration,Policy> {
{
if(cards[card_index] & mask)
{
this->myvm->gc_stats.cards_scanned++;
this->parent->gc_stats.cards_scanned++;
if(end < card_start_address(card_index))
{
start = gen->find_object_containing_card(card_index - gen_start_card);
binary_start = start + this->myvm->binary_payload_start((object *)start);
end = start + this->myvm->untagged_object_size((object *)start);
binary_start = start + this->parent->binary_payload_start((object *)start);
end = start + this->parent->untagged_object_size((object *)start);
}
#ifdef FACTOR_DEBUG
@ -113,11 +113,11 @@ scan_next_object: {
card_end_address(card_index));
if(end < card_end_address(card_index))
{
start = gen->next_object_after(this->myvm,start);
start = gen->next_object_after(this->parent,start);
if(start)
{
binary_start = start + this->myvm->binary_payload_start((object *)start);
end = start + this->myvm->untagged_object_size((object *)start);
binary_start = start + this->parent->binary_payload_start((object *)start);
end = start + this->parent->untagged_object_size((object *)start);
goto scan_next_object;
}
}
@ -133,7 +133,7 @@ scan_next_object: {
}
}
end: this->myvm->gc_stats.card_scan_time += (current_micros() - start_time);
end: this->parent->gc_stats.card_scan_time += (current_micros() - start_time);
}
/* Trace all literals referenced from a code block. Only for aging and nursery collections */
@ -142,7 +142,7 @@ end: this->myvm->gc_stats.card_scan_time += (current_micros() - start_time);
this->trace_handle(&compiled->owner);
this->trace_handle(&compiled->literals);
this->trace_handle(&compiled->relocation);
this->myvm->gc_stats.code_blocks_scanned++;
this->parent->gc_stats.code_blocks_scanned++;
}
void trace_code_heap_roots(std::set<code_block *> *remembered_set)
@ -158,7 +158,7 @@ end: this->myvm->gc_stats.card_scan_time += (current_micros() - start_time);
while(scan && scan < this->target->here)
{
this->trace_slots((object *)scan);
scan = this->target->next_object_after(this->myvm,scan);
scan = this->target->next_object_after(this->parent,scan);
}
}
};

6
vm/data_heap.cpp
View File

@ -240,10 +240,10 @@ void factor_vm::primitive_begin_scan()
cell factor_vm::next_object()
{
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
general_error(ERROR_HEAP_SCAN,false_object,false_object,NULL);
if(heap_scan_ptr >= data->tenured->here)
return F;
return false_object;
object *obj = (object *)heap_scan_ptr;
heap_scan_ptr += untagged_object_size(obj);
@ -266,7 +266,7 @@ template<typename Iterator> void factor_vm::each_object(Iterator &iterator)
{
begin_scan();
cell obj;
while((obj = next_object()) != F)
while(to_boolean(obj = next_object()))
iterator(tagged<object>(obj));
end_scan();
}

24
vm/debug.cpp
View File

@ -165,23 +165,23 @@ void factor_vm::print_retainstack()
}
struct stack_frame_printer {
factor_vm *myvm;
factor_vm *parent;
explicit stack_frame_printer(factor_vm *myvm_) : myvm(myvm_) {}
explicit stack_frame_printer(factor_vm *parent_) : parent(parent_) {}
void operator()(stack_frame *frame)
{
myvm->print_obj(myvm->frame_executing(frame));
parent->print_obj(parent->frame_executing(frame));
print_string("\n");
myvm->print_obj(myvm->frame_scan(frame));
parent->print_obj(parent->frame_scan(frame));
print_string("\n");
print_string("word/quot addr: ");
print_cell_hex((cell)myvm->frame_executing(frame));
print_cell_hex((cell)parent->frame_executing(frame));
print_string("\n");
print_string("word/quot xt: ");
print_cell_hex((cell)frame->xt);
print_string("\n");
print_string("return address: ");
print_cell_hex((cell)FRAME_RETURN_ADDRESS(frame,myvm));
print_cell_hex((cell)FRAME_RETURN_ADDRESS(frame,parent));
print_string("\n");
}
};
@ -236,7 +236,7 @@ void factor_vm::dump_objects(cell type)
begin_scan();
cell obj;
while((obj = next_object()) != F)
while(to_boolean(obj = next_object()))
{
if(type == TYPE_COUNT || tagged<object>(obj).type_p(type))
{
@ -252,10 +252,10 @@ void factor_vm::dump_objects(cell type)
struct data_references_finder {
cell look_for, obj;
factor_vm *myvm;
factor_vm *parent;
explicit data_references_finder(cell look_for_, cell obj_, factor_vm *myvm_)
: look_for(look_for_), obj(obj_), myvm(myvm_) { }
explicit data_references_finder(cell look_for_, cell obj_, factor_vm *parent_)
: look_for(look_for_), obj(obj_), parent(parent_) { }
void operator()(cell *scan)
{
@ -263,7 +263,7 @@ struct data_references_finder {
{
print_cell_hex_pad(obj);
print_string(" ");
myvm->print_nested_obj(obj,2);
parent->print_nested_obj(obj,2);
nl();
}
}
@ -275,7 +275,7 @@ void factor_vm::find_data_references(cell look_for)
cell obj;
while((obj = next_object()) != F)
while(to_boolean(obj = next_object()))
{
data_references_finder finder(look_for,obj,this);
do_slots(UNTAG(obj),finder);

24
vm/dispatch.cpp
View File

@ -15,14 +15,14 @@ cell factor_vm::search_lookup_alist(cell table, cell klass)
index -= 2;
}
return F;
return false_object;
}
cell factor_vm::search_lookup_hash(cell table, cell klass, cell hashcode)
{
array *buckets = untag<array>(table);
cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
if(tagged<object>(bucket).type_p(WORD_TYPE) || bucket == F)
if(tagged<object>(bucket).type_p(WORD_TYPE) || !to_boolean(bucket))
return bucket;
else
return search_lookup_alist(bucket,klass);
@ -56,12 +56,12 @@ cell factor_vm::lookup_tuple_method(cell obj, cell methods)
if(tagged<object>(echelon_methods).type_p(WORD_TYPE))
return echelon_methods;
else if(echelon_methods != F)
else if(to_boolean(echelon_methods))
{
cell klass = nth_superclass(layout,echelon);
cell hashcode = untag_fixnum(nth_hashcode(layout,echelon));
cell result = search_lookup_hash(echelon_methods,klass,hashcode);
if(result != F)
if(to_boolean(result))
return result;
}
@ -69,7 +69,7 @@ cell factor_vm::lookup_tuple_method(cell obj, cell methods)
}
critical_error("Cannot find tuple method",methods);
return F;
return false_object;
}
cell factor_vm::lookup_hi_tag_method(cell obj, cell methods)
@ -180,28 +180,28 @@ void factor_vm::primitive_dispatch_stats()
void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_)
{
gc_root<array> methods(methods_,parent_vm);
gc_root<array> cache(cache_,parent_vm);
gc_root<array> methods(methods_,parent);
gc_root<array> cache(cache_,parent);
/* Generate machine code to determine the object's class. */
emit_class_lookup(index,PIC_HI_TAG_TUPLE);
/* Do a cache lookup. */
emit_with(parent_vm->userenv[MEGA_LOOKUP],cache.value());
emit_with(parent->userenv[MEGA_LOOKUP],cache.value());
/* If we end up here, the cache missed. */
emit(parent_vm->userenv[JIT_PROLOG]);
emit(parent->userenv[JIT_PROLOG]);
/* Push index, method table and cache on the stack. */
push(methods.value());
push(tag_fixnum(index));
push(cache.value());
word_call(parent_vm->userenv[MEGA_MISS_WORD]);
word_call(parent->userenv[MEGA_MISS_WORD]);
/* Now the new method has been stored into the cache, and its on
the stack. */
emit(parent_vm->userenv[JIT_EPILOG]);
emit(parent_vm->userenv[JIT_EXECUTE_JUMP]);
emit(parent->userenv[JIT_EPILOG]);
emit(parent->userenv[JIT_EXECUTE_JUMP]);
}
}

20
vm/errors.cpp
View File

@ -29,7 +29,7 @@ void factor_vm::throw_error(cell error, stack_frame *callstack_top)
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
if(!current_gc && userenv[BREAK_ENV] != F)
if(!current_gc && to_boolean(userenv[BREAK_ENV]))
{
/* If error was thrown during heap scan, we re-enable the GC */
gc_off = false;
@ -80,7 +80,7 @@ void factor_vm::type_error(cell type, cell tagged)
void factor_vm::not_implemented_error()
{
general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
general_error(ERROR_NOT_IMPLEMENTED,false_object,false_object,NULL);
}
/* Test if 'fault' is in the guard page at the top or bottom (depending on
@ -97,32 +97,32 @@ bool factor_vm::in_page(cell fault, cell area, cell area_size, int offset)
void factor_vm::memory_protection_error(cell addr, stack_frame *native_stack)
{
if(in_page(addr, ds_bot, 0, -1))
general_error(ERROR_DS_UNDERFLOW,F,F,native_stack);
general_error(ERROR_DS_UNDERFLOW,false_object,false_object,native_stack);
else if(in_page(addr, ds_bot, ds_size, 0))
general_error(ERROR_DS_OVERFLOW,F,F,native_stack);
general_error(ERROR_DS_OVERFLOW,false_object,false_object,native_stack);
else if(in_page(addr, rs_bot, 0, -1))
general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
general_error(ERROR_RS_UNDERFLOW,false_object,false_object,native_stack);
else if(in_page(addr, rs_bot, rs_size, 0))
general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
general_error(ERROR_RS_OVERFLOW,false_object,false_object,native_stack);
else if(in_page(addr, nursery.end, 0, 0))
critical_error("allot_object() missed GC check",0);
else
general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
general_error(ERROR_MEMORY,allot_cell(addr),false_object,native_stack);
}
void factor_vm::signal_error(int signal, stack_frame *native_stack)
{
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
general_error(ERROR_SIGNAL,tag_fixnum(signal),false_object,native_stack);
}
void factor_vm::divide_by_zero_error()
{
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
general_error(ERROR_DIVIDE_BY_ZERO,false_object,false_object,NULL);
}
void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
{
general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),F,signal_callstack_top);
general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object,signal_callstack_top);
}
void factor_vm::primitive_call_clear()

16
vm/factor.cpp
View File

@ -100,7 +100,7 @@ void factor_vm::do_stage1_init()
fflush(stdout);
compile_all_words();
userenv[STAGE2_ENV] = T;
userenv[STAGE2_ENV] = true_object;
print_string("done\n");
fflush(stdout);
@ -148,17 +148,17 @@ void factor_vm::init_factor(vm_parameters *p)
init_profiler();
userenv[CPU_ENV] = allot_alien(F,(cell)FACTOR_CPU_STRING);
userenv[OS_ENV] = allot_alien(F,(cell)FACTOR_OS_STRING);
userenv[CPU_ENV] = allot_alien(false_object,(cell)FACTOR_CPU_STRING);
userenv[OS_ENV] = allot_alien(false_object,(cell)FACTOR_OS_STRING);
userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(cell));
userenv[EXECUTABLE_ENV] = allot_alien(F,(cell)p->executable_path);
userenv[ARGS_ENV] = F;
userenv[EMBEDDED_ENV] = F;
userenv[EXECUTABLE_ENV] = allot_alien(false_object,(cell)p->executable_path);
userenv[ARGS_ENV] = false_object;
userenv[EMBEDDED_ENV] = false_object;
/* We can GC now */
gc_off = false;
if(userenv[STAGE2_ENV] == F)
if(!to_boolean(userenv[STAGE2_ENV]))
do_stage1_init();
}
@ -169,7 +169,7 @@ void factor_vm::pass_args_to_factor(int argc, vm_char **argv)
int i;
for(i = 1; i < argc; i++){
args.add(allot_alien(F,(cell)argv[i]));
args.add(allot_alien(false_object,(cell)argv[i]));
}
args.trim();

36
vm/full_collector.cpp
View File

@ -3,23 +3,23 @@
namespace factor
{
full_collector::full_collector(factor_vm *myvm_) :
full_collector::full_collector(factor_vm *parent_) :
copying_collector<tenured_space,full_policy>(
myvm_,
&myvm_->gc_stats.full_stats,
myvm_->data->tenured,
full_policy(myvm_)) {}
parent_,
&parent_->gc_stats.full_stats,
parent_->data->tenured,
full_policy(parent_)) {}
struct stack_frame_marker {
factor_vm *myvm;
factor_vm *parent;
full_collector *collector;
explicit stack_frame_marker(full_collector *collector_) :
myvm(collector_->myvm), collector(collector_) {}
parent(collector_->parent), collector(collector_) {}
void operator()(stack_frame *frame)
{
collector->mark_code_block(myvm->frame_code(frame));
collector->mark_code_block(parent->frame_code(frame));
}
};
@ -27,7 +27,7 @@ struct stack_frame_marker {
void full_collector::mark_active_blocks()
{
stack_frame_marker marker(this);
myvm->iterate_active_frames(marker);
parent->iterate_active_frames(marker);
}
void full_collector::mark_object_code_block(object *obj)
@ -54,7 +54,7 @@ void full_collector::mark_object_code_block(object *obj)
{
callstack *stack = (callstack *)obj;
stack_frame_marker marker(this);
myvm->iterate_callstack_object(stack,marker);
parent->iterate_callstack_object(stack,marker);
break;
}
}
@ -74,7 +74,7 @@ struct callback_tracer {
void full_collector::trace_callbacks()
{
callback_tracer tracer(this);
myvm->callbacks->iterate(tracer);
parent->callbacks->iterate(tracer);
}
/* Trace all literals referenced from a code block. Only for aging and nursery collections */
@ -100,33 +100,33 @@ void full_collector::cheneys_algorithm()
object *obj = (object *)scan;
this->trace_slots(obj);
this->mark_object_code_block(obj);
scan = target->next_object_after(this->myvm,scan);
scan = target->next_object_after(this->parent,scan);
}
}
/* After growing the heap, we have to perform a full relocation to update
references to card and deck arrays. */
struct big_code_heap_updater {
factor_vm *myvm;
factor_vm *parent;
big_code_heap_updater(factor_vm *myvm_) : myvm(myvm_) {}
big_code_heap_updater(factor_vm *parent_) : parent(parent_) {}
void operator()(heap_block *block)
{
myvm->relocate_code_block((code_block *)block);
parent->relocate_code_block((code_block *)block);
}
};
/* After a full GC that did not grow the heap, we have to update references
to literals and other words. */
struct small_code_heap_updater {
factor_vm *myvm;
factor_vm *parent;
small_code_heap_updater(factor_vm *myvm_) : myvm(myvm_) {}
small_code_heap_updater(factor_vm *parent_) : parent(parent_) {}
void operator()(heap_block *block)
{
myvm->update_code_block_for_full_gc((code_block *)block);
parent->update_code_block_for_full_gc((code_block *)block);
}
};

6
vm/full_collector.hpp
View File

@ -2,10 +2,10 @@ namespace factor
{
struct full_policy {
factor_vm *myvm;
factor_vm *parent;
zone *tenured;
full_policy(factor_vm *myvm_) : myvm(myvm_), tenured(myvm->data->tenured) {}
full_policy(factor_vm *parent_) : parent(parent_), tenured(parent->data->tenured) {}
bool should_copy_p(object *untagged)
{
@ -16,7 +16,7 @@ struct full_policy {
struct full_collector : copying_collector<tenured_space,full_policy> {
bool trace_contexts_p;
full_collector(factor_vm *myvm_);
full_collector(factor_vm *parent_);
void mark_active_blocks();
void mark_object_code_block(object *object);
void trace_callbacks();

4
vm/gc.cpp
View File

@ -202,9 +202,9 @@ void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
gc_locals.pop_back();
}
VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm)
VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *parent)
{
myvm->inline_gc(gc_roots_base,gc_roots_size);
parent->inline_gc(gc_roots_base,gc_roots_size);
}
/*

2
vm/gc.hpp
View File

@ -37,6 +37,6 @@ struct gc_state {
~gc_state();
};
VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm);
VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *parent);
}

42
vm/image.cpp
View File

@ -8,7 +8,7 @@ void factor_vm::init_objects(image_header *h)
{
memcpy(userenv,h->userenv,sizeof(userenv));
T = h->t;
true_object = h->true_object;
bignum_zero = h->bignum_zero;
bignum_pos_one = h->bignum_pos_one;
bignum_neg_one = h->bignum_neg_one;
@ -104,19 +104,19 @@ void factor_vm::fixup_quotation(quotation *quot, cell code_relocation_base)
void factor_vm::fixup_alien(alien *d)
{
if(d->base == F) d->expired = T;
if(!to_boolean(d->base)) d->expired = true_object;
}
struct stack_frame_fixupper {
factor_vm *myvm;
factor_vm *parent;
cell code_relocation_base;
explicit stack_frame_fixupper(factor_vm *myvm_, cell code_relocation_base_) :
myvm(myvm_), code_relocation_base(code_relocation_base_) {}
explicit stack_frame_fixupper(factor_vm *parent_, cell code_relocation_base_) :
parent(parent_), code_relocation_base(code_relocation_base_) {}
void operator()(stack_frame *frame)
{
myvm->code_fixup(&frame->xt,code_relocation_base);
myvm->code_fixup(&FRAME_RETURN_ADDRESS(frame,myvm),code_relocation_base);
parent->code_fixup(&frame->xt,code_relocation_base);
parent->code_fixup(&FRAME_RETURN_ADDRESS(frame,parent),code_relocation_base);
}
};
@ -127,15 +127,15 @@ void factor_vm::fixup_callstack_object(callstack *stack, cell code_relocation_ba
}
struct object_fixupper {
factor_vm *myvm;
factor_vm *parent;
cell data_relocation_base;
explicit object_fixupper(factor_vm *myvm_, cell data_relocation_base_) :
myvm(myvm_), data_relocation_base(data_relocation_base_) { }
explicit object_fixupper(factor_vm *parent_, cell data_relocation_base_) :
parent(parent_), data_relocation_base(data_relocation_base_) { }
void operator()(cell *scan)
{
myvm->data_fixup(scan,data_relocation_base);
parent->data_fixup(scan,data_relocation_base);
}
};
@ -193,7 +193,7 @@ void factor_vm::relocate_data(cell data_relocation_base, cell code_relocation_ba
for(cell i = 0; i < USER_ENV; i++)
data_fixup(&userenv[i],data_relocation_base);
data_fixup(&T,data_relocation_base);
data_fixup(&true_object,data_relocation_base);
data_fixup(&bignum_zero,data_relocation_base);
data_fixup(&bignum_pos_one,data_relocation_base);
data_fixup(&bignum_neg_one,data_relocation_base);
@ -219,15 +219,15 @@ void factor_vm::fixup_code_block(code_block *compiled, cell data_relocation_base
}
struct code_block_fixupper {
factor_vm *myvm;
factor_vm *parent;
cell data_relocation_base;
code_block_fixupper(factor_vm *myvm_, cell data_relocation_base_) :
myvm(myvm_), data_relocation_base(data_relocation_base_) { }
code_block_fixupper(factor_vm *parent_, cell data_relocation_base_) :
parent(parent_), data_relocation_base(data_relocation_base_) { }
void operator()(code_block *compiled)
{
myvm->fixup_code_block(compiled,data_relocation_base);
parent->fixup_code_block(compiled,data_relocation_base);
}
};
@ -270,7 +270,7 @@ void factor_vm::load_image(vm_parameters *p)
relocate_code(h.data_relocation_base);
/* Store image path name */
userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path);
userenv[IMAGE_ENV] = allot_alien(false_object,(cell)p->image_path);
}
/* Save the current image to disk */
@ -294,13 +294,13 @@ bool factor_vm::save_image(const vm_char *filename)
h.code_relocation_base = code->seg->start;
h.code_size = code->heap_size();
h.t = T;
h.true_object = true_object;
h.bignum_zero = bignum_zero;
h.bignum_pos_one = bignum_pos_one;
h.bignum_neg_one = bignum_neg_one;
for(cell i = 0; i < USER_ENV; i++)
h.userenv[i] = (save_env_p(i) ? userenv[i] : F);
h.userenv[i] = (save_env_p(i) ? userenv[i] : false_object);
bool ok = true;
@ -337,9 +337,7 @@ void factor_vm::primitive_save_image_and_exit()
/* strip out userenv data which is set on startup anyway */
for(cell i = 0; i < USER_ENV; i++)
{
if(!save_env_p(i)) userenv[i] = F;
}
if(!save_env_p(i)) userenv[i] = false_object;
gc(collect_full_op,
0, /* requested size */

2
vm/image.hpp
View File

@ -17,7 +17,7 @@ struct image_header {
/* size of code heap */
cell code_size;
/* tagged pointer to t singleton */
cell t;
cell true_object;
/* tagged pointer to bignum 0 */
cell bignum_zero;
/* tagged pointer to bignum 1 */

22
vm/inline_cache.cpp
View File

@ -92,9 +92,9 @@ void inline_cache_jit::emit_check(cell klass)
{
cell code_template;
if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
code_template = parent_vm->userenv[PIC_CHECK_TAG];
code_template = parent->userenv[PIC_CHECK_TAG];
else
code_template = parent_vm->userenv[PIC_CHECK];
code_template = parent->userenv[PIC_CHECK];
emit_with(code_template,klass);
}
@ -107,12 +107,12 @@ void inline_cache_jit::compile_inline_cache(fixnum index,
cell cache_entries_,
bool tail_call_p)
{
gc_root<word> generic_word(generic_word_,parent_vm);
gc_root<array> methods(methods_,parent_vm);
gc_root<array> cache_entries(cache_entries_,parent_vm);
gc_root<word> generic_word(generic_word_,parent);
gc_root<array> methods(methods_,parent);
gc_root<array> cache_entries(cache_entries_,parent);
cell inline_cache_type = parent_vm->determine_inline_cache_type(cache_entries.untagged());
parent_vm->update_pic_count(inline_cache_type);
cell inline_cache_type = parent->determine_inline_cache_type(cache_entries.untagged());
parent->update_pic_count(inline_cache_type);
/* Generate machine code to determine the object's class. */
emit_class_lookup(index,inline_cache_type);
@ -127,7 +127,7 @@ void inline_cache_jit::compile_inline_cache(fixnum index,
/* Yes? Jump to method */
cell method = array_nth(cache_entries.untagged(),i + 1);
emit_with(parent_vm->userenv[PIC_HIT],method);
emit_with(parent->userenv[PIC_HIT],method);
}
/* Generate machine code to handle a cache miss, which ultimately results in
@ -139,7 +139,7 @@ void inline_cache_jit::compile_inline_cache(fixnum index,
push(methods.value());
push(tag_fixnum(index));
push(cache_entries.value());
word_special(parent_vm->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
word_special(parent->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
}
code_block *factor_vm::compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p)
@ -248,9 +248,9 @@ void *factor_vm::inline_cache_miss(cell return_address)
return xt;
}
VM_C_API void *inline_cache_miss(cell return_address, factor_vm *myvm)
VM_C_API void *inline_cache_miss(cell return_address, factor_vm *parent)
{
return myvm->inline_cache_miss(return_address);
return parent->inline_cache_miss(return_address);
}
void factor_vm::primitive_reset_inline_cache_stats()

12
vm/io.cpp
View File

@ -16,9 +16,9 @@ normal operation. */
void factor_vm::init_c_io()
{
userenv[STDIN_ENV] = allot_alien(F,(cell)stdin);
userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout);
userenv[STDERR_ENV] = allot_alien(F,(cell)stderr);
userenv[STDIN_ENV] = allot_alien(false_object,(cell)stdin);
userenv[STDOUT_ENV] = allot_alien(false_object,(cell)stdout);
userenv[STDERR_ENV] = allot_alien(false_object,(cell)stderr);
}
void factor_vm::io_error()
@ -28,7 +28,7 @@ void factor_vm::io_error()
return;
#endif
general_error(ERROR_IO,tag_fixnum(errno),F,NULL);
general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL);
}
void factor_vm::primitive_fopen()
@ -63,7 +63,7 @@ void factor_vm::primitive_fgetc()
{
if(feof(file))
{
dpush(F);
dpush(false_object);
break;
}
else
@ -97,7 +97,7 @@ void factor_vm::primitive_fread()
{
if(feof(file))
{
dpush(F);
dpush(false_object);
break;
}
else

20
vm/jit.cpp
View File

@ -19,12 +19,12 @@ jit::jit(cell type_, cell owner_, factor_vm *vm)
computing_offset_p(false),
position(0),
offset(0),
parent_vm(vm)
parent(vm)
{}
void jit::emit_relocation(cell code_template_)
{
gc_root<array> code_template(code_template_,parent_vm);
gc_root<array> code_template(code_template_,parent);
cell capacity = array_capacity(code_template.untagged());
for(cell i = 1; i < capacity; i += 3)
{
@ -43,11 +43,11 @@ void jit::emit_relocation(cell code_template_)
/* Allocates memory */
void jit::emit(cell code_template_)
{
gc_root<array> code_template(code_template_,parent_vm);
gc_root<array> code_template(code_template_,parent);
emit_relocation(code_template.value());
gc_root<byte_array> insns(array_nth(code_template.untagged(),0),parent_vm);
gc_root<byte_array> insns(array_nth(code_template.untagged(),0),parent);
if(computing_offset_p)
{
@ -71,16 +71,16 @@ void jit::emit(cell code_template_)
}
void jit::emit_with(cell code_template_, cell argument_) {
gc_root<array> code_template(code_template_,parent_vm);
gc_root<object> argument(argument_,parent_vm);
gc_root<array> code_template(code_template_,parent);
gc_root<object> argument(argument_,parent);
literal(argument.value());
emit(code_template.value());
}
void jit::emit_class_lookup(fixnum index, cell type)
{
emit_with(parent_vm->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
emit(parent_vm->userenv[type]);
emit_with(parent->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
emit(parent->userenv[type]);
}
/* Facility to convert compiled code offsets to quotation offsets.
@ -100,10 +100,10 @@ code_block *jit::to_code_block()
relocation.trim();
literals.trim();
return parent_vm->add_code_block(
return parent->add_code_block(
type,
code.elements.value(),
F, /* no labels */
false_object, /* no labels */
owner.value(),
relocation.elements.value(),
literals.elements.value());

21
vm/jit.hpp
View File

@ -10,7 +10,7 @@ struct jit {
bool computing_offset_p;
fixnum position;
cell offset;
factor_vm *parent_vm;
factor_vm *parent;
explicit jit(cell jit_type, cell owner, factor_vm *vm);
void compute_position(cell offset);
@ -22,27 +22,28 @@ struct jit {
void emit_with(cell code_template_, cell literal_);
void push(cell literal) {
emit_with(parent_vm->userenv[JIT_PUSH_IMMEDIATE],literal);
emit_with(parent->userenv[JIT_PUSH_IMMEDIATE],literal);
}
void word_jump(cell word) {
void word_jump(cell word_) {
gc_root<word> word(word_,parent);
literal(tag_fixnum(xt_tail_pic_offset));
literal(word);
emit(parent_vm->userenv[JIT_WORD_JUMP]);
literal(word.value());
emit(parent->userenv[JIT_WORD_JUMP]);
}
void word_call(cell word) {
emit_with(parent_vm->userenv[JIT_WORD_CALL],word);
emit_with(parent->userenv[JIT_WORD_CALL],word);
}
void word_special(cell word) {
emit_with(parent_vm->userenv[JIT_WORD_SPECIAL],word);
emit_with(parent->userenv[JIT_WORD_SPECIAL],word);
}
void emit_subprimitive(cell word_) {
gc_root<word> word(word_,parent_vm);
gc_root<array> code_pair(word->subprimitive,parent_vm);
literals.append(parent_vm->untag<array>(array_nth(code_pair.untagged(),0)));
gc_root<word> word(word_,parent);
gc_root<array> code_pair(word->subprimitive,parent);
literals.append(parent->untag<array>(array_nth(code_pair.untagged(),0)));
emit(array_nth(code_pair.untagged(),1));
}

8
vm/layouts.hpp
View File

@ -46,9 +46,6 @@ inline static cell align8(cell a)
#define OBJECT_TYPE 6
#define TUPLE_TYPE 7
/* Canonical F object */
#define F F_TYPE
#define HEADER_TYPE 8 /* anything less than this is a tag */
#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
@ -78,9 +75,12 @@ enum
FP_TRAP_INEXACT = 1 << 4,
};
/* What Factor calls 'f' */
static const cell false_object = F_TYPE;
inline static bool immediate_p(cell obj)
{
return (obj == F || TAG(obj) == FIXNUM_TYPE);
return (obj == false_object || TAG(obj) == FIXNUM_TYPE);
}
inline static fixnum untag_fixnum(cell tagged)

24
vm/local_roots.hpp
View File

@ -4,21 +4,21 @@ namespace factor
template<typename Type>
struct gc_root : public tagged<Type>
{
factor_vm *parent_vm;
factor_vm *parent;
void push() { parent_vm->check_tagged_pointer(tagged<Type>::value()); parent_vm->gc_locals.push_back((cell)this); }
void push() { parent->check_tagged_pointer(tagged<Type>::value()); parent->gc_locals.push_back((cell)this); }
explicit gc_root(cell value_,factor_vm *vm) : tagged<Type>(value_),parent_vm(vm) { push(); }
explicit gc_root(Type *value_, factor_vm *vm) : tagged<Type>(value_),parent_vm(vm) { push(); }
explicit gc_root(cell value_,factor_vm *vm) : tagged<Type>(value_),parent(vm) { push(); }
explicit gc_root(Type *value_, factor_vm *vm) : tagged<Type>(value_),parent(vm) { push(); }
const gc_root<Type>& operator=(const Type *x) { tagged<Type>::operator=(x); return *this; }
const gc_root<Type>& operator=(const cell &x) { tagged<Type>::operator=(x); return *this; }
~gc_root() {
#ifdef FACTOR_DEBUG
assert(parent_vm->gc_locals.back() == (cell)this);
assert(parent->gc_locals.back() == (cell)this);
#endif
parent_vm->gc_locals.pop_back();
parent->gc_locals.pop_back();
}
};
@ -26,18 +26,18 @@ struct gc_root : public tagged<Type>
struct gc_bignum
{
bignum **addr;
factor_vm *parent_vm;
gc_bignum(bignum **addr_, factor_vm *vm) : addr(addr_), parent_vm(vm) {
factor_vm *parent;
gc_bignum(bignum **addr_, factor_vm *vm) : addr(addr_), parent(vm) {
if(*addr_)
parent_vm->check_data_pointer(*addr_);
parent_vm->gc_bignums.push_back((cell)addr);
parent->check_data_pointer(*addr_);
parent->gc_bignums.push_back((cell)addr);
}
~gc_bignum() {
#ifdef FACTOR_DEBUG
assert(parent_vm->gc_bignums.back() == (cell)addr);
assert(parent->gc_bignums.back() == (cell)addr);
#endif
parent_vm->gc_bignums.pop_back();
parent->gc_bignums.pop_back();
}
};

90
vm/math.cpp
View File

@ -219,9 +219,9 @@ unsigned int factor_vm::bignum_producer(unsigned int digit)
return *(ptr + digit);
}
unsigned int bignum_producer(unsigned int digit, factor_vm *myvm)
unsigned int bignum_producer(unsigned int digit, factor_vm *parent)
{
return myvm->bignum_producer(digit);
return parent->bignum_producer(digit);
}
void factor_vm::primitive_byte_array_to_bignum()
@ -285,7 +285,7 @@ void factor_vm::primitive_str_to_float()
if(end == c_str + capacity - 1)
drepl(allot_float(f));
else
drepl(F);
drepl(false_object);
}
void factor_vm::primitive_float_to_str()
@ -393,9 +393,9 @@ fixnum factor_vm::to_fixnum(cell tagged)
}
}
VM_C_API fixnum to_fixnum(cell tagged,factor_vm *myvm)
VM_C_API fixnum to_fixnum(cell tagged,factor_vm *parent)
{
return myvm->to_fixnum(tagged);
return parent->to_fixnum(tagged);
}
cell factor_vm::to_cell(cell tagged)
@ -403,9 +403,9 @@ cell factor_vm::to_cell(cell tagged)
return (cell)to_fixnum(tagged);
}
VM_C_API cell to_cell(cell tagged, factor_vm *myvm)
VM_C_API cell to_cell(cell tagged, factor_vm *parent)
{
return myvm->to_cell(tagged);
return parent->to_cell(tagged);
}
void factor_vm::box_signed_1(s8 n)
@ -413,9 +413,9 @@ void factor_vm::box_signed_1(s8 n)
dpush(tag_fixnum(n));
}
VM_C_API void box_signed_1(s8 n,factor_vm *myvm)
VM_C_API void box_signed_1(s8 n,factor_vm *parent)
{
return myvm->box_signed_1(n);
return parent->box_signed_1(n);
}
void factor_vm::box_unsigned_1(u8 n)
@ -423,9 +423,9 @@ void factor_vm::box_unsigned_1(u8 n)
dpush(tag_fixnum(n));
}
VM_C_API void box_unsigned_1(u8 n,factor_vm *myvm)
VM_C_API void box_unsigned_1(u8 n,factor_vm *parent)
{
return myvm->box_unsigned_1(n);
return parent->box_unsigned_1(n);
}
void factor_vm::box_signed_2(s16 n)
@ -433,9 +433,9 @@ void factor_vm::box_signed_2(s16 n)
dpush(tag_fixnum(n));
}
VM_C_API void box_signed_2(s16 n,factor_vm *myvm)
VM_C_API void box_signed_2(s16 n,factor_vm *parent)
{
return myvm->box_signed_2(n);
return parent->box_signed_2(n);
}
void factor_vm::box_unsigned_2(u16 n)
@ -443,9 +443,9 @@ void factor_vm::box_unsigned_2(u16 n)
dpush(tag_fixnum(n));
}
VM_C_API void box_unsigned_2(u16 n,factor_vm *myvm)
VM_C_API void box_unsigned_2(u16 n,factor_vm *parent)
{
return myvm->box_unsigned_2(n);
return parent->box_unsigned_2(n);
}
void factor_vm::box_signed_4(s32 n)
@ -453,9 +453,9 @@ void factor_vm::box_signed_4(s32 n)
dpush(allot_integer(n));
}
VM_C_API void box_signed_4(s32 n,factor_vm *myvm)
VM_C_API void box_signed_4(s32 n,factor_vm *parent)
{
return myvm->box_signed_4(n);
return parent->box_signed_4(n);
}
void factor_vm::box_unsigned_4(u32 n)
@ -463,9 +463,9 @@ void factor_vm::box_unsigned_4(u32 n)
dpush(allot_cell(n));
}
VM_C_API void box_unsigned_4(u32 n,factor_vm *myvm)
VM_C_API void box_unsigned_4(u32 n,factor_vm *parent)
{
return myvm->box_unsigned_4(n);
return parent->box_unsigned_4(n);
}
void factor_vm::box_signed_cell(fixnum integer)
@ -473,9 +473,9 @@ void factor_vm::box_signed_cell(fixnum integer)
dpush(allot_integer(integer));
}
VM_C_API void box_signed_cell(fixnum integer,factor_vm *myvm)
VM_C_API void box_signed_cell(fixnum integer,factor_vm *parent)
{
return myvm->box_signed_cell(integer);
return parent->box_signed_cell(integer);
}
void factor_vm::box_unsigned_cell(cell cell)
@ -483,9 +483,9 @@ void factor_vm::box_unsigned_cell(cell cell)
dpush(allot_cell(cell));
}
VM_C_API void box_unsigned_cell(cell cell,factor_vm *myvm)
VM_C_API void box_unsigned_cell(cell cell,factor_vm *parent)
{
return myvm->box_unsigned_cell(cell);
return parent->box_unsigned_cell(cell);
}
void factor_vm::box_signed_8(s64 n)
@ -496,9 +496,9 @@ void factor_vm::box_signed_8(s64 n)
dpush(tag_fixnum(n));
}
VM_C_API void box_signed_8(s64 n,factor_vm *myvm)
VM_C_API void box_signed_8(s64 n,factor_vm *parent)
{
return myvm->box_signed_8(n);
return parent->box_signed_8(n);
}
s64 factor_vm::to_signed_8(cell obj)
@ -515,9 +515,9 @@ s64 factor_vm::to_signed_8(cell obj)
}
}
VM_C_API s64 to_signed_8(cell obj,factor_vm *myvm)
VM_C_API s64 to_signed_8(cell obj,factor_vm *parent)
{
return myvm->to_signed_8(obj);
return parent->to_signed_8(obj);
}
void factor_vm::box_unsigned_8(u64 n)
@ -528,9 +528,9 @@ void factor_vm::box_unsigned_8(u64 n)
dpush(tag_fixnum(n));
}
VM_C_API void box_unsigned_8(u64 n,factor_vm *myvm)
VM_C_API void box_unsigned_8(u64 n,factor_vm *parent)
{
return myvm->box_unsigned_8(n);
return parent->box_unsigned_8(n);
}
u64 factor_vm::to_unsigned_8(cell obj)
@ -547,9 +547,9 @@ u64 factor_vm::to_unsigned_8(cell obj)
}
}
VM_C_API u64 to_unsigned_8(cell obj,factor_vm *myvm)
VM_C_API u64 to_unsigned_8(cell obj,factor_vm *parent)
{
return myvm->to_unsigned_8(obj);
return parent->to_unsigned_8(obj);
}
void factor_vm::box_float(float flo)
@ -557,9 +557,9 @@ void factor_vm::box_float(float flo)
dpush(allot_float(flo));
}
VM_C_API void box_float(float flo, factor_vm *myvm)
VM_C_API void box_float(float flo, factor_vm *parent)
{
return myvm->box_float(flo);
return parent->box_float(flo);
}
float factor_vm::to_float(cell value)
@ -567,9 +567,9 @@ float factor_vm::to_float(cell value)
return untag_float_check(value);
}
VM_C_API float to_float(cell value,factor_vm *myvm)
VM_C_API float to_float(cell value,factor_vm *parent)
{
return myvm->to_float(value);
return parent->to_float(value);
}
void factor_vm::box_double(double flo)
@ -577,9 +577,9 @@ void factor_vm::box_double(double flo)
dpush(allot_float(flo));
}
VM_C_API void box_double(double flo,factor_vm *myvm)
VM_C_API void box_double(double flo,factor_vm *parent)
{
return myvm->box_double(flo);
return parent->box_double(flo);
}
double factor_vm::to_double(cell value)
@ -587,9 +587,9 @@ double factor_vm::to_double(cell value)
return untag_float_check(value);
}
VM_C_API double to_double(cell value,factor_vm *myvm)
VM_C_API double to_double(cell value,factor_vm *parent)
{
return myvm->to_double(value);
return parent->to_double(value);
}
/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
@ -600,9 +600,9 @@ inline void factor_vm::overflow_fixnum_add(fixnum x, fixnum y)
untag_fixnum(x) + untag_fixnum(y))));
}
VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *myvm)
VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *parent)
{
((factor_vm*)myvm)->overflow_fixnum_add(x,y);
parent->overflow_fixnum_add(x,y);
}
inline void factor_vm::overflow_fixnum_subtract(fixnum x, fixnum y)
@ -611,9 +611,9 @@ inline void factor_vm::overflow_fixnum_subtract(fixnum x, fixnum y)
untag_fixnum(x) - untag_fixnum(y))));
}
VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *myvm)
VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *parent)
{
((factor_vm*)myvm)->overflow_fixnum_subtract(x,y);
parent->overflow_fixnum_subtract(x,y);
}
inline void factor_vm::overflow_fixnum_multiply(fixnum x, fixnum y)
@ -625,9 +625,9 @@ inline void factor_vm::overflow_fixnum_multiply(fixnum x, fixnum y)
drepl(tag<bignum>(bignum_multiply(bx,by)));
}
VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *myvm)
VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *parent)
{
((factor_vm*)myvm)->overflow_fixnum_multiply(x,y);
parent->overflow_fixnum_multiply(x,y);
}
}

10
vm/nursery_collector.cpp
View File

@ -3,12 +3,12 @@
namespace factor
{
nursery_collector::nursery_collector(factor_vm *myvm_) :
nursery_collector::nursery_collector(factor_vm *parent_) :
copying_collector<aging_space,nursery_policy>(
myvm_,
&myvm_->gc_stats.nursery_stats,
myvm_->data->aging,
nursery_policy(myvm_)) {}
parent_,
&parent_->gc_stats.nursery_stats,
parent_->data->aging,
nursery_policy(parent_)) {}
void factor_vm::collect_nursery()
{

8
vm/nursery_collector.hpp
View File

@ -2,18 +2,18 @@ namespace factor
{
struct nursery_policy {
factor_vm *myvm;
factor_vm *parent;
nursery_policy(factor_vm *myvm_) : myvm(myvm_) {}
nursery_policy(factor_vm *parent_) : parent(parent_) {}
bool should_copy_p(object *untagged)
{
return myvm->nursery.contains_p(untagged);
return parent->nursery.contains_p(untagged);
}
};
struct nursery_collector : copying_collector<aging_space,nursery_policy> {
nursery_collector(factor_vm *myvm_);
nursery_collector(factor_vm *parent_);
};
}

4
vm/old_space.cpp
View File

@ -62,9 +62,9 @@ void old_space::clear_object_start_offsets()
memset(object_start_offsets,card_starts_inside_object,addr_to_card(size));
}
cell old_space::next_object_after(factor_vm *myvm, cell scan)
cell old_space::next_object_after(factor_vm *parent, cell scan)
{
cell size = myvm->untagged_object_size((object *)scan);
cell size = parent->untagged_object_size((object *)scan);
if(scan + size < here)
return scan + size;
else

2
vm/old_space.hpp
View File

@ -15,7 +15,7 @@ struct old_space : zone {
void record_object_start_offset(object *obj);
object *allot(cell size);
void clear_object_start_offsets();
cell next_object_after(factor_vm *myvm, cell scan);
cell next_object_after(factor_vm *parent, cell scan);
};
}

6
vm/os-linux.cpp
View File

@ -45,19 +45,19 @@ VM_C_API int inotify_rm_watch(int fd, u32 wd)
VM_C_API int inotify_init()
{
myvm->not_implemented_error();
parent->not_implemented_error();
return -1;
}
VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask)
{
myvm->not_implemented_error();
parent->not_implemented_error();
return -1;
}
VM_C_API int inotify_rm_watch(int fd, u32 wd)
{
myvm->not_implemented_error();
parent->not_implemented_error();
return -1;
}

2
vm/os-macosx.mm
View File

@ -13,7 +13,7 @@ NS_DURING
c_to_factor(quot,this);
NS_VOIDRETURN;
NS_HANDLER
dpush(allot_alien(F,(cell)localException));
dpush(allot_alien(false_object,(cell)localException));
quot = userenv[COCOA_EXCEPTION_ENV];
if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
{

2
vm/os-unix.cpp
View File

@ -72,7 +72,7 @@ void *factor_vm::ffi_dlsym(dll *dll, symbol_char *symbol)
void factor_vm::ffi_dlclose(dll *dll)
{
if(dlclose(dll->dll))
general_error(ERROR_FFI,F,F,NULL);
general_error(ERROR_FFI,false_object,false_object,NULL);
dll->dll = NULL;
}

20
vm/primitives.hpp
View File

@ -2,18 +2,18 @@ namespace factor
{
#if defined(FACTOR_X86)
extern "C" __attribute__ ((regparm (1))) typedef void (*primitive_type)(void *myvm);
#define PRIMITIVE(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(void *myvm)
#define PRIMITIVE_FORWARD(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(void *myvm) \
{ \
((factor_vm*)myvm)->primitive_##name(); \
extern "C" __attribute__ ((regparm (1))) typedef void (*primitive_type)(factor_vm *parent);
#define PRIMITIVE(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(factor_vm *parent)
#define PRIMITIVE_FORWARD(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(factor_vm *parent) \
{ \
parent->primitive_##name(); \
}
#else
extern "C" typedef void (*primitive_type)(void *myvm);
#define PRIMITIVE(name) extern "C" void primitive_##name(void *myvm)
#define PRIMITIVE_FORWARD(name) extern "C" void primitive_##name(void *myvm) \
{ \
((factor_vm*)myvm)->primitive_##name(); \
extern "C" typedef void (*primitive_type)(factor_vm *parent);
#define PRIMITIVE(name) extern "C" void primitive_##name(factor_vm *parent)
#define PRIMITIVE_FORWARD(name) extern "C" void primitive_##name(factor_vm *parent) \
{ \
parent->primitive_##name(); \
}
#endif
extern const primitive_type primitives[];

66
vm/quotations.cpp
View File

@ -38,29 +38,29 @@ so this results in a big speedup for relatively little effort. */
bool quotation_jit::primitive_call_p(cell i, cell length)
{
return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_PRIMITIVE_WORD];
return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_PRIMITIVE_WORD];
}
bool quotation_jit::fast_if_p(cell i, cell length)
{
return (i + 3) == length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
&& array_nth(elements.untagged(),i + 2) == parent_vm->userenv[JIT_IF_WORD];
&& array_nth(elements.untagged(),i + 2) == parent->userenv[JIT_IF_WORD];
}
bool quotation_jit::fast_dip_p(cell i, cell length)
{
return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DIP_WORD];
return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_DIP_WORD];
}
bool quotation_jit::fast_2dip_p(cell i, cell length)
{
return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_2DIP_WORD];
return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_2DIP_WORD];
}
bool quotation_jit::fast_3dip_p(cell i, cell length)
{
return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_3DIP_WORD];
return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_3DIP_WORD];
}
bool quotation_jit::mega_lookup_p(cell i, cell length)
@ -68,13 +68,13 @@ bool quotation_jit::mega_lookup_p(cell i, cell length)
return (i + 4) <= length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE)
&& array_nth(elements.untagged(),i + 3) == parent_vm->userenv[MEGA_LOOKUP_WORD];
&& array_nth(elements.untagged(),i + 3) == parent->userenv[MEGA_LOOKUP_WORD];
}
bool quotation_jit::declare_p(cell i, cell length)
{
return (i + 2) <= length
&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DECLARE_WORD];
&& array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_DECLARE_WORD];
}
bool quotation_jit::stack_frame_p()
@ -88,7 +88,7 @@ bool quotation_jit::stack_frame_p()
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
if(parent_vm->untag<word>(obj)->subprimitive == F)
if(!parent->to_boolean(parent->untag<word>(obj)->subprimitive))
return true;
break;
case QUOTATION_TYPE:
@ -110,9 +110,9 @@ bool quotation_jit::trivial_quotation_p(array *elements)
void quotation_jit::emit_quot(cell quot_)
{
gc_root<quotation> quot(quot_,parent_vm);
gc_root<quotation> quot(quot_,parent);
array *elements = parent_vm->untag<array>(quot->array);
array *elements = parent->untag<array>(quot->array);
/* If the quotation consists of a single word, compile a direct call
to the word. */
@ -120,7 +120,7 @@ void quotation_jit::emit_quot(cell quot_)
literal(array_nth(elements,0));
else
{
if(compiling) parent_vm->jit_compile(quot.value(),relocate);
if(compiling) parent->jit_compile(quot.value(),relocate);
literal(quot.value());
}
}
@ -133,7 +133,7 @@ void quotation_jit::iterate_quotation()
set_position(0);
if(stack_frame)
emit(parent_vm->userenv[JIT_PROLOG]);
emit(parent->userenv[JIT_PROLOG]);
cell i;
cell length = array_capacity(elements.untagged());
@ -143,32 +143,32 @@ void quotation_jit::iterate_quotation()
{
set_position(i);
gc_root<object> obj(array_nth(elements.untagged(),i),parent_vm);
gc_root<object> obj(array_nth(elements.untagged(),i),parent);
switch(obj.type())
{
case WORD_TYPE:
/* Intrinsics */
if(obj.as<word>()->subprimitive != F)
if(parent->to_boolean(obj.as<word>()->subprimitive))
emit_subprimitive(obj.value());
/* The (execute) primitive is special-cased */
else if(obj.value() == parent_vm->userenv[JIT_EXECUTE_WORD])
else if(obj.value() == parent->userenv[JIT_EXECUTE_WORD])
{
if(i == length - 1)
{
if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]);
if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
tail_call = true;
emit(parent_vm->userenv[JIT_EXECUTE_JUMP]);
emit(parent->userenv[JIT_EXECUTE_JUMP]);
}
else
emit(parent_vm->userenv[JIT_EXECUTE_CALL]);
emit(parent->userenv[JIT_EXECUTE_CALL]);
}
/* Everything else */
else
{
if(i == length - 1)
{
if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]);
if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
tail_call = true;
/* Inline cache misses are special-cased.
The calling convention for tail
@ -178,8 +178,8 @@ void quotation_jit::iterate_quotation()
the inline cache miss primitive, and
we don't want to clobber the saved
address. */
if(obj.value() == parent_vm->userenv[PIC_MISS_WORD]
|| obj.value() == parent_vm->userenv[PIC_MISS_TAIL_WORD])
if(obj.value() == parent->userenv[PIC_MISS_WORD]
|| obj.value() == parent->userenv[PIC_MISS_TAIL_WORD])
{
word_special(obj.value());
}
@ -201,7 +201,7 @@ void quotation_jit::iterate_quotation()
{
literal(tag_fixnum(0));
literal(obj.value());
emit(parent_vm->userenv[JIT_PRIMITIVE]);
emit(parent->userenv[JIT_PRIMITIVE]);
i++;
@ -215,12 +215,12 @@ void quotation_jit::iterate_quotation()
mutually recursive in the library, but both still work) */
if(fast_if_p(i,length))
{
if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]);
if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
tail_call = true;
emit_quot(array_nth(elements.untagged(),i));
emit_quot(array_nth(elements.untagged(),i + 1));
emit(parent_vm->userenv[JIT_IF]);
emit(parent->userenv[JIT_IF]);
i += 2;
}
@ -228,21 +228,21 @@ void quotation_jit::iterate_quotation()
else if(fast_dip_p(i,length))
{
emit_quot(obj.value());
emit(parent_vm->userenv[JIT_DIP]);
emit(parent->userenv[JIT_DIP]);
i++;
}
/* 2dip */
else if(fast_2dip_p(i,length))
{
emit_quot(obj.value());
emit(parent_vm->userenv[JIT_2DIP]);
emit(parent->userenv[JIT_2DIP]);
i++;
}
/* 3dip */
else if(fast_3dip_p(i,length))
{
emit_quot(obj.value());
emit(parent_vm->userenv[JIT_3DIP]);
emit(parent->userenv[JIT_3DIP]);
i++;
}
else
@ -276,8 +276,8 @@ void quotation_jit::iterate_quotation()
set_position(length);
if(stack_frame)
emit(parent_vm->userenv[JIT_EPILOG]);
emit(parent_vm->userenv[JIT_RETURN]);
emit(parent->userenv[JIT_EPILOG]);
emit(parent->userenv[JIT_RETURN]);
}
}
@ -313,8 +313,8 @@ void factor_vm::primitive_array_to_quotation()
{
quotation *quot = allot<quotation>(sizeof(quotation));
quot->array = dpeek();
quot->cached_effect = F;
quot->cache_counter = F;
quot->cached_effect = false_object;
quot->cache_counter = false_object;
quot->xt = (void *)lazy_jit_compile;
quot->code = NULL;
drepl(tag<quotation>(quot));
@ -367,9 +367,9 @@ cell factor_vm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
return quot.value();
}
VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *myvm)
VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *parent)
{
return myvm->lazy_jit_compile_impl(quot_,stack);
return parent->lazy_jit_compile_impl(quot_,stack);
}
void factor_vm::primitive_quot_compiled_p()

2
vm/quotations.hpp
View File

@ -25,6 +25,6 @@ struct quotation_jit : public jit {
void iterate_quotation();
};
VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *myvm);
VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *parent);
}

16
vm/strings.cpp
View File

@ -35,7 +35,9 @@ void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
str->data()[index] = ((ch & 0x7f) | 0x80);
if(str->aux == F)
if(to_boolean(str->aux))
aux = untag<byte_array>(str->aux);
else
{
/* We don't need to pre-initialize the
byte array with any data, since we
@ -48,8 +50,6 @@ void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
str->aux = tag<byte_array>(aux);
write_barrier(&str->aux);
}
else
aux = untag<byte_array>(str->aux);
aux->data<u16>()[index] = ((ch >> 7) ^ 1);
}
@ -69,8 +69,8 @@ string *factor_vm::allot_string_internal(cell capacity)
string *str = allot<string>(string_size(capacity));
str->length = tag_fixnum(capacity);
str->hashcode = F;
str->aux = F;
str->hashcode = false_object;
str->aux = false_object;
return str;
}
@ -109,7 +109,7 @@ void factor_vm::primitive_string()
bool factor_vm::reallot_string_in_place_p(string *str, cell capacity)
{
return nursery.contains_p(str)
&& (str->aux == F || nursery.contains_p(untag<byte_array>(str->aux)))
&& (!to_boolean(str->aux) || nursery.contains_p(untag<byte_array>(str->aux)))
&& capacity <= string_capacity(str);
}
@ -121,7 +121,7 @@ string* factor_vm::reallot_string(string *str_, cell capacity)
{
str->length = tag_fixnum(capacity);
if(str->aux != F)
if(to_boolean(str->aux))
{
byte_array *aux = untag<byte_array>(str->aux);
aux->capacity = tag_fixnum(capacity * 2);
@ -139,7 +139,7 @@ string* factor_vm::reallot_string(string *str_, cell capacity)
memcpy(new_str->data(),str->data(),to_copy);
if(str->aux != F)
if(to_boolean(str->aux))
{
byte_array *new_aux = allot_byte_array(capacity * sizeof(u16));

4
vm/tagged.hpp
View File

@ -29,9 +29,9 @@ struct tagged
bool type_p(cell type_) const { return type() == type_; }
Type *untag_check(factor_vm *myvm) const {
Type *untag_check(factor_vm *parent) const {
if(Type::type_number != TYPE_COUNT && !type_p(Type::type_number))
myvm->type_error(Type::type_number,value_);
parent->type_error(Type::type_number,value_);
return untagged();
}

2
vm/tuples.cpp
View File

@ -18,7 +18,7 @@ void factor_vm::primitive_tuple()
tuple *t = allot_tuple(layout.value());
fixnum i;
for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--)
t->data()[i] = F;
t->data()[i] = false_object;
dpush(tag<tuple>(t));
}

4
vm/vm.hpp
View File

@ -26,8 +26,8 @@ struct factor_vm
/* Pooling unused contexts to make callbacks cheaper */
context *unused_contexts;
/* Canonical T object. It's just a word */
cell T;
/* Canonical truth value. In Factor, 't' */
cell true_object;
/* Is call counting enabled? */
bool profiling_p;

8
vm/words.cpp
View File

@ -14,11 +14,11 @@ word *factor_vm::allot_word(cell name_, cell vocab_, cell hashcode_)
new_word->vocabulary = vocab.value();
new_word->name = name.value();
new_word->def = userenv[UNDEFINED_ENV];
new_word->props = F;
new_word->props = false_object;
new_word->counter = tag_fixnum(0);
new_word->pic_def = F;
new_word->pic_tail_def = F;
new_word->subprimitive = F;
new_word->pic_def = false_object;
new_word->pic_tail_def = false_object;
new_word->subprimitive = false_object;
new_word->profiling = NULL;
new_word->code = NULL;