{ $values { "type" string } { "size" math:integer } }
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
{ $examples
- "On a 32-bit system, you will get the following output:"
- { $unchecked-example "USE: alien\n\"void*\" heap-size ." "4" }
+ { $example "USING: alien alien.c-types prettyprint ;\nint heap-size ." "4" }
}
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
PREDICATE: c-type-word < word
"c-type" word-prop ;
-UNION: c-type-name string c-type-word ;
+UNION: c-type-name string word ;
! C type protocol
GENERIC: c-type ( name -- type ) foldable
M: ushort-8-rep rep-component-type drop ushort ;
M: int-4-rep rep-component-type drop int ;
M: uint-4-rep rep-component-type drop uint ;
+M: longlong-2-rep rep-component-type drop longlong ;
+M: ulonglong-2-rep rep-component-type drop ulonglong ;
M: float-4-rep rep-component-type drop float ;
M: double-2-rep rep-component-type drop double ;
T-class c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
-number >>boxed-class
+complex >>boxed-class
drop
;FUNCTOR
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
-M: ##vm-field-ptr insn-slot# fieldname>> 1array ; ! is this right?
+M: ##vm-field-ptr insn-slot# field-name>> ; ! is this right?
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
use: src1 src2
literal: rep ;
+PURE-INSN: ##shl-vector
+def: dst
+use: src1 src2/scalar-rep
+literal: rep ;
+
+PURE-INSN: ##shr-vector
+def: dst
+use: src1 src2/scalar-rep
+literal: rep ;
+
+! Scalar/integer conversion
+PURE-INSN: ##scalar>integer
+def: dst/int-rep
+use: src
+literal: rep ;
+
+PURE-INSN: ##integer>scalar
+def: dst
+use: src/int-rep
+literal: rep ;
+
! Boxing and unboxing aliens
PURE-INSN: ##box-alien
def: dst/int-rep
INSN: ##vm-field-ptr
def: dst/int-rep
-literal: fieldname ;
+literal: field-name ;
! FFI
INSN: ##alien-invoke
{ math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
USING: kernel accessors sequences arrays fry namespaces generic
words sets combinators generalizations cpu.architecture compiler.units
compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
-compiler.cfg.instructions compiler.cfg.instructions.syntax
-compiler.cfg.def-use ;
+compiler.cfg.instructions compiler.cfg.def-use ;
+FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ;
IN: compiler.cfg.representations.preferred
GENERIC: defs-vreg-rep ( insn -- rep/f )
! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry accessors sequences assocs sets namespaces
-arrays combinators make locals deques dlists
+arrays combinators make locals deques dlists layouts
cpu.architecture compiler.utilities
compiler.cfg
compiler.cfg.rpo
GENERIC: emit-box ( dst src rep -- )
GENERIC: emit-unbox ( dst src rep -- )
-M: float-rep emit-box
- drop
- [ double-rep next-vreg-rep dup ] dip ##single>double-float
- int-rep next-vreg-rep ##box-float ;
+M:: float-rep emit-box ( dst src rep -- )
+ double-rep next-vreg-rep :> temp
+ temp src ##single>double-float
+ dst temp int-rep next-vreg-rep ##box-float ;
-M: float-rep emit-unbox
- drop
- [ double-rep next-vreg-rep dup ] dip ##unbox-float
- ##double>single-float ;
+M:: float-rep emit-unbox ( dst src rep -- )
+ double-rep next-vreg-rep :> temp
+ temp src ##unbox-float
+ dst temp ##double>single-float ;
M: double-rep emit-box
- drop
- int-rep next-vreg-rep ##box-float ;
+ drop int-rep next-vreg-rep ##box-float ;
M: double-rep emit-unbox
drop ##unbox-float ;
M: vector-rep emit-unbox
##unbox-vector ;
+M:: scalar-rep emit-box ( dst src rep -- )
+ int-rep next-vreg-rep :> temp
+ temp src rep ##scalar>integer
+ dst temp tag-bits get ##shl-imm ;
+
+M:: scalar-rep emit-unbox ( dst src rep -- )
+ int-rep next-vreg-rep :> temp
+ temp src tag-bits get ##sar-imm
+ dst temp rep ##integer>scalar ;
+
: emit-conversion ( dst src dst-rep src-rep -- )
{
{ [ 2dup eq? ] [ drop ##copy ] }
##max-vector
##and-vector
##or-vector
- ##xor-vector ;
+ ##xor-vector
+ ##shl-vector
+ ##shr-vector ;
GENERIC: convert-two-operand* ( insn -- )
CODEGEN: ##and-vector %and-vector
CODEGEN: ##or-vector %or-vector
CODEGEN: ##xor-vector %xor-vector
+CODEGEN: ##shl-vector %shl-vector
+CODEGEN: ##shr-vector %shr-vector
+CODEGEN: ##integer>scalar %integer>scalar
+CODEGEN: ##scalar>integer %scalar>integer
CODEGEN: ##box-alien %box-alien
CODEGEN: ##box-displaced-alien %box-displaced-alien
CODEGEN: ##unbox-alien %unbox-alien
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
+CODEGEN: ##vm-field-ptr %vm-field-ptr
CODEGEN: _fixnum-add %fixnum-add
CODEGEN: _fixnum-sub %fixnum-sub
[ dst>> ] [ symbol>> ] [ library>> ] tri
%alien-global ;
-M: ##vm-field-ptr generate-insn
- [ dst>> ] [ fieldname>> ] bi %vm-field-ptr ;
-
! ##alien-invoke
GENERIC: next-fastcall-param ( rep -- )
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays system sorting math.libm
-math.intervals quotations effects alien ;
+math.intervals quotations effects alien alien.data ;
FROM: math => float ;
SPECIALIZED-ARRAY: double
IN: compiler.tree.propagation.tests
[ t ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { /i fixnum/i fixnum/i-fast } inlined? ] unit-test
[ f ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { fixnum-shift-fast } inlined? ] unit-test
[ f ] [ [ >float dup 0 >= [ 16 /i ] when ] { /i float/f } inlined? ] unit-test
+
+! We want this to inline
+[ t ] [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
(simd-vbitand)
(simd-vbitor)
(simd-vbitxor)
+ (simd-vlshift)
+ (simd-vrshift)
(simd-broadcast)
(simd-gather-2)
(simd-gather-4)
literal>> scalar-rep-of {
{ float-rep [ float ] }
{ double-rep [ float ] }
- { int-rep [ integer ] }
+ [ integer ]
} case
] [ drop real ] if
<class-info>
short-8-rep
ushort-8-rep
int-4-rep
-uint-4-rep ;
+uint-4-rep
+longlong-2-rep
+ulonglong-2-rep ;
+
+! Scalar values in the high component of a vector register
+SINGLETONS:
+char-scalar-rep
+uchar-scalar-rep
+short-scalar-rep
+ushort-scalar-rep
+int-scalar-rep
+uint-scalar-rep
+longlong-scalar-rep
+ulonglong-scalar-rep ;
SINGLETONS:
float-4-rep
short-8-rep
ushort-8-rep
int-4-rep
-uint-4-rep ;
+uint-4-rep
+longlong-2-rep
+ulonglong-2-rep ;
+
+UNION: scalar-rep
+char-scalar-rep
+uchar-scalar-rep
+short-scalar-rep
+ushort-scalar-rep
+int-scalar-rep
+uint-scalar-rep
+longlong-scalar-rep
+ulonglong-scalar-rep ;
UNION: float-vector-rep
float-4-rep
int-rep
float-rep
double-rep
-vector-rep ;
+vector-rep
+scalar-rep ;
! Register classes
SINGLETONS: int-regs float-regs ;
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
+! On x86, vectors and floats are stored in the same register bank
+! On PowerPC they are distinct
+HOOK: vector-regs cpu ( -- reg-class )
+
GENERIC: reg-class-of ( rep -- reg-class )
M: tagged-rep reg-class-of drop int-regs ;
M: int-rep reg-class-of drop int-regs ;
M: float-rep reg-class-of drop float-regs ;
M: double-rep reg-class-of drop float-regs ;
-M: vector-rep reg-class-of drop float-regs ;
+M: vector-rep reg-class-of drop vector-regs ;
+M: scalar-rep reg-class-of drop vector-regs ;
M: stack-params reg-class-of drop stack-params ;
GENERIC: rep-size ( rep -- n ) foldable
M: float-4-rep scalar-rep-of drop float-rep ;
M: double-2-rep scalar-rep-of drop double-rep ;
-M: int-vector-rep scalar-rep-of drop int-rep ;
+M: char-16-rep scalar-rep-of drop char-scalar-rep ;
+M: uchar-16-rep scalar-rep-of drop uchar-scalar-rep ;
+M: short-8-rep scalar-rep-of drop short-scalar-rep ;
+M: ushort-8-rep scalar-rep-of drop ushort-scalar-rep ;
+M: int-4-rep scalar-rep-of drop int-scalar-rep ;
+M: uint-4-rep scalar-rep-of drop uint-scalar-rep ;
+M: longlong-2-rep scalar-rep-of drop longlong-scalar-rep ;
+M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
HOOK: %and-vector cpu ( dst src1 src2 rep -- )
HOOK: %or-vector cpu ( dst src1 src2 rep -- )
HOOK: %xor-vector cpu ( dst src1 src2 rep -- )
+HOOK: %shl-vector cpu ( dst src1 src2 rep -- )
+HOOK: %shr-vector cpu ( dst src1 src2 rep -- )
+
+HOOK: %integer>scalar cpu ( dst src rep -- )
+HOOK: %scalar>integer cpu ( dst src rep -- )
HOOK: %broadcast-vector-reps cpu ( -- reps )
HOOK: %gather-vector-2-reps cpu ( -- reps )
HOOK: %and-vector-reps cpu ( -- reps )
HOOK: %or-vector-reps cpu ( -- reps )
HOOK: %xor-vector-reps cpu ( -- reps )
+HOOK: %shl-vector-reps cpu ( -- reps )
+HOOK: %shr-vector-reps cpu ( -- reps )
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
dst 1 4 scratch@ LWZ ;
M: ppc %copy ( dst src rep -- )
- {
- { int-rep [ MR ] }
- { double-rep [ FMR ] }
- } case ;
+ 2over eq? [ 3drop ] [
+ {
+ { int-rep [ MR ] }
+ { double-rep [ FMR ] }
+ } case
+ ] if ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
[ float-regs param-regs nth 1 ] [ n>> spill@ ] bi* LFD ;
: float-function-return ( reg -- )
- float-regs return-reg 2dup = [ 2drop ] [ FMR ] if ;
+ float-regs return-reg double-rep %copy ;
M:: ppc %unary-float-function ( dst src func -- )
0 src float-function-param
dst float-function-return ;
! Internal format is always double-precision on PowerPC
-M: ppc %single>double-float FMR ;
-
-M: ppc %double>single-float FMR ;
+M: ppc %single>double-float double-rep %copy ;
+M: ppc %double>single-float double-rep %copy ;
+
+! VMX/AltiVec not supported yet
+M: ppc %broadcast-vector-reps { } ;
+M: ppc %gather-vector-2-reps { } ;
+M: ppc %gather-vector-4-reps { } ;
+M: ppc %add-vector-reps { } ;
+M: ppc %saturated-add-vector-reps { } ;
+M: ppc %add-sub-vector-reps { } ;
+M: ppc %sub-vector-reps { } ;
+M: ppc %saturated-sub-vector-reps { } ;
+M: ppc %mul-vector-reps { } ;
+M: ppc %saturated-mul-vector-reps { } ;
+M: ppc %div-vector-reps { } ;
+M: ppc %min-vector-reps { } ;
+M: ppc %max-vector-reps { } ;
+M: ppc %sqrt-vector-reps { } ;
+M: ppc %horizontal-add-vector-reps { } ;
+M: ppc %abs-vector-reps { } ;
+M: ppc %and-vector-reps { } ;
+M: ppc %or-vector-reps { } ;
+M: ppc %xor-vector-reps { } ;
M: ppc %unbox-alien ( dst src -- )
alien-offset LWZ ;
: shift-arg ( -- reg ) ECX ;
: div-arg ( -- reg ) EAX ;
: mod-arg ( -- reg ) EDX ;
-: arg ( -- reg ) EAX ;
+: arg1 ( -- reg ) EAX ;
: arg2 ( -- reg ) EDX ;
: temp0 ( -- reg ) EAX ;
: temp1 ( -- reg ) EDX ;
! save stack pointer
temp0 [] stack-reg MOV
! pass vm ptr to primitive
- arg 0 MOV rc-absolute-cell rt-vm jit-rel
+ arg1 0 MOV rc-absolute-cell rt-vm jit-rel
! call the primitive
0 JMP rc-relative rt-primitive jit-rel
] jit-primitive jit-define
{ [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
} cond ;
-M: x86 %save-param-reg [ param@ ] 2dip copy-register ;
+M: x86 %save-param-reg [ param@ ] 2dip %copy ;
-M: x86 %load-param-reg [ swap param@ ] dip copy-register ;
+M: x86 %load-param-reg [ swap param@ ] dip %copy ;
: with-return-regs ( quot -- )
[
[ [ 0 ] dip reg-class-of param-reg ]
[ reg-class-of return-reg ]
[ ]
- tri copy-register ;
-
-
+ tri %copy ;
M:: x86.64 %box ( n rep func -- )
n [
[ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
: float-function-return ( reg -- )
- float-regs return-reg double-rep copy-register ;
+ float-regs return-reg double-rep %copy ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
: rex-length ( -- n ) 1 ;
[
-
! load stack_chain
temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
temp0 temp0 [] MOV
! load XT
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
! load vm ptr
- arg 0 MOV rc-absolute-cell rt-vm jit-rel
+ arg1 0 MOV rc-absolute-cell rt-vm jit-rel
! go
temp1 JMP
] jit-primitive jit-define
IN: bootstrap.x86
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
-: arg ( -- reg ) RDI ;
+: arg1 ( -- reg ) RDI ;
: arg2 ( -- reg ) RSI ;
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
IN: bootstrap.x86
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
-: arg ( -- reg ) RCX ;
+: arg1 ( -- reg ) RCX ;
: arg2 ( -- reg ) RDX ;
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
! MOV where the src is immediate.
+<PRIVATE
+
GENERIC: (MOV-I) ( src dst -- )
M: register (MOV-I) t HEX: b8 short-operand cell, ;
M: operand (MOV-I)
{ BIN: 000 t HEX: c6 }
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
+PRIVATE>
+
GENERIC: MOV ( dst src -- )
M: immediate MOV swap (MOV-I) ;
M: operand MOV HEX: 88 2-operand ;
M: integer CALL HEX: e8 , 4, ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
+<PRIVATE
+
GENERIC# JUMPcc 1 ( addr opcode -- )
M: integer JUMPcc extended-opcode, 4, ;
+PRIVATE>
+
: JO ( dst -- ) HEX: 80 JUMPcc ;
: JNO ( dst -- ) HEX: 81 JUMPcc ;
: JB ( dst -- ) HEX: 82 JUMPcc ;
: CDQ ( -- ) HEX: 99 , ;
: CQO ( -- ) HEX: 48 , CDQ ;
+<PRIVATE
+
: (SHIFT) ( dst src op -- )
over CL eq? [
nip t HEX: d3 3array 1-operand
swapd t HEX: c0 3array immediate-1
] if ; inline
+PRIVATE>
+
: ROL ( dst n -- ) BIN: 000 (SHIFT) ;
: ROR ( dst n -- ) BIN: 001 (SHIFT) ;
: RCL ( dst n -- ) BIN: 010 (SHIFT) ;
--- /dev/null
+Slava Pestov
+Joe Groff
--- /dev/null
+x86 registers and memory operands
! Quotations and words
[
! load from stack
- arg ds-reg [] MOV
+ arg1 ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
! pass vm pointer
arg2 0 MOV rc-absolute-cell rt-vm jit-rel
! call quotation
- arg quot-xt-offset [+] JMP
+ arg1 quot-xt-offset [+] JMP
] \ (call) define-sub-primitive
! Objects
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
-cpu.architecture kernel kernel.private math memory namespaces make
-sequences words system layouts combinators math.order fry locals
-compiler.constants byte-arrays io macros quotations cpu.x86.features
-cpu.x86.features.private compiler compiler.units init vm
+cpu.x86.features cpu.x86.features.private cpu.architecture kernel
+kernel.private math memory namespaces make sequences words system
+layouts combinators math.order fry locals compiler.constants
+byte-arrays io macros quotations compiler compiler.units init vm
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
M: x86 two-operand? t ;
+M: x86 vector-regs float-regs ;
+
HOOK: stack-reg cpu ( -- reg )
HOOK: reserved-area-size cpu ( -- n )
M: double-2-rep copy-register* drop MOVUPD ;
M: vector-rep copy-register* drop MOVDQU ;
-: copy-register ( dst src rep -- )
+M: x86 %copy ( dst src rep -- )
2over eq? [ 3drop ] [ copy-register* ] if ;
-M: x86 %copy ( dst src rep -- ) copy-register ;
-
:: overflow-template ( label dst src1 src2 insn -- )
src1 src2 insn call
label JO ; inline
dst rep rep-size 2 cells + byte-array temp %allot
16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm
dst byte-array-offset [+]
- src rep copy-register ;
+ src rep %copy ;
M:: x86 %unbox-vector ( dst src rep -- )
dst src byte-array-offset [+]
- rep copy-register ;
+ rep %copy ;
MACRO: available-reps ( alist -- )
! Each SSE version adds new representations and supports
M: x86 %broadcast-vector ( dst src rep -- )
{
- { float-4-rep [ [ MOVSS ] [ drop dup 0 SHUFPS ] 2bi ] }
- { double-2-rep [ [ MOVSD ] [ drop dup UNPCKLPD ] 2bi ] }
+ { float-4-rep [ [ float-4-rep %copy ] [ drop dup 0 SHUFPS ] 2bi ] }
+ { double-2-rep [ [ double-2-rep %copy ] [ drop dup UNPCKLPD ] 2bi ] }
} case ;
M: x86 %broadcast-vector-reps
{
- { sse? { float-4-rep } }
- { sse2? { double-2-rep } }
+ ! Can't do this with sse1 since it will want to unbox
+ ! a double-precision float and convert to single precision
+ { sse2? { float-4-rep double-2-rep } }
} available-reps ;
M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
{
float-4-rep
[
- dst src1 MOVSS
+ dst src1 float-4-rep %copy
dst src2 UNPCKLPS
src3 src4 UNPCKLPS
dst src3 MOVLHPS
M: x86 %gather-vector-4-reps
{
- { sse? { float-4-rep } }
+ ! Can't do this with sse1 since it will want to unbox
+ ! double-precision floats and convert to single precision
+ { sse2? { float-4-rep } }
} available-reps ;
M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
{
double-2-rep
[
- dst src1 MOVSD
+ dst src1 double-2-rep %copy
dst src2 UNPCKLPD
]
}
{ ushort-8-rep [ PADDW ] }
{ int-4-rep [ PADDD ] }
{ uint-4-rep [ PADDD ] }
+ { longlong-2-rep [ PADDQ ] }
+ { ulonglong-2-rep [ PADDQ ] }
} case drop ;
M: x86 %add-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %saturated-add-vector ( dst src1 src2 rep -- )
{ ushort-8-rep [ PSUBW ] }
{ int-4-rep [ PSUBD ] }
{ uint-4-rep [ PSUBD ] }
+ { longlong-2-rep [ PSUBQ ] }
+ { ulonglong-2-rep [ PSUBQ ] }
} case drop ;
M: x86 %sub-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %saturated-sub-vector ( dst src1 src2 rep -- )
M: x86 %mul-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { double-2-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
+ { sse2? { double-2-rep short-8-rep ushort-8-rep } }
+ { sse4.1? { int-4-rep uint-4-rep } }
} available-reps ;
M: x86 %saturated-mul-vector-reps
M: x86 %horizontal-add-vector ( dst src rep -- )
{
- { float-4-rep [ [ MOVAPS ] [ HADDPS ] [ HADDPS ] 2tri ] }
- { double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] }
+ { float-4-rep [ [ float-4-rep %copy ] [ HADDPS ] [ HADDPS ] 2tri ] }
+ { double-2-rep [ [ double-2-rep %copy ] [ HADDPD ] 2bi ] }
} case ;
M: x86 %horizontal-add-vector-reps
{
{ float-4-rep [ ANDPS ] }
{ double-2-rep [ ANDPD ] }
- { char-16-rep [ PAND ] }
- { uchar-16-rep [ PAND ] }
- { short-8-rep [ PAND ] }
- { ushort-8-rep [ PAND ] }
- { int-4-rep [ PAND ] }
- { uint-4-rep [ PAND ] }
+ [ drop PAND ]
} case drop ;
M: x86 %and-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %or-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ ORPS ] }
{ double-2-rep [ ORPD ] }
- { char-16-rep [ POR ] }
- { uchar-16-rep [ POR ] }
- { short-8-rep [ POR ] }
- { ushort-8-rep [ POR ] }
- { int-4-rep [ POR ] }
- { uint-4-rep [ POR ] }
+ [ drop POR ]
} case drop ;
M: x86 %or-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %xor-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ XORPS ] }
{ double-2-rep [ XORPD ] }
- { char-16-rep [ PXOR ] }
- { uchar-16-rep [ PXOR ] }
- { short-8-rep [ PXOR ] }
- { ushort-8-rep [ PXOR ] }
- { int-4-rep [ PXOR ] }
- { uint-4-rep [ PXOR ] }
+ [ drop PXOR ]
} case drop ;
M: x86 %xor-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %shl-vector ( dst src1 src2 rep -- )
+ {
+ { short-8-rep [ PSLLW ] }
+ { ushort-8-rep [ PSLLW ] }
+ { int-4-rep [ PSLLD ] }
+ { uint-4-rep [ PSLLD ] }
+ { longlong-2-rep [ PSLLQ ] }
+ { ulonglong-2-rep [ PSLLQ ] }
+ } case drop ;
+
+M: x86 %shl-vector-reps
+ {
+ { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %shr-vector ( dst src1 src2 rep -- )
+ {
+ { short-8-rep [ PSRAW ] }
+ { ushort-8-rep [ PSRLW ] }
+ { int-4-rep [ PSRAD ] }
+ { uint-4-rep [ PSRLD ] }
+ { ulonglong-2-rep [ PSRLQ ] }
+ } case drop ;
+
+M: x86 %shr-vector-reps
+ {
+ { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } }
} available-reps ;
+M: x86 %integer>scalar drop MOVD ;
+
+M: x86 %scalar>integer drop MOVD ;
+
M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ;
[ quot call ] with-save/restore
] if ; inline
-: ?MOV ( dst src -- )
- 2dup = [ 2drop ] [ MOV ] if ; inline
-
M:: x86 %string-nth ( dst src index temp -- )
! We request a small-reg of size 8 since those of size 16 are
! a superset.
! Compute code point
new-dst temp XOR
"end" resolve-label
- dst new-dst ?MOV
+ dst new-dst int-rep %copy
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
ch { index str temp } 8 [| new-ch |
- new-ch ch ?MOV
+ new-ch ch int-rep %copy
temp str index [+] LEA
temp string-offset [+] new-ch 8-bit-version-of MOV
] with-small-register ;
dst { src } size [| new-dst |
new-dst dup size n-bit-version-of dup src [] MOV
quot call
- dst new-dst ?MOV
+ dst new-dst int-rep %copy
] with-small-register ; inline
: %alien-unsigned-getter ( dst src size -- )
M: x86 %alien-cell [] MOV ;
M: x86 %alien-float [] MOVSS ;
M: x86 %alien-double [] MOVSD ;
-M: x86 %alien-vector [ [] ] dip copy-register ;
+M: x86 %alien-vector [ [] ] dip %copy ;
:: %alien-integer-setter ( ptr value size -- )
value { ptr } size [| new-value |
- new-value value ?MOV
+ new-value value int-rep %copy
ptr [] new-value size n-bit-version-of MOV
] with-small-register ; inline
M: x86 %set-alien-cell [ [] ] dip MOV ;
M: x86 %set-alien-float [ [] ] dip MOVSS ;
M: x86 %set-alien-double [ [] ] dip MOVSD ;
-M: x86 %set-alien-vector [ [] ] 2dip copy-register ;
+M: x86 %set-alien-vector [ [] ] 2dip %copy ;
: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
\ UCOMISD (%compare-float-branch) ;
M:: x86 %spill ( src rep n -- )
- n spill@ src rep copy-register ;
+ n spill@ src rep %copy ;
M:: x86 %reload ( dst rep n -- )
- dst n spill@ rep copy-register ;
+ dst n spill@ rep %copy ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes.predicate fry generic io.pathnames kernel
-macros sequences vocabs words words.symbol words.constant
-lexer parser help.topics help.markup namespaces sorting ;
+USING: assocs classes.predicate fry generic help.topics
+io.pathnames kernel lexer macros namespaces parser sequences
+vocabs words words.constant words.symbol ;
IN: definitions.icons
GENERIC: definition-icon ( definition -- path )
ICON: runnable-vocab runnable-vocab
ICON: vocab open-vocab
ICON: vocab-link unopen-vocab
-
-: $definition-icons ( element -- )
- drop
- icons get >alist sort-keys
- [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
- { "" "Definition class" } prefix
- $table ;
\ No newline at end of file
ARTICLE: "grouping" "Groups and clumps"
"Splitting a sequence into disjoint, fixed-length subsequences:"
-{ $subsection group }
+{ $subsections group }
"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
-{ $subsection groups }
-{ $subsection <groups> }
-{ $subsection <sliced-groups> }
+{ $subsections groups <groups> <sliced-groups> }
"Splitting a sequence into overlapping, fixed-length subsequences:"
-{ $subsection clump }
+{ $subsections clump }
"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
-{ $subsection clumps }
-{ $subsection <clumps> }
-{ $subsection <sliced-clumps> }
+{ $subsections clumps <clumps> <sliced-clumps> }
"The difference can be summarized as the following:"
{ $list
{ "With groups, the subsequences form the original sequence when concatenated:"
}
}
}
+$nl
"A combinator built using clumps:"
-{ $subsection monotonic? }
+{ $subsections monotonic? }
"Testing how elements are related:"
-{ $subsection all-eq? }
-{ $subsection all-equal? } ;
+{ $subsections all-eq? all-equal? } ;
ABOUT: "grouping"
collect-elements [ >link ] map ;
: article-children ( topic -- seq )
- { $subsection } article-links ;
+ { $subsection $subsections } article-links ;
: help-path ( topic -- seq )
[ article-parent ] follow rest ;
HELP: $subsection
{ $values { "element" "a markup element of the form " { $snippet "{ topic }" } } }
-{ $description "Prints a large clickable link to the help topic named by the first string element of " { $snippet "element" } "." }
+{ $description "Prints a large clickable link to the help topic named by the first item in " { $snippet "element" } ". The link is printed along with its associated definition icon." }
{ $examples
- { $code "{ $subsection \"sequences\" }" }
+ { $markup-example { $subsection "sequences" } }
+ { $markup-example { $subsection nth } }
+ { $markup-example { $subsection each } }
+} ;
+
+HELP: $subsections
+{ $values { "children" "a " { $link sequence } " of one or more " { $link topic } "s or, in the case of a help article, the article's string name." } }
+{ $description "Prints a large clickable link for each of the listed help topics in " { $snippet "children" } ". The link is printed along with its associated definition icon." }
+{ $examples
+ { $markup-example { $subsections "sequences" nth each } }
+} ;
+
+{ $subsection $subsections $link } related-words
+
+HELP: $vocab-subsection
+{ $values { "element" "a markup element of the form " { $snippet "{ title vocab }" } } }
+{ $description "Prints a large clickable link for " { $snippet "vocab" } ". If " { $snippet "vocab" } " has a main help article, the link will point at that article and the " { $snippet "title" } " input will be ignored. Otherwise, the link text will be taken from " { $snippet "title" } " and point to " { $snippet "vocab" } "'s automatically generated documentation."
+$nl
+"The link will be printed along with its associated definition icon." }
+{ $examples
+ { $markup-example { $vocab-subsection "SQLite" "db.sqlite" } }
+ { $markup-example { $vocab-subsection "Alien" "alien" } }
} ;
HELP: $index
: print-topic ( topic -- )
>link
last-element off
- [ $title ] [ article-content print-content nl ] bi ;
+ [ $title ] [ nl article-content print-content nl ] bi ;
SYMBOL: help-hook
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions generic io kernel assocs
-hashtables namespaces make parser prettyprint sequences strings
-io.styles vectors words math sorting splitting classes slots fry
-sets vocabs help.stylesheet help.topics vocabs.loader quotations
-combinators see present ;
+USING: accessors arrays assocs classes colors.constants
+combinators definitions definitions.icons effects fry generic
+hashtables help.stylesheet help.topics io io.styles kernel make
+math namespaces parser present prettyprint
+prettyprint.stylesheet quotations see sequences sets slots
+sorting splitting strings vectors vocabs vocabs.loader words ;
FROM: prettyprint.sections => with-pprint ;
IN: help.markup
] ($span) ;
: $nl ( children -- )
- nl nl drop ;
+ nl last-block? [ nl ] unless drop ;
! Some blocks
: ($heading) ( children quot -- )
: write-link ( string object -- )
link-style get [ write-object ] with-style ;
-: ($link) ( article -- )
- [ [ article-name ] [ >link ] bi write-link ] ($span) ;
+: link-icon ( topic -- )
+ definition-icon 1array $image ;
-: $link ( element -- )
- first ($link) ;
-
-: ($definition-link) ( word -- )
+: link-text ( topic -- )
[ article-name ] keep write-link ;
-: $definition-link ( element -- )
- first ($definition-link) ;
+: link-effect ( topic -- )
+ dup word? [
+ stack-effect [ effect>string ] [ effect-style ] bi
+ [ write ] with-style
+ ] [ drop ] if ;
+
+: inter-cleave ( x seq between -- )
+ [ [ call( x -- ) ] with ] dip swap interleave ; inline
+
+: (($link)) ( topic words -- )
+ [ dup topic? [ >link ] unless ] dip
+ [ [ bl ] inter-cleave ] ($span) ; inline
+
+: ($link) ( topic -- )
+ { [ link-text ] } (($link)) ;
+
+: $link ( element -- ) first ($link) ;
+
+: ($long-link) ( topic -- )
+ { [ link-text ] [ link-effect ] } (($link)) ;
+
+: $long-link ( element -- ) first ($long-link) ;
+
+: ($pretty-link) ( topic -- )
+ { [ link-icon ] [ link-text ] } (($link)) ;
+
+: $pretty-link ( element -- ) first ($pretty-link) ;
-: ($long-link) ( object -- )
- [ article-title ] [ >link ] bi write-link ;
+: ($long-pretty-link) ( topic -- )
+ { [ link-icon ] [ link-text ] [ link-effect ] } (($link)) ;
-: $long-link ( object -- )
- first ($long-link) ;
+: $long-pretty-link ( element -- ) first ($long-pretty-link) ;
+
+: <$pretty-link> ( definition -- element )
+ 1array \ $pretty-link prefix ;
: ($subsection) ( element quot -- )
[
- subsection-style get [
- bullet get write bl
- call
- ] with-style
+ subsection-style get [ call ] with-style
] ($block) ; inline
+: $subsection* ( topic -- )
+ [
+ [ ($long-pretty-link) ] with-scope
+ ] ($subsection) ;
+
+: $subsections ( children -- )
+ [ $subsection* ] each nl ;
+
: $subsection ( element -- )
- [ first ($long-link) ] ($subsection) ;
+ first $subsection* ;
: ($vocab-link) ( text vocab -- )
>vocab-link write-link ;
: $vocab-subsection ( element -- )
[
- first2 dup vocab-help dup [
- 2nip ($long-link)
- ] [
- drop ($vocab-link)
- ] if
+ first2 dup vocab-help
+ [ 2nip ($long-pretty-link) ]
+ [ [ >vocab-link link-icon bl ] [ ($vocab-link) ] bi ]
+ if*
] ($subsection) ;
: $vocab-link ( element -- )
: <$snippet> ( str -- element )
1array \ $snippet prefix ;
+
+: $definition-icons ( element -- )
+ drop
+ icons get >alist sort-keys
+ [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
+ { "" "Definition class" } prefix
+ $table ;
\ No newline at end of file
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple classes.union combinators
-definitions effects fry generic help help.markup help.stylesheet
-help.topics io io.files io.pathnames io.styles kernel macros
-make namespaces prettyprint sequences sets sorting summary
-vocabs vocabs.files vocabs.hierarchy vocabs.loader
-vocabs.metadata words words.symbol definitions.icons ;
+effects fry generic help help.markup help.stylesheet
+help.topics io io.pathnames io.styles kernel macros make
+namespaces sequences sorting summary vocabs vocabs.files
+vocabs.hierarchy vocabs.loader vocabs.metadata words
+words.symbol ;
FROM: vocabs.hierarchy => child-vocabs ;
IN: help.vocabs
: about ( vocab -- )
[ require ] [ vocab help ] bi ;
-: $pretty-link ( element -- )
- [ first definition-icon 1array $image " " print-element ]
- [ $definition-link ]
- bi ;
-
-: <$pretty-link> ( definition -- element )
- 1array \ $pretty-link prefix ;
-
: vocab-row ( vocab -- row )
[ <$pretty-link> ] [ vocab-summary ] bi 2array ;
: simple-link ( xml url -- xml' )
url-encode swap [XML <a href=<->><-></a> XML] ;
+
+: simple-image ( url -- xml )
+ url-encode [XML <img src=<-> /> XML] ;
\ No newline at end of file
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test
-[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
\ No newline at end of file
+[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
+
+[ "<img src=\"/icons/class-word.tiff\"/>" ] [
+ [
+ "text"
+ { { image "vocab:definitions/icons/class-word.tiff" } }
+ format
+ ] make-html-string
+] unit-test
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel assocs io io.styles math math.order math.parser
-sequences strings make words combinators macros xml.syntax html fry
-destructors ;
+USING: accessors assocs combinators destructors fry html io
+io.backend io.pathnames io.styles kernel macros make math
+math.order math.parser namespaces sequences strings words
+splitting xml xml.syntax ;
IN: html.streams
GENERIC: url-of ( object -- url )
: emit-html ( quot stream -- )
dip data>> push ; inline
+: image-path ( path -- images-path )
+ "vocab:definitions/icons/" ?head [ "/icons/" prepend ] when ;
+
+: img-tag ( xml style -- xml )
+ image swap at [ nip image-path simple-image ] when* ;
+
: format-html-span ( string style stream -- )
- [ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ]
- emit-html ;
+ [
+ {
+ [ span-tag ]
+ [ href-link-tag ]
+ [ object-link-tag ]
+ [ img-tag ]
+ } cleave
+ ] emit-html ;
TUPLE: html-span-stream < html-sub-stream ;
H{ } describe
H{ } describe
-[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
+[ "fixnum\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
[ ] [ H{ } clone inspect ] unit-test
IN: math.functions
ARTICLE: "integer-functions" "Integer functions"
-{ $subsection align }
-{ $subsection gcd }
-{ $subsection log2 }
-{ $subsection next-power-of-2 }
+{ $subsections
+ align
+ gcd
+ log2
+ next-power-of-2
+}
"Modular exponentiation:"
-{ $subsection ^mod }
-{ $subsection mod-inv }
+{ $subsections ^mod mod-inv }
"Tests:"
-{ $subsection power-of-2? }
-{ $subsection even? }
-{ $subsection odd? }
-{ $subsection divisor? } ;
+{ $subsections
+ power-of-2?
+ even?
+ odd?
+ divisor?
+} ;
ARTICLE: "arithmetic-functions" "Arithmetic functions"
"Computing additive and multiplicative inverses:"
-{ $subsection neg }
-{ $subsection recip }
+{ $subsections neg recip }
"Complex conjugation:"
-{ $subsection conjugate }
+{ $subsections conjugate }
"Tests:"
-{ $subsection zero? }
-{ $subsection between? }
+{ $subsections zero? between? }
"Control flow:"
-{ $subsection if-zero }
-{ $subsection when-zero }
-{ $subsection unless-zero }
+{ $subsections
+ if-zero
+ when-zero
+ unless-zero
+}
"Sign:"
-{ $subsection sgn }
+{ $subsections sgn }
"Rounding:"
-{ $subsection ceiling }
-{ $subsection floor }
-{ $subsection truncate }
-{ $subsection round }
+{ $subsections
+ ceiling
+ floor
+ truncate
+ round
+}
"Inexact comparison:"
-{ $subsection ~ }
+{ $subsections ~ }
"Numbers implement the " { $link "math.order" } ", therefore operations such as " { $link min } " and " { $link max } " can be used with numbers." ;
ARTICLE: "power-functions" "Powers and logarithms"
"Squares:"
-{ $subsection sq }
-{ $subsection sqrt }
+{ $subsections sq sqrt }
"Exponential and natural logarithm:"
-{ $subsection exp }
-{ $subsection cis }
-{ $subsection log }
+{ $subsections exp cis log }
"Other logarithms:"
-{ $subsection log1+ }
-{ $subsection log10 }
+{ $subsection log1+ log10 }
"Raising a number to a power:"
-{ $subsection ^ }
-{ $subsection 10^ }
+{ $subsections ^ 10^ }
"Converting between rectangular and polar form:"
-{ $subsection abs }
-{ $subsection absq }
-{ $subsection arg }
-{ $subsection >polar }
-{ $subsection polar> } ;
+{ $subsections
+ abs
+ absq
+ arg
+ >polar
+ polar>
+} ;
ARTICLE: "trig-hyp-functions" "Trigonometric and hyperbolic functions"
"Trigonometric functions:"
-{ $subsection cos }
-{ $subsection sin }
-{ $subsection tan }
+{ $subsections cos sin tan }
"Reciprocals:"
-{ $subsection sec }
-{ $subsection cosec }
-{ $subsection cot }
+{ $subsections sec cosec cot }
"Inverses:"
-{ $subsection acos }
-{ $subsection asin }
-{ $subsection atan }
+{ $subsections acos asin atan }
"Inverse reciprocals:"
-{ $subsection asec }
-{ $subsection acosec }
-{ $subsection acot }
+{ $subsections asec acosec acot }
"Hyperbolic functions:"
-{ $subsection cosh }
-{ $subsection sinh }
-{ $subsection tanh }
+{ $subsections cosh sinh tanh }
"Reciprocals:"
-{ $subsection sech }
-{ $subsection cosech }
-{ $subsection coth }
+{ $subsections sech cosech coth }
"Inverses:"
-{ $subsection acosh }
-{ $subsection asinh }
-{ $subsection atanh }
+{ $subsections acosh asinh atanh }
"Inverse reciprocals:"
-{ $subsection asech }
-{ $subsection acosech }
-{ $subsection acoth } ;
+{ $subsections asech acosech acoth } ;
ARTICLE: "math-functions" "Mathematical functions"
-{ $subsection "integer-functions" }
-{ $subsection "arithmetic-functions" }
-{ $subsection "power-functions" }
-{ $subsection "trig-hyp-functions" } ;
+{ $subsections
+ "integer-functions"
+ "arithmetic-functions"
+ "power-functions"
+ "trig-hyp-functions"
+} ;
ABOUT: "math-functions"
} append
] when ;
-:: simd-vector-words ( class ctor rep vv->v v->v v->n -- )
+:: simd-vector-words ( class ctor rep vv->v vn->v v->v v->n -- )
rep rep-component-type c-type-boxed-class :> elt-class
class
elt-class
{
{ { +vector+ +vector+ -> +vector+ } vv->v }
+ { { +vector+ +scalar+ -> +vector+ } vn->v }
{ { +vector+ -> +vector+ } v->v }
{ { +vector+ -> +scalar+ } v->n }
{ { +vector+ -> +nonnegative+ } v->n }
A-rep [ A name>> "-rep" append "cpu.architecture" lookup ]
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op
A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
: A-vv->v-op ( v1 v2 quot -- v3 )
[ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
+: A-vn->v-op ( v1 v2 quot -- v3 )
+ [ [ underlying>> ] dip A-rep ] dip call \ A boa ; inline
+
: A-v->v-op ( v1 quot -- v2 )
[ underlying>> A-rep ] dip call \ A boa ; inline
: A-v->n-op ( v quot -- n )
[ underlying>> A-rep ] dip call ; inline
-\ A \ A-with \ A-rep \ A-vv->v-op \ A-v->v-op \ A-v->n-op simd-vector-words
+\ A \ A-with \ A-rep \ A-vv->v-op \ A-vn->v-op \ A-v->v-op \ A-v->n-op simd-vector-words
\ A \ A-rep define-simd-128-type
PRIVATE>
A-rep [ A/2 name>> "-rep" append "cpu.architecture" lookup ]
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op
A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
[ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
\ A boa ; inline
+: A-vn->v-op ( v1 v2 quot -- v3 )
+ [ [ [ underlying1>> ] dip A-rep ] dip call ]
+ [ [ [ underlying2>> ] dip A-rep ] dip call ] 3bi
+ \ A boa ; inline
+
: A-v->v-op ( v1 combine-quot -- v2 )
[ [ underlying1>> A-rep ] dip call ]
[ [ underlying2>> A-rep ] dip call ] 2bi
: A-v->n-op ( v1 combine-quot -- v2 )
[ [ underlying1>> ] [ underlying2>> ] bi A-rep (simd-v+) A-rep ] dip call ; inline
-\ A \ A-with \ A-rep \ A-vv->v-op \ A-v->v-op \ A-v->n-op simd-vector-words
+\ A \ A-with \ A-rep \ A-vv->v-op \ A-vn->v-op \ A-v->v-op \ A-v->n-op simd-vector-words
\ A \ A-rep define-simd-256-type
;FUNCTOR
SIMD-OP: vbitand
SIMD-OP: vbitor
SIMD-OP: vbitxor
+SIMD-OP: vlshift
+SIMD-OP: vrshift
: (simd-broadcast) ( x rep -- v ) bad-simd-call ;
: (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
{ \ (simd-vbitand) [ %and-vector-reps ] }
{ \ (simd-vbitor) [ %or-vector-reps ] }
{ \ (simd-vbitxor) [ %xor-vector-reps ] }
+ { \ (simd-vlshift) [ %shl-vector-reps ] }
+ { \ (simd-vrshift) [ %shr-vector-reps ] }
{ \ (simd-broadcast) [ %broadcast-vector-reps ] }
{ \ (simd-gather-2) [ %gather-vector-2-reps ] }
{ \ (simd-gather-4) [ %gather-vector-4-reps ] }
"uint-4"
"int-8"
"uint-8"
+ "longlong-2"
+ "ulonglong-2"
+ "longlong-4"
+ "ulonglong-4"
"float-4"
"float-8"
"double-2"
{ $code
"""USING: compiler.tree.debugger kernel.private
math.vectors math.vectors.simd ;
-SIMD: float-4
+SIMD: float
IN: simd-demo
: interpolate ( v a b -- w )
{ $code
"""USING: compiler.tree.debugger hints
math.vectors math.vectors.simd ;
-SIMD: float-4
+SIMD: float
IN: simd-demo
: interpolate ( v a b -- w )
"In the " { $snippet "interpolate" } " word, there is still a call to the " { $link <tuple-boa> } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:"
{ $code
"""USING: compiler.tree.debugger math.vectors math.vectors.simd ;
-SIMD: float-4
+SIMD: float
IN: simd-demo
STRUCT: actor
{ $subsection "math.vectors.simd.intrinsics" } ;
HELP: SIMD:
-{ $syntax "SIMD: type-length" }
-{ $values { "type" "a scalar C type" } { "length" "a vector dimension" } }
-{ $description "Brings a SIMD array for holding " { $snippet "length" } " values of " { $snippet "type" } " into the vocabulary search path. The possible type/length combinations are listed in " { $link "math.vectors.simd.types" } " and the generated words are documented in " { $link "math.vectors.simd.words" } "." } ;
+{ $syntax "SIMD: type" }
+{ $values { "type" "a scalar C type" } }
+{ $description "Defines 128-bit and 256-bit SIMD arrays for holding elements of " { $snippet "type" } " into the vocabulary search path. The possible type/length combinations are listed in " { $link "math.vectors.simd.types" } " and the generated words are documented in " { $link "math.vectors.simd.words" } "." } ;
ABOUT: "math.vectors.simd"
tools.test vocabs assocs compiler.cfg.debugger words
locals math.vectors.specialization combinators cpu.architecture
math.vectors.simd.intrinsics namespaces byte-arrays alien
-specialized-arrays classes.struct ;
+specialized-arrays classes.struct eval ;
FROM: alien.c-types => c-type-boxed-class ;
SPECIALIZED-ARRAY: float
-SIMD: char-16
-SIMD: uchar-16
-SIMD: char-32
-SIMD: uchar-32
-SIMD: short-8
-SIMD: ushort-8
-SIMD: short-16
-SIMD: ushort-16
-SIMD: int-4
-SIMD: uint-4
-SIMD: int-8
-SIMD: uint-8
-SIMD: float-4
-SIMD: float-8
-SIMD: double-2
-SIMD: double-4
+SIMD: char
+SIMD: uchar
+SIMD: short
+SIMD: ushort
+SIMD: int
+SIMD: uint
+SIMD: longlong
+SIMD: ulonglong
+SIMD: float
+SIMD: double
IN: math.vectors.simd.tests
-[ float-4{ 0 0 0 0 } ] [ float-4 new ] unit-test
+! Make sure the functor doesn't generate bogus vocabularies
+2 [ [ "USE: math.vectors.simd SIMD: rubinius" eval( -- ) ] must-fail ] times
-[ float-4{ 0 0 0 0 } ] [ [ float-4 new ] compile-call ] unit-test
+[ f ] [ "math.vectors.simd.instances.rubinius" vocab ] unit-test
+! Test type propagation
[ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
[ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
+[ V{ float-4 } ] [ [ { float-4 } declare normalize ] final-classes ] unit-test
+
+[ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test
+
! Test puns; only on x86
cpu x86? [
[ double-2{ 4 1024 } ] [
uint-4
int-8
uint-8
+ longlong-2
+ ulonglong-2
+ longlong-4
+ ulonglong-4
float-4
float-8
double-2
: remove-float-words ( alist -- alist' )
[ drop { vsqrt n/v v/n v/ normalize } member? not ] assoc-filter ;
+: remove-integer-words ( alist -- alist' )
+ [ drop { vlshift vrshift } member? not ] assoc-filter ;
+
: ops-to-check ( elt-class -- alist )
[ vector-words >alist ] dip
- float = [ remove-float-words ] unless ;
+ float = [ remove-integer-words ] [ remove-float-words ] if ;
: check-vector-ops ( class elt-class compare-quot -- )
[
simd-classes [
{
{ [ dup name>> "float" head? ] [ float [ approx= ] ] }
- { [ dup name>> "double" tail? ] [ float [ = ] ] }
+ { [ dup name>> "double" head? ] [ float [ = ] ] }
[ fixnum [ = ] ]
} cond 3array
] map ;
USING: alien.c-types combinators fry kernel lexer math math.parser
math.vectors.simd.functor sequences splitting vocabs.generated
vocabs.loader vocabs.parser words ;
+QUALIFIED-WITH: alien.c-types c
IN: math.vectors.simd
-ERROR: bad-vector-size bits ;
+ERROR: bad-base-type type ;
<PRIVATE
-: simd-vocab ( type -- vocab )
+: simd-vocab ( base-type -- vocab )
"math.vectors.simd.instances." prepend ;
-: parse-simd-name ( string -- c-type quot )
- "-" split1
- [ "alien.c-types" lookup dup heap-size ] [ string>number ] bi*
- * 8 * {
- { 128 [ [ define-simd-128 ] ] }
- { 256 [ [ define-simd-256 ] ] }
- [ bad-vector-size ]
+: parse-base-type ( string -- c-type )
+ {
+ { "char" [ c:char ] }
+ { "uchar" [ c:uchar ] }
+ { "short" [ c:short ] }
+ { "ushort" [ c:ushort ] }
+ { "int" [ c:int ] }
+ { "uint" [ c:uint ] }
+ { "longlong" [ c:longlong ] }
+ { "ulonglong" [ c:ulonglong ] }
+ { "float" [ c:float ] }
+ { "double" [ c:double ] }
+ [ bad-base-type ]
} case ;
PRIVATE>
: define-simd-vocab ( type -- vocab )
- [ simd-vocab ]
- [ '[ _ parse-simd-name call( type -- ) ] ] bi
- generate-vocab ;
+ [ simd-vocab ] keep '[
+ _ parse-base-type
+ [ define-simd-128 ]
+ [ define-simd-256 ] bi
+ ] generate-vocab ;
SYNTAX: SIMD:
scan define-simd-vocab use-vocab ;
[ { float-array float } declare v*n norm ] final-classes
] unit-test
-[ V{ number } ] [
+[ V{ complex } ] [
[ { complex-float-array complex-float-array } declare v. ] final-classes
] unit-test
-[ V{ real } ] [
+[ V{ float } ] [
+ [ { float-array float } declare v*n norm ] final-classes
+] unit-test
+
+[ V{ float } ] [
[ { complex-float-array complex } declare v*n norm ] final-classes
] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types words kernel make sequences effects
-kernel.private accessors combinators math math.intervals
-math.vectors namespaces assocs fry splitting classes.algebra
-generalizations locals compiler.tree.propagation.info ;
+USING: words kernel make sequences effects sets kernel.private
+accessors combinators math math.intervals math.vectors
+namespaces assocs fry splitting classes.algebra generalizations
+locals compiler.tree.propagation.info ;
IN: math.vectors.specialization
SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ;
{
{ +vector+ [ drop <class-info> ] }
{ +scalar+ [ nip <class-info> ] }
- { +nonnegative+ [ nip real class-and [0,inf] <class/interval-info> ] }
+ {
+ +nonnegative+
+ [
+ nip
+ dup complex class<= [ drop float ] when
+ [0,inf] <class/interval-info>
+ ]
+ }
} case
] with with map ;
{ vbitand { +vector+ +vector+ -> +vector+ } }
{ vbitor { +vector+ +vector+ -> +vector+ } }
{ vbitxor { +vector+ +vector+ -> +vector+ } }
+ { vlshift { +vector+ +scalar+ -> +vector+ } }
+ { vrshift { +vector+ +scalar+ -> +vector+ } }
}
PREDICATE: vector-word < word vector-words key? ;
:: input-signature ( word array-type elt-type -- signature )
array-type elt-type word word-schema inputs signature-for-schema ;
+: vector-words-for-type ( elt-type -- alist )
+ {
+ ! Can't do shifts on floats
+ { [ dup float class<= ] [ vector-words keys { vlshift vrshift } diff ] }
+ ! Can't divide integers
+ { [ dup integer class<= ] [ vector-words keys { vsqrt n/v v/n v/ normalize } diff ] }
+ ! Can't compute square root of complex numbers (vsqrt uses fsqrt not sqrt)
+ { [ dup complex class<= ] [ vector-words keys { vsqrt } diff ] }
+ [ { } ]
+ } cond nip ;
+
:: specialize-vector-words ( array-type elt-type simd -- )
- elt-type number class<= [
- vector-words keys [
- [ array-type elt-type simd specialize-vector-word ]
- [ array-type elt-type input-signature ]
- [ ]
- tri add-specialization
- ] each
- ] when ;
+ elt-type vector-words-for-type [
+ [ array-type elt-type simd specialize-vector-word ]
+ [ array-type elt-type input-signature ]
+ [ ]
+ tri add-specialization
+ ] each ;
: find-specialization ( classes word -- word/f )
specializations
{ $subsection vbitand }
{ $subsection vbitor }
{ $subsection vbitxor }
+{ $subsection vlshift }
+{ $subsection vrshift }
"Inner product and norm:"
{ $subsection v. }
{ $subsection norm }
HELP: v.
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "x" "a real number" } }
-{ $description "Computes the real-valued dot product." }
-{ $notes
- "This word can also take complex number sequences as input, however mathematically it will compute the wrong result. The complex-valued dot product is defined differently:"
- { $code "0 [ conjugate * + ] 2reduce" }
-} ;
+{ $description "Computes the dot product of two vectors." } ;
HELP: vs+
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
{ $description "Takes the bitwise exclusive or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
{ $notes "Unlike " { $link bitxor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+HELP: vlshift
+{ $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } }
+{ $description "Shifts each element of " { $snippet "u" } " to the left by " { $snippet "n" } " bits." } ;
+
+HELP: vrshift
+{ $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } }
+{ $description "Shifts each element of " { $snippet "u" } " to the right by " { $snippet "n" } " bits." } ;
+
HELP: norm-sq
{ $values { "v" "a sequence of numbers" } { "x" "a non-negative real number" } }
{ $description "Computes the squared length of a mathematical vector." } ;
IN: math.vectors.tests
-USING: math.vectors tools.test ;
+USING: math.vectors tools.test kernel ;
[ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test
[ { 1 2 3 } ] [ { 2 4 6 } 1/2 v*n ] unit-test
[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
-[ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test
\ No newline at end of file
+[ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test
+
+[ 1 ] [ { C{ 0 1 } } dup v. ] unit-test
\ No newline at end of file
: vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ;
: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ;
+: vlshift ( u n -- w ) '[ _ shift ] map ;
+: vrshift ( u n -- w ) neg '[ _ shift ] map ;
+
: vfloor ( u -- v ) [ floor ] map ;
: vceiling ( u -- v ) [ ceiling ] map ;
: vtruncate ( u -- v ) [ truncate ] map ;
: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ;
: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ;
-: v. ( u v -- x ) [ * ] [ + ] 2map-reduce ;
+: v. ( u v -- x ) [ conjugate * ] [ + ] 2map-reduce ;
: norm-sq ( v -- x ) [ absq ] [ + ] map-reduce ;
: norm ( v -- x ) norm-sq sqrt ;
: normalize ( u -- v ) dup norm v/n ;
! Copyright (C) 2009 Keith Lazuka.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs colors.constants combinators
+USING: assocs colors colors.constants combinators
combinators.short-circuit hashtables io.styles kernel literals
namespaces sequences words words.symbol ;
IN: prettyprint.stylesheet
dim-color colored-presentation-style ;
: effect-style ( effect -- style )
- COLOR: DarkGreen colored-presentation-style ;
+ 0 0.2 0 1 <rgba> colored-presentation-style
+ { { font-style plain } } assoc-union ;
ARTICLE: "regexp.combinators" "Regular expression combinators"
"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This complements the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary."
-{ $subsection "regexp.combinators.intro" }
+{ $subsections "regexp.combinators.intro" }
"Basic combinators:"
-{ $subsection <literal> }
-{ $subsection <nothing> }
+{ $subsections <literal> <nothing> }
"Higher-order combinators for building new regular expressions from existing ones:"
-{ $subsection <or> }
-{ $subsection <and> }
-{ $subsection <not> }
-{ $subsection <sequence> }
-{ $subsection <zero-or-more> }
+{ $subsections
+ <or>
+ <and>
+ <not>
+ <sequence>
+ <zero-or-more>
+}
"Derived combinators implemented in terms of the above:"
-{ $subsection <one-or-more> }
+{ $subsections <one-or-more> }
"Setting options:"
-{ $subsection <option> } ;
+{ $subsections <option> } ;
HELP: <literal>
{ $values { "string" string } { "regexp" regexp } }
ARTICLE: "regexp" "Regular expressions"
"The " { $vocab-link "regexp" } " vocabulary provides word for creating and using regular expressions."
-{ $subsection { "regexp" "intro" } }
+{ $subsections { "regexp" "intro" } }
"The class of regular expressions:"
-{ $subsection regexp }
+{ $subsections regexp }
"Basic usage:"
-{ $subsection { "regexp" "syntax" } }
-{ $subsection { "regexp" "options" } }
-{ $subsection { "regexp" "construction" } }
-{ $subsection { "regexp" "operations" } }
+{ $subsections
+ { "regexp" "syntax" }
+ { "regexp" "options" }
+ { "regexp" "construction" }
+ { "regexp" "operations" }
+}
"Advanced topics:"
{ $vocab-subsection "Regular expression combinators" "regexp.combinators" }
-{ $subsection { "regexp" "theory" } }
-{ $subsection { "regexp" "deploy" } } ;
+{ $subsections
+ { "regexp" "theory" }
+ { "regexp" "deploy" }
+} ;
ARTICLE: { "regexp" "intro" } "A quick introduction to regular expressions"
"Regular expressions are a terse way to do certain simple string processing tasks. For example, to replace all instances of " { $snippet "foo" } " in one string with " { $snippet "bar" } ", the following can be used:"
ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
"Most of the time, regular expressions are literals and the parsing word should be used, to construct them at parse time. This ensures that they are only compiled once, and gives parse time syntax checking."
-{ $subsection POSTPONE: R/ }
+{ $subsections POSTPONE: R/ }
"Sometimes, regular expressions need to be constructed at run time instead; for example, in a text editor, the user might input a regular expression to search for in a document."
-{ $subsection <regexp> }
-{ $subsection <optioned-regexp> }
+{ $subsections <regexp> <optioned-regexp> }
"Another approach is to use " { $vocab-link "regexp.combinators" } "." ;
ARTICLE: { "regexp" "syntax" } "Regular expression syntax"
ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions"
"Testing if a string matches a regular expression:"
-{ $subsection matches? }
+{ $subsections matches? }
"Finding a match inside a string:"
-{ $subsection re-contains? }
-{ $subsection first-match }
+{ $subsections re-contains? first-match }
"Finding all matches inside a string:"
-{ $subsection count-matches }
-{ $subsection all-matching-slices }
-{ $subsection all-matching-subseqs }
+{ $subsections
+ count-matches
+ all-matching-slices
+ all-matching-subseqs
+}
"Splitting a string into tokens delimited by a regular expression:"
-{ $subsection re-split }
+{ $subsections re-split }
"Replacing occurrences of a regular expression with a string:"
-{ $subsection re-replace } ;
+{ $subsections re-replace } ;
ARTICLE: { "regexp" "deploy" } "Regular expressions and the deploy tool"
"The " { $link "tools.deploy" } " tool has the option to strip out the optimizing compiler from the resulting image. Since regular expressions compile to Factor code, this creates a minor performance-related caveat."
GENERIC: summary ( object -- string )
: object-summary ( object -- string )
- class name>> " instance" append ;
+ class name>> ;
M: object summary object-summary ;
synopsis-alist sort-keys definitions. ;
: usage. ( word -- )
- smart-usage sorted-definitions. ;
+ smart-usage
+ [ "No usages." print ] [ sorted-definitions. ] if-empty ;
: vocab-xref ( vocab quot -- vocabs )
[ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
"word-style"
} %
] when
+
+ deploy-c-types? get [
+ { "c-type" "struct-slots" "struct-size" "struct-align" } %
+ ] unless
] { } make ;
: strip-words ( props -- )
{ } { "math.partial-dispatch" } strip-vocab-globals %
+ { } { "math.vectors.simd" } strip-vocab-globals %
+
{ } { "peg" } strip-vocab-globals %
] when
[ ] [ [ [ ] compile-call ] profile ] unit-test
[ [ gensym execute ] profile ] [ T{ undefined } = ] must-fail-with
+
+: crash-bug-1 ( -- x ) "hi" "bye" <word> ;
+: crash-bug-2 ( -- ) 100000 [ crash-bug-1 drop ] times ;
+
+[ ] [ [ crash-bug-2 ] profile ] unit-test
}
} ;
-HELP: command-string
-{ $values { "gesture" "a gesture" } { "command" "a command" } { "string" string } }
-{ $description "Outputs a string containing the command name followed by the gesture." }
-{ $examples
- { $unchecked-example
- "USING: io ui.commands ui.gestures ;"
- "IN: scratchpad"
- ": com-my-command ;"
- "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write"
- "My Command (C+s)"
- }
-} ;
-
ARTICLE: "ui-commands" "Commands"
"Commands are an abstraction layered on top of gestures. Their main advantage is that they are identified by words and can be organized into " { $emphasis "command maps" } ". This allows easy construction of buttons and tool bars for invoking commands."
{ $subsection define-command }
M: word command-word ;
-M: f invoke-command ( target command -- ) 2drop ;
-
-: command-string ( gesture command -- string )
- [
- command-name %
- gesture>string [ " (" % % ")" % ] when*
- ] "" make ;
\ No newline at end of file
+M: f invoke-command ( target command -- ) 2drop ;
\ No newline at end of file
'[ _ _ invoke-command ] ;
: gesture>tooltip ( gesture -- str/f )
- dup [ gesture>string "Shortcut: " prepend ] when ;
+ gesture>string dup [ "Shortcut: " prepend ] when ;
: <command-button> ( target gesture command -- button )
swapd [ command-name swap ] keep command-button-quot
: slot-editor-window ( close-hook update-hook assoc key key-string -- )
[ <value-ref> <slot-editor> ] [ "Slot editor: " prepend ] bi*
- open-window ;
+ open-status-window ;
: com-edit-slot ( inspector -- )
[ close-window ] swap
USING: tools.test ui.tools.listener.completion ;
IN: ui.tools.listener.completion.tests
-[ t ] [ { "USING:" "A" "B" "C" } complete-USING:? ] unit-test
+[ f ] [ { "USE:" "A" "B" "C" } complete-vocab? ] unit-test
-[ f ] [ { "USING:" "A" "B" "C" ";" } complete-USING:? ] unit-test
+[ t ] [ { "USE:" "A" } complete-vocab? ] unit-test
-[ t ] [ { "X" ";" "USING:" "A" "B" "C" } complete-USING:? ] unit-test
\ No newline at end of file
+[ t ] [ { "UNUSE:" "A" } complete-vocab? ] unit-test
+
+[ t ] [ { "QUALIFIED:" "A" } complete-vocab? ] unit-test
+
+[ t ] [ { "QUALIFIED-WITH:" "A" } complete-vocab? ] unit-test
+
+[ t ] [ { "USING:" "A" "B" "C" } complete-vocab-list? ] unit-test
+
+[ f ] [ { "USING:" "A" "B" "C" ";" } complete-vocab-list? ] unit-test
+
+[ t ] [ { "X" ";" "USING:" "A" "B" "C" } complete-vocab-list? ] unit-test
\ No newline at end of file
M: vocab-completion row-color
drop vocab? COLOR: black COLOR: dark-gray ? ;
-: complete-IN:/USE:? ( tokens -- ? )
- 1 short head* 2 short tail* { "IN:" "USE:" } intersects? ;
+: complete-vocab? ( tokens -- ? )
+ 1 short head* 2 short tail*
+ { "IN:" "USE:" "UNUSE:" "QUALIFIED:" "QUALIFIED-WITH:" } intersects? ;
: chop-; ( seq -- seq' )
{ ";" } split1-last [ ] [ ] ?if ;
-: complete-USING:? ( tokens -- ? )
+: complete-vocab-list? ( tokens -- ? )
chop-; 1 short head* { "USING:" } intersects? ;
: complete-CHAR:? ( tokens -- ? )
: completion-mode ( interactor -- symbol )
[ manifest>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split
{
- { [ dup { [ complete-IN:/USE:? ] [ complete-USING:? ] } 1|| ] [ 2drop vocab-completion ] }
+ { [ dup { [ complete-vocab? ] [ complete-vocab-list? ] } 1|| ] [ 2drop vocab-completion ] }
{ [ dup complete-CHAR:? ] [ 2drop char-completion ] }
[ drop <word-completion> ]
} cond ;
{ $code "USE: threads" "[ \"ui.tools\" run ] in-thread" } ;
ARTICLE: "ui-shortcuts" "UI tool keyboard shortcuts"
-"Every UI tool has its own set of keyboard shortcuts; press " { $snippet "F1" } " inside a tool to see help. Some common shortcuts are also supported by all tools:"
+"Every UI tool has its own set of keyboard shortcuts. Mouse-over a toolbar button to see its shortcut, if any, in the status bar, or press " { $snippet "F1" } " to see a list of all shortcuts supported by the tool."
+$nl
+"Some common shortcuts are supported by all tools:"
{ $command-map tool "tool-switching" }
{ $command-map tool "common" } ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.units fry kernel vocabs vocabs.parser ;
+USING: compiler.units continuations fry kernel vocabs vocabs.parser ;
IN: vocabs.generated
: generate-vocab ( vocab-name quot -- vocab )
[ dup vocab [ ] ] dip '[
[
[
- _ with-current-vocab
+ [ _ with-current-vocab ] [ ] [ forget-vocab ] cleanup
] with-compilation-unit
] keep
] ?if ; inline
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: alien.c-types alien.libraries alien.syntax classes.struct windows.types ;
+IN: windows.dwmapi
+
+STRUCT: MARGINS
+ { cxLeftWidth int }
+ { cxRightWidth int }
+ { cyTopHeight int }
+ { cyBottomHeight int } ;
+
+STRUCT: DWM_BLURBEHIND
+ { dwFlags DWORD }
+ { fEnable BOOL }
+ { hRgnBlur HANDLE }
+ { fTransitionOnMaximized BOOL } ;
+
+: <MARGINS> ( l r t b -- MARGINS )
+ MARGINS <struct-boa> ; inline
+
+: full-window-margins ( -- MARGINS )
+ -1 -1 -1 -1 <MARGINS> ; inline
+
+<< "dwmapi" "dwmapi.dll" "stdcall" add-library >>
+
+LIBRARY: dwmapi
+
+FUNCTION: HRESULT DwmExtendFrameIntoClientArea ( HWND hWnd, MARGINS* pMarInset ) ;
+FUNCTION: HRESULT DwmEnableBlurBehindWindow ( HWND hWnd, DWM_BLURBEHIND* pBlurBehind ) ;
--- /dev/null
+Windows Vista Desktop Window Manager API functions
--- /dev/null
+windows
+unportable
"The cleave combinators apply multiple quotations to a single value."
$nl
"Two quotations:"
-{ $subsection bi }
-{ $subsection 2bi }
-{ $subsection 3bi }
+{ $subsections bi 2bi 3bi }
"Three quotations:"
-{ $subsection tri }
-{ $subsection 2tri }
-{ $subsection 3tri }
+{ $subsections tri 2tri 3tri }
"An array of quotations:"
-{ $subsection cleave }
-{ $subsection 2cleave }
-{ $subsection 3cleave }
+{ $subsection cleave 2cleave 3cleave }
+$nl
"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
{ $code
"! First alternative; uses keep"
"[ 2 * ] tri"
}
"The latter is more aesthetically pleasing than the former."
+$nl
{ $subsection "cleave-shuffle-equivalence" } ;
ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
"The spread combinators apply multiple quotations to multiple values. In this case, " { $snippet "*" } " suffix signify spreading."
$nl
"Two quotations:"
-{ $subsection bi* }
-{ $subsection 2bi* }
+{ $subsections bi* 2bi* }
"Three quotations:"
-{ $subsection tri* }
-{ $subsection 2tri* }
+{ $subsections tri* 2tri* }
"An array of quotations:"
-{ $subsection spread }
+{ $subsections spread }
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
{ $code
"! First alternative; uses dip"
"[ 1 + ] [ 1 - ] [ 2 * ] tri*"
}
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+$nl
{ $subsection "spread-shuffle-equivalence" } ;
ARTICLE: "apply-combinators" "Apply combinators"
"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
$nl
"Two quotations:"
-{ $subsection bi@ }
-{ $subsection 2bi@ }
+{ $subsections bi@ 2bi@ }
"Three quotations:"
-{ $subsection tri@ }
-{ $subsection 2tri@ }
+{ $subsections tri@ 2tri@ }
"A pair of utility words built from " { $link bi@ } ":"
-{ $subsection both? }
-{ $subsection either? } ;
+{ $subsections both? either? } ;
ARTICLE: "retainstack-combinators" "Retain stack combinators"
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
$nl
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
-{ $subsection dip }
-{ $subsection 2dip }
-{ $subsection 3dip }
-{ $subsection 4dip }
+{ $subsections dip 2dip 3dip 4dip }
"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
-{ $subsection keep }
-{ $subsection 2keep }
-{ $subsection 3keep } ;
+{ $subsections keep 2keep 3keep } ;
ARTICLE: "curried-dataflow" "Curried dataflow combinators"
"Curried cleave combinators:"
-{ $subsection bi-curry }
-{ $subsection tri-curry }
+{ $subsections bi-curry tri-curry }
"Curried spread combinators:"
-{ $subsection bi-curry* }
-{ $subsection tri-curry* }
+{ $subsections bi-curry* tri-curry* }
"Curried apply combinators:"
-{ $subsection bi-curry@ }
-{ $subsection tri-curry@ }
+{ $subsections bi-curry@ tri-curry@ }
{ $see-also "dataflow-combinators" } ;
ARTICLE: "compositional-examples" "Examples of compositional combinator usage"
ARTICLE: "compositional-combinators" "Compositional combinators"
"Certain combinators transform quotations to produce a new quotation."
-{ $subsection "compositional-examples" }
+{ $subsections "compositional-examples" }
"Fundamental operations:"
-{ $subsection curry }
-{ $subsection compose }
+{ $subsections curry compose }
"Derived operations:"
-{ $subsection 2curry }
-{ $subsection 3curry }
-{ $subsection with }
-{ $subsection prepose }
+{ $subsections 2curry 3curry with prepose }
"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words."
$nl
"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways."
-{ $subsection "curried-dataflow" }
+{ $subsections "curried-dataflow" }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ;
ARTICLE: "booleans" "Booleans"
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
-{ $subsection f }
-{ $subsection t }
+{ $subsections f t }
"A union class of the above:"
-{ $subsection boolean }
+{ $subsections boolean }
"There are some logical operations on booleans:"
-{ $subsection >boolean }
-{ $subsection not }
-{ $subsection and }
-{ $subsection or }
-{ $subsection xor }
+{ $subsections
+ >boolean
+ not
+ and
+ or
+ xor
+}
"Boolean values are most frequently used for " { $link "conditionals" } "."
{ $heading "The f object and f class" }
"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
ARTICLE: "conditionals" "Conditional combinators"
"The basic conditionals:"
-{ $subsection if }
-{ $subsection when }
-{ $subsection unless }
+{ $subsections if when unless }
"Forms abstracting a common stack shuffle pattern:"
-{ $subsection if* }
-{ $subsection when* }
-{ $subsection unless* }
+{ $subsections if* when* unless* }
"Another form abstracting a common stack shuffle pattern:"
-{ $subsection ?if }
+{ $subsections ?if }
"Sometimes instead of branching, you just need to pick one of two values:"
-{ $subsection ? }
+{ $subsections ? }
"Two combinators which abstract out nested chains of " { $link if } ":"
-{ $subsection cond }
-{ $subsection case }
+{ $subsections cond case }
{ $subsection "conditionals-boolean-equivalence" }
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "dataflow-combinators" "Data flow combinators"
"Data flow combinators pass values between quotations:"
-{ $subsection "retainstack-combinators" }
-{ $subsection "cleave-combinators" }
-{ $subsection "spread-combinators" }
-{ $subsection "apply-combinators" }
+{ $subsections
+ "retainstack-combinators"
+ "cleave-combinators"
+ "spread-combinators"
+ "apply-combinators"
+}
{ $see-also "curried-dataflow" } ;
ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
-{ $subsection cond>quot }
-{ $subsection case>quot }
-{ $subsection alist>quot } ;
+{ $subsections cond>quot case>quot alist>quot } ;
ARTICLE: "call-unsafe" "Unsafe combinators"
"Unsafe calls declare an effect statically without any runtime checking:"
-{ $subsection call-effect-unsafe }
-{ $subsection execute-effect-unsafe } ;
+{ $subsections call-effect-unsafe execute-effect-unsafe } ;
ARTICLE: "call" "Fundamental combinators"
"The most basic combinators are those that take either a quotation or word, and invoke it immediately."
"There are two sets of combinators; they differ in whether or not the stack effect of the expected code is declared."
$nl
"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:"
-{ $subsection call }
-{ $subsection execute }
+{ $subsections call execute }
"The second set of combinators takes an effect declaration. Note that the opening parenthesis is actually part of the word name; these are parsing words, and they read a stack effect until the corresponding closing parenthesis. The stack effect of the quotation or word is then checked at runtime:"
-{ $subsection POSTPONE: call( }
-{ $subsection POSTPONE: execute( }
+{ $subsections POSTPONE: call( POSTPONE: execute( }
"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
-{ $subsection call-effect }
-{ $subsection execute-effect }
+{ $subsections call-effect execute-effect }
"The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "."
{ $subsection "call-unsafe" }
{ $see-also "effects" "inference" } ;
ARTICLE: "combinators" "Combinators"
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
-{ $subsection "call" }
-{ $subsection "dataflow-combinators" }
-{ $subsection "conditionals" }
-{ $subsection "looping-combinators" }
-{ $subsection "compositional-combinators" }
-{ $subsection "combinators.short-circuit" }
-{ $subsection "combinators.smart" }
+{ $subsections
+ "call"
+ "dataflow-combinators"
+ "conditionals"
+ "looping-combinators"
+ "compositional-combinators"
+ "combinators.short-circuit"
+ "combinators.smart"
+ "combinators-quot"
+ "generalizations"
+}
"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
-{ $subsection "combinators-quot" }
-{ $subsection "generalizations" }
{ $see-also "quotations" } ;
ABOUT: "combinators"
[ drop remake-generic drop ]
3tri ; inline
-: method-word-name ( class word -- string )
+: method-word-name ( class generic -- string )
[ name>> ] bi@ "=>" glue ;
PREDICATE: method-body < word
: <method> ( class generic -- method )
check-method
- [ method-word-props ] 2keep
- method-word-name f <word>
- swap >>props ;
+ [ method-word-name f <word> ] [ method-word-props ] 2bi
+ >>props ;
: with-implementors ( class generic quot -- )
[ swap implementors-map get at ] dip call ; inline
"Integers can be converted to and from arbitrary bases. Floating point numbers can only be converted to and from base 10 and 16."
$nl
"Converting numbers to strings:"
-{ $subsection number>string }
-{ $subsection >bin }
-{ $subsection >oct }
-{ $subsection >hex }
-{ $subsection >base }
+{ $subsections
+ number>string
+ >bin
+ >oct
+ >hex
+ >base
+}
"Converting strings to numbers:"
-{ $subsection string>number }
-{ $subsection bin> }
-{ $subsection oct> }
-{ $subsection hex> }
-{ $subsection base> }
+{ $subsections
+ string>number
+ bin>
+ oct>
+ hex>
+ base>
+}
"You can also input literal numbers in a different base (" { $link "syntax-integers" } ")."
{ $see-also "prettyprint-numbers" } ;
ARTICLE: "sequence-protocol" "Sequence protocol"
"All sequences must be instances of a mixin class:"
-{ $subsection sequence }
-{ $subsection sequence? }
+{ $subsections sequence sequence? }
"All sequences must know their length:"
-{ $subsection length }
+{ $subsections length }
"At least one of the following two generic words must have a method for accessing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
-{ $subsection nth }
-{ $subsection nth-unsafe }
+{ $subsections nth nth-unsafe }
"Note that sequences are always indexed starting from zero."
$nl
"At least one of the following two generic words must have a method for storing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
-{ $subsection set-nth }
-{ $subsection set-nth-unsafe }
-"Note that even if the sequence is immutable, at least one of the generic words must be specialized, otherwise calling them will result in an infinite recursion. There is a standard word which throws an error indicating a sequence is immutable:"
-{ $subsection immutable }
+{ $subsections set-nth set-nth-unsafe }
+"If your sequence is immutable, then you must implement either " { $link set-nth } " or " { $link set-nth-unsafe } " to simply call " { $link immutable } " to signal an error."
+$nl
"The following two generic words are optional, as not all sequences are resizable:"
-{ $subsection set-length }
-{ $subsection lengthen }
+{ $subsections set-length lengthen }
"An optional generic word for creating sequences of the same class as a given sequence:"
-{ $subsection like }
+{ $subsections like }
"Optional generic words for optimization purposes:"
-{ $subsection new-sequence }
-{ $subsection new-resizable }
+{ $subsections new-sequence new-resizable }
{ $see-also "sequences-unsafe" } ;
ARTICLE: "virtual-sequences-protocol" "Virtual sequence protocol"
"Virtual sequences must know their length:"
-{ $subsection length }
+{ $subsections length }
"The underlying sequence to look up a value in:"
-{ $subsection virtual-seq }
+{ $subsections virtual-seq }
"The index of the value in the underlying sequence:"
-{ $subsection virtual@ } ;
+{ $subsections virtual@ } ;
ARTICLE: "virtual-sequences" "Virtual sequences"
"A virtual sequence is an implementation of the " { $link "sequence-protocol" } " which does not store its own elements, and instead computes them, either from scratch or by retrieving them from another sequence."
$nl
"Implementations include the following:"
-{ $list
- { $link reversed }
- { $link slice }
- { $link iota }
-}
-"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence:"
-{ $subsection "virtual-sequences-protocol" } ;
+{ $subsections reversed slice iota }
+"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence." ;
ARTICLE: "sequences-integers" "Counted loops"
"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
"To reduce the boilerplate of checking if a sequence is empty, several combinators are provided."
$nl
"Checking if a sequence is empty:"
-{ $subsection if-empty }
-{ $subsection when-empty }
-{ $subsection unless-empty } ;
+{ $subsections if-empty when-empty unless-empty } ;
ARTICLE: "sequences-access" "Accessing sequence elements"
-{ $subsection ?nth }
+"Element access by index, without raising exceptions:"
+{ $subsections ?nth }
"Concise way of extracting one of the first four elements:"
-{ $subsection first }
-{ $subsection second }
-{ $subsection third }
-{ $subsection fourth }
+{ $subsections first second third fourth }
"Extracting the last element:"
-{ $subsection last }
+{ $subsections last }
"Unpacking sequences:"
-{ $subsection first2 }
-{ $subsection first3 }
-{ $subsection first4 }
+{ $subsections first2 first3 first4 }
{ $see-also nth } ;
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
-{ $subsection prefix }
-{ $subsection suffix }
+{ $subsections prefix suffix }
"Removing elements:"
-{ $subsection remove }
-{ $subsection remq }
-{ $subsection remove-nth } ;
+{ $subsections remove remq remove-nth } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
-{ $subsection repetition }
-{ $subsection <repetition> }
+{ $subsections repetition <repetition> }
"Reversing a sequence:"
-{ $subsection reverse }
+{ $subsections reverse }
"A " { $emphasis "reversal" } " presents a reversed view of an underlying sequence:"
-{ $subsection reversed }
-{ $subsection <reversed> }
+{ $subsections reversed <reversed> }
"Transposing a matrix:"
-{ $subsection flip } ;
+{ $subsections flip } ;
ARTICLE: "sequences-appending" "Appending sequences"
-{ $subsection append }
-{ $subsection append-as }
-{ $subsection prepend }
-{ $subsection 3append }
-{ $subsection 3append-as }
-{ $subsection surround }
-{ $subsection glue }
-{ $subsection concat }
-{ $subsection join }
+"Basic append operations:"
+{ $subsections
+ append
+ append-as
+ prepend
+ 3append
+ 3append-as
+ surround
+ glue
+}
+"Collapse a sequence unto itself:"
+{ $subsections concat join }
"A pair of words useful for aligning strings:"
-{ $subsection pad-head }
-{ $subsection pad-tail } ;
+{ $subsections pad-head pad-tail } ;
ARTICLE: "sequences-slices" "Subsequences and slices"
"There are two ways to extract a subrange of elements from a sequence. The first approach creates a new sequence of the same type as the input, which does not share storage with the underlying sequence. This takes time proportional to the number of elements being extracted. The second approach creates a " { $emphasis "slice" } ", which is a virtual sequence (see " { $link "virtual-sequences" } ") sharing storage with the original sequence. Slices are constructed in constant time."
}
{ $heading "Subsequence operations" }
"Extracting a subsequence:"
-{ $subsection subseq }
-{ $subsection head }
-{ $subsection tail }
-{ $subsection head* }
-{ $subsection tail* }
+{ $subsections
+ subseq
+ head
+ tail
+ head*
+ tail*
+}
"Removing the first or last element:"
-{ $subsection rest }
-{ $subsection but-last }
+{ $subsections rest but-last }
"Taking a sequence apart into a head and a tail:"
-{ $subsection unclip }
-{ $subsection unclip-last }
-{ $subsection cut }
-{ $subsection cut* }
+{ $subsections
+ unclip
+ unclip-last
+ cut
+ cut*
+}
{ $heading "Slice operations" }
"The slice data type:"
-{ $subsection slice }
-{ $subsection slice? }
+{ $subsections slice slice? }
"Extracting a slice:"
-{ $subsection <slice> }
-{ $subsection head-slice }
-{ $subsection tail-slice }
-{ $subsection head-slice* }
-{ $subsection tail-slice* }
+{ $subsections
+ <slice>
+ head-slice
+ tail-slice
+ head-slice*
+ tail-slice*
+}
"Removing the first or last element:"
-{ $subsection rest-slice }
-{ $subsection but-last-slice }
+{ $subsections rest-slice but-last-slice }
"Taking a sequence apart into a head and a tail:"
-{ $subsection unclip-slice }
-{ $subsection unclip-last-slice }
-{ $subsection cut-slice }
+{ $subsections unclip-slice unclip-last-slice cut-slice }
"A utility for words which use slices as iterators:"
-{ $subsection <flat-slice> }
+{ $subsections <flat-slice> }
"Replacing slices with new elements:"
-{ $subsection replace-slice } ;
+{ $subsections replace-slice } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
"Iteration:"
-{ $subsection each }
-{ $subsection each-index }
-{ $subsection reduce }
-{ $subsection interleave }
-{ $subsection replicate }
-{ $subsection replicate-as }
+{ $subsections
+ each
+ each-index
+ reduce
+ interleave
+ replicate
+ replicate-as
+}
"Mapping:"
-{ $subsection map }
-{ $subsection map-as }
-{ $subsection map-index }
-{ $subsection map-reduce }
-{ $subsection accumulate }
-{ $subsection produce }
-{ $subsection produce-as }
+{ $subsections
+ map
+ map-as
+ map-index
+ map-reduce
+ accumulate
+ produce
+ produce-as
+}
"Filtering:"
-{ $subsection filter }
-{ $subsection partition }
+{ $subsections
+ filter
+ partition
+}
"Testing if a sequence contains elements satisfying a predicate:"
-{ $subsection any? }
-{ $subsection all? }
+{ $subsections
+ any?
+ all?
+}
+{ $heading "Related Articles" }
{ $subsection "sequence-2combinators" }
{ $subsection "sequence-3combinators" } ;
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined."
-{ $subsection 2each }
-{ $subsection 2reduce }
-{ $subsection 2map }
-{ $subsection 2map-as }
-{ $subsection 2map-reduce }
-{ $subsection 2all? } ;
+{ $subsections
+ 2each
+ 2reduce
+ 2map
+ 2map-as
+ 2map-reduce
+ 2all?
+} ;
ARTICLE: "sequence-3combinators" "Triple-wise sequence combinators"
"There is a set of combinators which traverse three sequences triple-wise. If one sequence is shorter than the others, then only the prefix having the length of the minimum of the three is examined."
-{ $subsection 3each }
-{ $subsection 3map }
-{ $subsection 3map-as } ;
+{ $subsections 3each 3map 3map-as } ;
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
-{ $subsection empty? }
+{ $subsections empty? }
"Testing indices:"
-{ $subsection bounds-check? }
+{ $subsections bounds-check? }
"Testing if a sequence contains an object:"
-{ $subsection member? }
-{ $subsection memq? }
+{ $subsections member? memq? }
"Testing if a sequence contains a subsequence:"
-{ $subsection head? }
-{ $subsection tail? }
-{ $subsection subseq? } ;
+{ $subsections head? tail? subseq? } ;
ARTICLE: "sequences-search" "Searching sequences"
"Finding the index of an element:"
-{ $subsection index }
-{ $subsection index-from }
-{ $subsection last-index }
-{ $subsection last-index-from }
+{ $subsections
+ index
+ index-from
+ last-index
+ last-index-from
+}
"Finding the start of a subsequence:"
-{ $subsection start }
-{ $subsection start* }
+{ $subsections start start* }
"Finding the index of an element satisfying a predicate:"
-{ $subsection find }
-{ $subsection find-from }
-{ $subsection find-last }
-{ $subsection find-last-from }
-{ $subsection map-find } ;
+{ $subsections
+ find
+ find-from
+ find-last
+ find-last-from
+ map-find
+} ;
ARTICLE: "sequences-trimming" "Trimming sequences"
"Trimming words:"
-{ $subsection trim }
-{ $subsection trim-head }
-{ $subsection trim-tail }
+{ $subsections trim trim-head trim-tail }
"Potentially more efficient trim:"
-{ $subsection trim-slice }
-{ $subsection trim-head-slice }
-{ $subsection trim-tail-slice } ;
+{ $subsections trim-slice trim-head-slice trim-tail-slice } ;
ARTICLE: "sequences-destructive-discussion" "When to use destructive operations"
"Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more re-usable and easier to reason about. There are two main reasons to use destructive operations:"
"The second reason is much weaker than the first one. In particular, many combinators (see " { $link map } ", " { $link produce } " and " { $link "namespaces-make" } ") as well as more advanced data structures (such as " { $vocab-link "persistent.vectors" } ") alleviate the need for explicit use of side effects." ;
ARTICLE: "sequences-destructive" "Destructive operations"
-"These words modify their input, instead of creating a new sequence."
-{ $subsection "sequences-destructive-discussion" }
"Changing elements:"
-{ $subsection change-each }
-{ $subsection change-nth }
+{ $subsections change-each change-nth }
"Deleting elements:"
-{ $subsection delete }
-{ $subsection delq }
-{ $subsection delete-nth }
-{ $subsection delete-slice }
-{ $subsection delete-all }
-{ $subsection filter-here }
+{ $subsections
+ delete
+ delq
+ delete-nth
+ delete-slice
+ delete-all
+ filter-here
+}
"Other destructive words:"
-{ $subsection reverse-here }
-{ $subsection push-all }
-{ $subsection move }
-{ $subsection exchange }
-{ $subsection copy }
+{ $subsections
+ reverse-here
+ push-all
+ move
+ exchange
+ copy
+}
"Many operations have constructive and destructive variants:"
{ $table
{ "Constructive" "Destructive" }
{ { $link map } { $link change-each } }
{ { $link filter } { $link filter-here } }
}
-{ $see-also set-nth push pop "sequences-stacks" } ;
+{ $heading "Related Articles" }
+{ $subsection "sequences-destructive-discussion" }
+{ $subsection "sequences-stacks" }
+{ $see-also set-nth push pop } ;
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
"The classical stack operations, modifying a sequence in place:"
-{ $subsection push }
-{ $subsection pop }
-{ $subsection pop* }
+{ $subsections push pop pop* }
{ $see-also empty? } ;
ARTICLE: "sequences-comparing" "Comparing sequences"
"Element equality testing:"
-{ $subsection sequence= }
-{ $subsection mismatch }
-{ $subsection drop-prefix }
-{ $subsection assert-sequence= }
+{ $subsections
+ sequence=
+ mismatch
+ drop-prefix
+ assert-sequence=
+}
"The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
ARTICLE: "sequences-f" "The f object as a sequence"
"A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
$nl
"Sequences implement a protocol:"
-{ $subsection "sequence-protocol" }
-{ $subsection "sequences-f" }
+{ $subsections
+ "sequence-protocol"
+ "sequences-f"
+}
"Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $link "virtual-sequences" } "."
-{ $subsection "sequences-access" }
-{ $subsection "sequences-combinators" }
-{ $subsection "sequences-add-remove" }
-{ $subsection "sequences-appending" }
-{ $subsection "sequences-slices" }
-{ $subsection "sequences-reshape" }
-{ $subsection "sequences-tests" }
-{ $subsection "sequences-search" }
-{ $subsection "sequences-comparing" }
-{ $subsection "sequences-split" }
-{ $subsection "grouping" }
-{ $subsection "sequences-destructive" }
-{ $subsection "sequences-stacks" }
-{ $subsection "sequences-sorting" }
-{ $subsection "binary-search" }
-{ $subsection "sets" }
-{ $subsection "sequences-trimming" }
-{ $subsection "sequences.deep" }
+{ $subsections
+ "sequences-access"
+ "sequences-combinators"
+ "sequences-add-remove"
+ "sequences-appending"
+ "sequences-slices"
+ "sequences-reshape"
+ "sequences-tests"
+ "sequences-search"
+ "sequences-comparing"
+ "sequences-split"
+ "grouping"
+ "sequences-destructive"
+ "sequences-stacks"
+ "sequences-sorting"
+ "binary-search"
+ "sets"
+ "sequences-trimming"
+ "sequences.deep"
+}
"Using sequences for looping:"
-{ $subsection "sequences-integers" }
-{ $subsection "math.ranges" }
+{ $subsections
+ "sequences-integers"
+ "math.ranges"
+}
"Using sequences for control flow:"
-{ $subsection "sequences-if" }
+{ $subsections "sequences-if" }
"For inner loops:"
-{ $subsection "sequences-unsafe" } ;
+{ $subsections "sequences-unsafe" } ;
ABOUT: "sequences"
"Sorting combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
$nl
"Sorting a sequence with a custom comparator:"
-{ $subsection sort }
+{ $subsections sort }
"Sorting a sequence with common comparators:"
-{ $subsection sort-with }
-{ $subsection inv-sort-with }
-{ $subsection natural-sort }
-{ $subsection sort-keys }
-{ $subsection sort-values } ;
+{ $subsections
+ sort-with
+ inv-sort-with
+ natural-sort
+ sort-keys
+ sort-values
+} ;
ABOUT: "sequences-sorting"
USING: math math.order kernel arrays byte-arrays sequences
-colors.hsv benchmark.mandel.params accessors colors ;
+colors.hsv accessors colors fry benchmark.mandel.params ;
IN: benchmark.mandel.colors
: scale ( x -- y ) 255 * >fixnum ; inline
CONSTANT: val 0.85
: <color-map> ( nb-cols -- map )
- dup [
- 360 * swap 1 + / sat val
+ [ iota ] keep '[
+ 360 * _ 1 + / sat val
1 <hsva> >rgba scale-rgb
- ] with map ;
+ ] map ;
: color-map ( -- map )
max-iterations max-color min <color-map> ; foldable
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math math.functions sequences prettyprint
io.files io.files.temp io.encodings io.encodings.ascii
benchmark.mandel.colors ;
IN: benchmark.mandel
-: x-inc ( -- x ) width 200000 zoom-fact * / ; inline
-: y-inc ( -- y ) height 150000 zoom-fact * / ; inline
+: x-scale ( -- x ) width 200000 zoom-fact * / ; inline
+: y-scale ( -- y ) height 150000 zoom-fact * / ; inline
-: c ( i j -- c )
- [ x-inc * center real-part x-inc width 2 / * - + >float ]
- [ y-inc * center imaginary-part y-inc height 2 / * - + >float ] bi*
- rect> ; inline
+: scale ( x y -- z ) [ x-scale * ] [ y-scale * ] bi* rect> ; inline
+
+: c ( i j -- c ) scale center width height scale 2 / - + ; inline
: count-iterations ( z max-iterations step-quot test-quot -- #iters )
'[ drop @ dup @ ] find-last-integer nip ; inline
[ color-map [ length mod ] keep nth ] [ B{ 0 0 0 } ] if* ; inline
: render ( -- )
- height [ width swap '[ _ c pixel color write ] each ] each ; inline
+ height iota [ width iota swap '[ _ c pixel color write ] each ] each ; inline
: ppm-header ( -- )
ascii encode-output
math.functions math.vectors math.vectors.simd prettyprint
combinators.smart sequences hints classes.struct
specialized-arrays ;
-SIMD: double-4
+SIMD: double
IN: benchmark.nbody-simd
: solar-mass ( -- x ) 4 pi sq * ; inline
io.encodings.binary kernel math math.constants math.functions
math.vectors math.vectors.simd math.parser make sequences
sequences.private words hints classes.struct ;
-SIMD: double-4
+SIMD: double
IN: benchmark.raytracer-simd
! parameters
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io math math.functions math.parser math.vectors
math.vectors.simd sequences specialized-arrays ;
-SIMD: float-4
+SIMD: float
SPECIALIZED-ARRAY: float-4
IN: benchmark.simd-1
] [
number-of-requests
[ read1 write1 flush ] times
- counter get count-down
] if
] with-stream
] curry "Client handler" spawn drop server-loop ;
: clients ( n -- )
dup pprint " clients: " write [
<promise> port-promise set
- dup 2 * <count-down> counter set
+ dup <count-down> counter set
[ simple-server ] "Simple server" spawn drop
yield yield
[ [ simple-client ] "Simple client" spawn drop ] times
+++ /dev/null
-USING: alien.syntax io io.encodings.utf16n io.encodings.utf8 io.files
-kernel namespaces sequences system threads unix.utilities ;
-IN: mttest
-
-FUNCTION: void* start_standalone_factor_in_new_thread ( int argc, char** argv ) ;
-
-HOOK: native-string-encoding os ( -- encoding )
-M: windows native-string-encoding utf16n ;
-M: unix native-string-encoding utf8 ;
-
-: start-vm-in-os-thread ( args -- threadhandle )
- \ vm get-global prefix
- [ length ] [ native-string-encoding strings>alien ] bi
- start_standalone_factor_in_new_thread ;
-
-: start-tetris-in-os-thread ( -- )
- { "-run=tetris" } start-vm-in-os-thread drop ;
-
-: start-testthread-in-os-thread ( -- )
- { "-run=mttest" } start-vm-in-os-thread drop ;
-
-: testthread ( -- )
- "/tmp/hello" utf8 [ "hello!\n" write ] with-file-appender 5000000 sleep ;
-
-MAIN: testthread
\ No newline at end of file
--- /dev/null
+USING: alien.syntax io io.encodings.utf16n io.encodings.utf8 io.files
+kernel namespaces sequences system threads unix.utilities ;
+IN: native-thread-test
+
+FUNCTION: void* start_standalone_factor_in_new_thread ( int argc, char** argv ) ;
+
+HOOK: native-string-encoding os ( -- encoding )
+M: windows native-string-encoding utf16n ;
+M: unix native-string-encoding utf8 ;
+
+: start-vm-in-os-thread ( args -- threadhandle )
+ \ vm get-global prefix
+ [ length ] [ native-string-encoding strings>alien ] bi
+ start_standalone_factor_in_new_thread ;
+
+: start-tetris-in-os-thread ( -- )
+ { "-run=tetris" } start-vm-in-os-thread drop ;
+
+: start-testthread-in-os-thread ( -- )
+ { "-run=native-thread-test" } start-vm-in-os-thread drop ;
+
+: testthread ( -- )
+ "/tmp/hello" utf8 [ "hello!\n" write ] with-file-appender 5000000 sleep ;
+
+MAIN: testthread
\ No newline at end of file
help-webapp new-dispatcher
<main-action> "" add-responder
over <search-action> "search" add-responder
- swap <static> "content" add-responder ;
+ swap <static> "content" add-responder
+ "resource:basis/definitions/icons/" <static> "icons" add-responder ;
/* gets the address of an object representing a C pointer, with the
intention of storing the pointer across code which may potentially GC. */
-char *factorvm::pinned_alien_offset(cell obj)
+char *factor_vm::pinned_alien_offset(cell obj)
{
switch(tagged<object>(obj).type())
{
}
/* make an alien */
-cell factorvm::allot_alien(cell delegate_, cell displacement)
+cell factor_vm::allot_alien(cell delegate_, cell displacement)
{
gc_root<object> delegate(delegate_,this);
gc_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
}
/* make an alien pointing at an offset of another alien */
-inline void factorvm::vmprim_displaced_alien()
+inline void factor_vm::primitive_displaced_alien()
{
cell alien = dpop();
cell displacement = to_cell(dpop());
PRIMITIVE(displaced_alien)
{
- PRIMITIVE_GETVM()->vmprim_displaced_alien();
+ PRIMITIVE_GETVM()->primitive_displaced_alien();
}
/* address of an object representing a C pointer. Explicitly throw an error
if the object is a byte array, as a sanity check. */
-inline void factorvm::vmprim_alien_address()
+inline void factor_vm::primitive_alien_address()
{
box_unsigned_cell((cell)pinned_alien_offset(dpop()));
}
PRIMITIVE(alien_address)
{
- PRIMITIVE_GETVM()->vmprim_alien_address();
+ PRIMITIVE_GETVM()->primitive_alien_address();
}
/* pop ( alien n ) from datastack, return alien's address plus n */
-void *factorvm::alien_pointer()
+void *factor_vm::alien_pointer()
{
fixnum offset = to_fixnum(dpop());
return unbox_alien() + offset;
DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
/* open a native library and push a handle */
-inline void factorvm::vmprim_dlopen()
+inline void factor_vm::primitive_dlopen()
{
gc_root<byte_array> path(dpop(),this);
path.untag_check(this);
PRIMITIVE(dlopen)
{
- PRIMITIVE_GETVM()->vmprim_dlopen();
+ PRIMITIVE_GETVM()->primitive_dlopen();
}
/* look up a symbol in a native library */
-inline void factorvm::vmprim_dlsym()
+inline void factor_vm::primitive_dlsym()
{
gc_root<object> library(dpop(),this);
gc_root<byte_array> name(dpop(),this);
PRIMITIVE(dlsym)
{
- PRIMITIVE_GETVM()->vmprim_dlsym();
+ PRIMITIVE_GETVM()->primitive_dlsym();
}
/* close a native library handle */
-inline void factorvm::vmprim_dlclose()
+inline void factor_vm::primitive_dlclose()
{
dll *d = untag_check<dll>(dpop());
if(d->dll != NULL)
PRIMITIVE(dlclose)
{
- PRIMITIVE_GETVM()->vmprim_dlclose();
+ PRIMITIVE_GETVM()->primitive_dlclose();
}
-inline void factorvm::vmprim_dll_validp()
+inline void factor_vm::primitive_dll_validp()
{
cell library = dpop();
if(library == F)
PRIMITIVE(dll_validp)
{
- PRIMITIVE_GETVM()->vmprim_dll_validp();
+ PRIMITIVE_GETVM()->primitive_dll_validp();
}
/* gets the address of an object representing a C pointer */
-char *factorvm::alien_offset(cell obj)
+char *factor_vm::alien_offset(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-VM_C_API char *alien_offset(cell obj, factorvm *myvm)
+VM_C_API char *alien_offset(cell obj, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->alien_offset(obj);
}
/* pop an object representing a C pointer */
-char *factorvm::unbox_alien()
+char *factor_vm::unbox_alien()
{
return alien_offset(dpop());
}
-VM_C_API char *unbox_alien(factorvm *myvm)
+VM_C_API char *unbox_alien(factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->unbox_alien();
}
/* make an alien and push */
-void factorvm::box_alien(void *ptr)
+void factor_vm::box_alien(void *ptr)
{
if(ptr == NULL)
dpush(F);
dpush(allot_alien(F,(cell)ptr));
}
-VM_C_API void box_alien(void *ptr, factorvm *myvm)
+VM_C_API void box_alien(void *ptr, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_alien(ptr);
}
/* for FFI calls passing structs by value */
-void factorvm::to_value_struct(cell src, void *dest, cell size)
+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, factorvm *myvm)
+VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_value_struct(src,dest,size);
}
/* for FFI callbacks receiving structs by value */
-void factorvm::box_value_struct(void *src, cell size)
+void factor_vm::box_value_struct(void *src, cell size)
{
byte_array *bytes = allot_byte_array(size);
memcpy(bytes->data<void>(),src,size);
dpush(tag<byte_array>(bytes));
}
-VM_C_API void box_value_struct(void *src, cell size,factorvm *myvm)
+VM_C_API void box_value_struct(void *src, cell size,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_value_struct(src,size);
}
/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
-void factorvm::box_small_struct(cell x, cell y, cell size)
+void factor_vm::box_small_struct(cell x, cell y, cell size)
{
cell data[2];
data[0] = x;
box_value_struct(data,size);
}
-VM_C_API void box_small_struct(cell x, cell y, cell size, factorvm *myvm)
+VM_C_API void box_small_struct(cell x, cell y, cell size, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_small_struct(x,y,size);
}
/* On OS X/PPC, complex numbers are returned in registers. */
-void factorvm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
+void factor_vm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
{
cell data[4];
data[0] = x1;
box_value_struct(data,size);
}
-VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factorvm *myvm)
+VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_medium_struct(x1, x2, x3, x4, size);
}
-inline void factorvm::vmprim_vm_ptr()
+inline void factor_vm::primitive_vm_ptr()
{
box_alien(this);
}
PRIMITIVE(vm_ptr)
{
- PRIMITIVE_GETVM()->vmprim_vm_ptr();
+ PRIMITIVE_GETVM()->primitive_vm_ptr();
}
}
PRIMITIVE(vm_ptr);
-VM_C_API char *alien_offset(cell object, factorvm *vm);
-VM_C_API char *unbox_alien(factorvm *vm);
-VM_C_API void box_alien(void *ptr, factorvm *vm);
-VM_C_API void to_value_struct(cell src, void *dest, cell size, factorvm *vm);
-VM_C_API void box_value_struct(void *src, cell size,factorvm *vm);
-VM_C_API void box_small_struct(cell x, cell y, cell size,factorvm *vm);
-VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size,factorvm *vm);
+VM_C_API char *alien_offset(cell object, factor_vm *vm);
+VM_C_API char *unbox_alien(factor_vm *vm);
+VM_C_API void box_alien(void *ptr, factor_vm *vm);
+VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *vm);
+VM_C_API void box_value_struct(void *src, cell size,factor_vm *vm);
+VM_C_API void box_small_struct(cell x, cell y, cell size,factor_vm *vm);
+VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size,factor_vm *vm);
}
{
/* make a new array with an initial element */
-array *factorvm::allot_array(cell capacity, cell fill_)
+array *factor_vm::allot_array(cell capacity, cell fill_)
{
gc_root<object> fill(fill_,this);
gc_root<array> new_array(allot_array_internal<array>(capacity),this);
return new_array.untagged();
}
-
/* push a new array on the stack */
-inline void factorvm::vmprim_array()
+inline void factor_vm::primitive_array()
{
cell initial = dpop();
cell size = unbox_array_size();
PRIMITIVE(array)
{
- PRIMITIVE_GETVM()->vmprim_array();
+ PRIMITIVE_GETVM()->primitive_array();
}
-cell factorvm::allot_array_1(cell obj_)
+cell factor_vm::allot_array_1(cell obj_)
{
gc_root<object> obj(obj_,this);
gc_root<array> a(allot_array_internal<array>(1),this);
return a.value();
}
-
-cell factorvm::allot_array_2(cell v1_, cell v2_)
+cell factor_vm::allot_array_2(cell v1_, cell v2_)
{
gc_root<object> v1(v1_,this);
gc_root<object> v2(v2_,this);
return a.value();
}
-
-cell factorvm::allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
+cell factor_vm::allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
{
gc_root<object> v1(v1_,this);
gc_root<object> v2(v2_,this);
return a.value();
}
-
-inline void factorvm::vmprim_resize_array()
+inline void factor_vm::primitive_resize_array()
{
array* a = untag_check<array>(dpop());
cell capacity = unbox_array_size();
PRIMITIVE(resize_array)
{
- PRIMITIVE_GETVM()->vmprim_resize_array();
+ PRIMITIVE_GETVM()->primitive_resize_array();
}
void growable_array::add(cell elt_)
{
- factorvm* myvm = elements.myvm;
- gc_root<object> elt(elt_,myvm);
+ factor_vm* parent_vm = elements.parent_vm;
+ gc_root<object> elt(elt_,parent_vm);
if(count == array_capacity(elements.untagged()))
- elements = myvm->reallot_array(elements.untagged(),count * 2);
+ elements = parent_vm->reallot_array(elements.untagged(),count * 2);
- myvm->set_array_nth(elements.untagged(),count++,elt.value());
+ parent_vm->set_array_nth(elements.untagged(),count++,elt.value());
}
void growable_array::trim()
{
- factorvm *myvm = elements.myvm;
- elements = myvm->reallot_array(elements.untagged(),count);
+ factor_vm *parent_vm = elements.parent_vm;
+ elements = parent_vm->reallot_array(elements.untagged(),count);
}
}
PRIMITIVE(array);
PRIMITIVE(resize_array);
-
}
-/* :tabSize=2:indentSize=2:noTabs=true:
-
+/*
Copyright (C) 1989-94 Massachusetts Institute of Technology
Portions copyright (C) 2004-2008 Slava Pestov
/* Exports */
-int factorvm::bignum_equal_p(bignum * x, bignum * y)
+int factor_vm::bignum_equal_p(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
&& (bignum_equal_p_unsigned (x, y))));
}
-
-enum bignum_comparison factorvm::bignum_compare(bignum * x, bignum * y)
+enum bignum_comparison factor_vm::bignum_compare(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
: (bignum_compare_unsigned (x, y))));
}
-
/* allocates memory */
-bignum *factorvm::bignum_add(bignum * x, bignum * y)
+bignum *factor_vm::bignum_add(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
}
/* allocates memory */
-bignum *factorvm::bignum_subtract(bignum * x, bignum * y)
+bignum *factor_vm::bignum_subtract(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
: (bignum_subtract_unsigned (x, y))))));
}
-
/* allocates memory */
-bignum *factorvm::bignum_multiply(bignum * x, bignum * y)
+bignum *factor_vm::bignum_multiply(bignum * x, bignum * y)
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
bignum_length_type y_length = (BIGNUM_LENGTH (y));
if (BIGNUM_ZERO_P (y))
return (y);
if (x_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (x, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (y, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
- }
+ {
+ bignum_digit_type digit = (BIGNUM_REF (x, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (y, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
+ }
if (y_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (y, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (x, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
- }
+ {
+ bignum_digit_type digit = (BIGNUM_REF (y, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (x, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
+ }
return (bignum_multiply_unsigned (x, y, negative_p));
}
-
/* allocates memory */
-void factorvm::bignum_divide(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder)
+void factor_vm::bignum_divide(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder)
{
if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error();
- return;
- }
+ {
+ divide_by_zero_error();
+ return;
+ }
if (BIGNUM_ZERO_P (numerator))
- {
- (*quotient) = numerator;
- (*remainder) = numerator;
- }
+ {
+ (*quotient) = numerator;
+ (*remainder) = numerator;
+ }
else
+ {
+ int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
+ switch (bignum_compare_unsigned (numerator, denominator))
{
- int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
- int q_negative_p =
- ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
- switch (bignum_compare_unsigned (numerator, denominator))
+ case bignum_comparison_equal:
+ {
+ (*quotient) = (BIGNUM_ONE (q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ case bignum_comparison_less:
+ {
+ (*quotient) = (BIGNUM_ZERO ());
+ (*remainder) = numerator;
+ break;
+ }
+ case bignum_comparison_greater:
+ {
+ if ((BIGNUM_LENGTH (denominator)) == 1)
{
- case bignum_comparison_equal:
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
{
- (*quotient) = (BIGNUM_ONE (q_negative_p));
+ (*quotient) =
+ (bignum_maybe_new_sign (numerator, q_negative_p));
(*remainder) = (BIGNUM_ZERO ());
break;
}
- case bignum_comparison_less:
+ else if (digit < BIGNUM_RADIX_ROOT)
{
- (*quotient) = (BIGNUM_ZERO ());
- (*remainder) = numerator;
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
break;
}
- case bignum_comparison_greater:
+ else
{
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- {
- (*quotient) =
- (bignum_maybe_new_sign (numerator, q_negative_p));
- (*remainder) = (BIGNUM_ZERO ());
- break;
- }
- else if (digit < BIGNUM_RADIX_ROOT)
- {
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- else
- {
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- }
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
quotient, remainder,
q_negative_p, r_negative_p);
break;
}
}
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
}
+ }
}
-
/* allocates memory */
-bignum *factorvm::bignum_quotient(bignum * numerator, bignum * denominator)
+bignum *factor_vm::bignum_quotient(bignum * numerator, bignum * denominator)
{
if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error();
- return (BIGNUM_OUT_OF_BAND);
- }
+ {
+ divide_by_zero_error();
+ return (BIGNUM_OUT_OF_BAND);
+ }
if (BIGNUM_ZERO_P (numerator))
return numerator;
{
? (! (BIGNUM_NEGATIVE_P (numerator)))
: (BIGNUM_NEGATIVE_P (numerator)));
switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ONE (q_negative_p));
+ case bignum_comparison_less:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
{
- case bignum_comparison_equal:
- return (BIGNUM_ONE (q_negative_p));
- case bignum_comparison_less:
- return (BIGNUM_ZERO ());
- case bignum_comparison_greater:
- default: /* to appease gcc -Wall */
+ bignum * quotient;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
{
- bignum * quotient;
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (numerator, q_negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- ("ient), ((bignum * *) 0),
- q_negative_p, 0);
- else
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- ("ient), ((bignum * *) 0),
- q_negative_p, 0);
- }
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (numerator, q_negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
("ient), ((bignum * *) 0),
q_negative_p, 0);
- return (quotient);
}
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
+ return (quotient);
}
+ }
}
}
-
/* allocates memory */
-bignum *factorvm::bignum_remainder(bignum * numerator, bignum * denominator)
+bignum *factor_vm::bignum_remainder(bignum * numerator, bignum * denominator)
{
if (BIGNUM_ZERO_P (denominator))
{
}
}
-
-#define FOO_TO_BIGNUM(name,type,utype) \
-bignum * factorvm::name##_to_bignum(type n) \
-{ \
- int negative_p; \
- bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
- bignum_digit_type * end_digits = result_digits; \
- /* Special cases win when these small constants are cached. */ \
- if (n == 0) return (BIGNUM_ZERO ()); \
- if (n == 1) return (BIGNUM_ONE (0)); \
- if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
- { \
- utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \
- do \
- { \
- (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
- accumulator >>= BIGNUM_DIGIT_LENGTH; \
- } \
- while (accumulator != 0); \
- } \
- { \
- bignum * result = \
- (allot_bignum ((end_digits - result_digits), negative_p)); \
- bignum_digit_type * scan_digits = result_digits; \
- bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
- while (scan_digits < end_digits) \
- (*scan_result++) = (*scan_digits++); \
- return (result); \
- } \
+#define FOO_TO_BIGNUM(name,type,utype) \
+bignum * factor_vm::name##_to_bignum(type n) \
+{ \
+ int negative_p; \
+ bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
+ bignum_digit_type * end_digits = result_digits; \
+ /* Special cases win when these small constants are cached. */ \
+ if (n == 0) return (BIGNUM_ZERO ()); \
+ if (n == 1) return (BIGNUM_ONE (0)); \
+ if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
+ { \
+ utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \
+ do \
+ { \
+ (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
+ accumulator >>= BIGNUM_DIGIT_LENGTH; \
+ } \
+ while (accumulator != 0); \
+ } \
+ { \
+ bignum * result = \
+ (allot_bignum ((end_digits - result_digits), negative_p)); \
+ bignum_digit_type * scan_digits = result_digits; \
+ bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
+ while (scan_digits < end_digits) \
+ (*scan_result++) = (*scan_digits++); \
+ return (result); \
+ } \
}
/* all below allocate memory */
FOO_TO_BIGNUM(long_long,s64,u64)
FOO_TO_BIGNUM(ulong_long,u64,u64)
-#define BIGNUM_TO_FOO(name,type,utype) \
- type factorvm::bignum_to_##name(bignum * bignum) \
- { \
- if (BIGNUM_ZERO_P (bignum)) \
- return (0); \
- { \
- utype accumulator = 0; \
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
+
+#define BIGNUM_TO_FOO(name,type,utype) \
+ type factor_vm::bignum_to_##name(bignum * bignum) \
+ { \
+ if (BIGNUM_ZERO_P (bignum)) \
+ return (0); \
+ { \
+ utype accumulator = 0; \
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
- while (start < scan) \
+ while (start < scan) \
accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
- } \
+ } \
}
/* all of the below allocate memory */
BIGNUM_TO_FOO(long_long,s64,u64)
BIGNUM_TO_FOO(ulong_long,u64,u64)
-double factorvm::bignum_to_double(bignum * bignum)
+double factor_vm::bignum_to_double(bignum * bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (0);
}
}
-
-#define DTB_WRITE_DIGIT(factor) \
-{ \
+#define DTB_WRITE_DIGIT(factor) \
+{ \
significand *= (factor); \
- digit = ((bignum_digit_type) significand); \
- (*--scan) = digit; \
- significand -= ((double) digit); \
+ digit = ((bignum_digit_type) significand); \
+ (*--scan) = digit; \
+ significand -= ((double) digit); \
}
/* allocates memory */
#define inf std::numeric_limits<double>::infinity()
-bignum *factorvm::double_to_bignum(double x)
+bignum *factor_vm::double_to_bignum(double x)
{
if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ());
int exponent;
if (odd_bits > 0)
DTB_WRITE_DIGIT ((fixnum)1 << odd_bits);
while (start < scan)
+ {
+ if (significand == 0)
{
- if (significand == 0)
- {
- while (start < scan)
- (*--scan) = 0;
- break;
- }
- DTB_WRITE_DIGIT (BIGNUM_RADIX);
+ while (start < scan)
+ (*--scan) = 0;
+ break;
}
+ DTB_WRITE_DIGIT (BIGNUM_RADIX);
+ }
return (result);
}
}
-
#undef DTB_WRITE_DIGIT
/* Comparisons */
-int factorvm::bignum_equal_p_unsigned(bignum * x, bignum * y)
+int factor_vm::bignum_equal_p_unsigned(bignum * x, bignum * y)
{
bignum_length_type length = (BIGNUM_LENGTH (x));
if (length != (BIGNUM_LENGTH (y)))
return (0);
else
- {
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_x = (scan_x + length);
- while (scan_x < end_x)
- if ((*scan_x++) != (*scan_y++))
- return (0);
- return (1);
- }
+ {
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_x = (scan_x + length);
+ while (scan_x < end_x)
+ if ((*scan_x++) != (*scan_y++))
+ return (0);
+ return (1);
+ }
}
-
-enum bignum_comparison factorvm::bignum_compare_unsigned(bignum * x, bignum * y)
+enum bignum_comparison factor_vm::bignum_compare_unsigned(bignum * x, bignum * y)
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
bignum_length_type y_length = (BIGNUM_LENGTH (y));
bignum_digit_type * scan_x = (start_x + x_length);
bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
while (start_x < scan_x)
- {
- bignum_digit_type digit_x = (*--scan_x);
- bignum_digit_type digit_y = (*--scan_y);
- if (digit_x < digit_y)
- return (bignum_comparison_less);
- if (digit_x > digit_y)
- return (bignum_comparison_greater);
- }
+ {
+ bignum_digit_type digit_x = (*--scan_x);
+ bignum_digit_type digit_y = (*--scan_y);
+ if (digit_x < digit_y)
+ return (bignum_comparison_less);
+ if (digit_x > digit_y)
+ return (bignum_comparison_greater);
+ }
}
return (bignum_comparison_equal);
}
-
/* Addition */
/* allocates memory */
-bignum *factorvm::bignum_add_unsigned(bignum * x, bignum * y, int negative_p)
+bignum *factor_vm::bignum_add_unsigned(bignum * x, bignum * y, int negative_p)
{
- GC_BIGNUM(x,this); GC_BIGNUM(y,this);
+ GC_BIGNUM(x); GC_BIGNUM(y);
if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum * z = x;
- x = y;
- y = z;
- }
+ {
+ bignum * z = x;
+ x = y;
+ y = z;
+ }
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
-
+
bignum * r = (allot_bignum ((x_length + 1), negative_p));
bignum_digit_type sum;
bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
if (carry != 0)
while (scan_x < end_x)
+ {
+ sum = ((*scan_x++) + 1);
+ if (sum < BIGNUM_RADIX)
{
- sum = ((*scan_x++) + 1);
- if (sum < BIGNUM_RADIX)
- {
- (*scan_r++) = sum;
- carry = 0;
- break;
- }
- else
- (*scan_r++) = (sum - BIGNUM_RADIX);
+ (*scan_r++) = sum;
+ carry = 0;
+ break;
}
+ else
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ }
while (scan_x < end_x)
(*scan_r++) = (*scan_x++);
}
if (carry != 0)
- {
- (*scan_r) = 1;
- return (r);
- }
+ {
+ (*scan_r) = 1;
+ return (r);
+ }
return (bignum_shorten_length (r, x_length));
}
}
-
/* Subtraction */
/* allocates memory */
-bignum *factorvm::bignum_subtract_unsigned(bignum * x, bignum * y)
+bignum *factor_vm::bignum_subtract_unsigned(bignum * x, bignum * y)
{
- GC_BIGNUM(x,this); GC_BIGNUM(y,this);
+ GC_BIGNUM(x); GC_BIGNUM(y);
int negative_p = 0;
switch (bignum_compare_unsigned (x, y))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
{
- case bignum_comparison_equal:
- return (BIGNUM_ZERO ());
- case bignum_comparison_less:
- {
- bignum * z = x;
- x = y;
- y = z;
- }
- negative_p = 1;
- break;
- case bignum_comparison_greater:
- negative_p = 0;
- break;
+ bignum * z = x;
+ x = y;
+ y = z;
}
+ negative_p = 1;
+ break;
+ case bignum_comparison_greater:
+ negative_p = 0;
+ break;
+ }
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
-
+
bignum * r = (allot_bignum (x_length, negative_p));
bignum_digit_type difference;
bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
while (scan_y < end_y)
+ {
+ difference = (((*scan_x++) - (*scan_y++)) - borrow);
+ if (difference < 0)
{
- difference = (((*scan_x++) - (*scan_y++)) - borrow);
- if (difference < 0)
- {
- (*scan_r++) = (difference + BIGNUM_RADIX);
- borrow = 1;
- }
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- }
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ borrow = 1;
+ }
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
}
+ }
}
{
bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
if (borrow != 0)
while (scan_x < end_x)
+ {
+ difference = ((*scan_x++) - borrow);
+ if (difference < 0)
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ else
{
- difference = ((*scan_x++) - borrow);
- if (difference < 0)
- (*scan_r++) = (difference + BIGNUM_RADIX);
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- break;
- }
+ (*scan_r++) = difference;
+ borrow = 0;
+ break;
}
+ }
BIGNUM_ASSERT (borrow == 0);
while (scan_x < end_x)
(*scan_r++) = (*scan_x++);
}
}
-
/* Multiplication
Maximum value for product_low or product_high:
((R * R) + (R * (R - 2)) + (R - 1))
where R == BIGNUM_RADIX_ROOT */
/* allocates memory */
-bignum *factorvm::bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p)
+bignum *factor_vm::bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p)
{
- GC_BIGNUM(x,this); GC_BIGNUM(y,this);
+ GC_BIGNUM(x); GC_BIGNUM(y);
if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum * z = x;
- x = y;
- y = z;
- }
+ {
+ bignum * z = x;
+ x = y;
+ y = z;
+ }
{
bignum_digit_type carry;
bignum_digit_type y_digit_low;
#define y_digit y_digit_high
#define product_high carry
while (scan_x < end_x)
+ {
+ x_digit = (*scan_x++);
+ x_digit_low = (HD_LOW (x_digit));
+ x_digit_high = (HD_HIGH (x_digit));
+ carry = 0;
+ scan_y = start_y;
+ scan_r = (start_r++);
+ while (scan_y < end_y)
{
- x_digit = (*scan_x++);
- x_digit_low = (HD_LOW (x_digit));
- x_digit_high = (HD_HIGH (x_digit));
- carry = 0;
- scan_y = start_y;
- scan_r = (start_r++);
- while (scan_y < end_y)
- {
- y_digit = (*scan_y++);
- y_digit_low = (HD_LOW (y_digit));
- y_digit_high = (HD_HIGH (y_digit));
- product_low =
- ((*scan_r) +
- (x_digit_low * y_digit_low) +
- (HD_LOW (carry)));
- product_high =
- ((x_digit_high * y_digit_low) +
- (x_digit_low * y_digit_high) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan_r++) =
- (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry =
- ((x_digit_high * y_digit_high) +
- (HD_HIGH (product_high)));
- }
- (*scan_r) += carry;
+ y_digit = (*scan_y++);
+ y_digit_low = (HD_LOW (y_digit));
+ y_digit_high = (HD_HIGH (y_digit));
+ product_low =
+ ((*scan_r) +
+ (x_digit_low * y_digit_low) +
+ (HD_LOW (carry)));
+ product_high =
+ ((x_digit_high * y_digit_low) +
+ (x_digit_low * y_digit_high) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan_r++) =
+ (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry =
+ ((x_digit_high * y_digit_high) +
+ (HD_HIGH (product_high)));
}
+ (*scan_r) += carry;
+ }
return (bignum_trim (r));
#undef x_digit
#undef y_digit
}
}
-
/* allocates memory */
-bignum *factorvm::bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y,int negative_p)
+bignum *factor_vm::bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y, int negative_p)
{
- GC_BIGNUM(x,this);
+ GC_BIGNUM(x);
bignum_length_type length_x = (BIGNUM_LENGTH (x));
return (bignum_trim (p));
}
-
-void factorvm::bignum_destructive_add(bignum * bignum, bignum_digit_type n)
+void factor_vm::bignum_destructive_add(bignum * bignum, bignum_digit_type n)
{
bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
bignum_digit_type digit;
digit = ((*scan) + n);
if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
+ {
+ (*scan) = digit;
+ return;
+ }
(*scan++) = (digit - BIGNUM_RADIX);
while (1)
+ {
+ digit = ((*scan) + 1);
+ if (digit < BIGNUM_RADIX)
{
- digit = ((*scan) + 1);
- if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
- (*scan++) = (digit - BIGNUM_RADIX);
+ (*scan) = digit;
+ return;
}
+ (*scan++) = (digit - BIGNUM_RADIX);
+ }
}
-
-void factorvm::bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor)
+void factor_vm::bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor)
{
bignum_digit_type carry = 0;
bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
while (scan < end)
- {
- two_digits = (*scan);
- product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
- product_high =
- ((factor * (HD_HIGH (two_digits))) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry = (HD_HIGH (product_high));
- }
+ {
+ two_digits = (*scan);
+ product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
+ product_high =
+ ((factor * (HD_HIGH (two_digits))) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry = (HD_HIGH (product_high));
+ }
/* A carry here would be an overflow, i.e. it would not fit.
Hopefully the callers allocate enough space that this will
never happen.
#undef product_high
}
-
/* Division */
/* For help understanding this algorithm, see:
section 4.3.1, "Multiple-Precision Arithmetic". */
/* allocates memory */
-void factorvm::bignum_divide_unsigned_large_denominator(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder, int q_negative_p, int r_negative_p)
+void factor_vm::bignum_divide_unsigned_large_denominator(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder, int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator,this); GC_BIGNUM(denominator,this);
+ GC_BIGNUM(numerator); GC_BIGNUM(denominator);
bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
((quotient != ((bignum * *) 0))
? (allot_bignum ((length_n - length_d), q_negative_p))
: BIGNUM_OUT_OF_BAND);
- GC_BIGNUM(q,this);
+ GC_BIGNUM(q);
bignum * u = (allot_bignum (length_n, r_negative_p));
- GC_BIGNUM(u,this);
+ GC_BIGNUM(u);
int shift = 0;
BIGNUM_ASSERT (length_d > 1);
{
bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
while (v1 < (BIGNUM_RADIX / 2))
- {
- v1 <<= 1;
- shift += 1;
- }
- }
- if (shift == 0)
{
- bignum_destructive_copy (numerator, u);
- (BIGNUM_REF (u, (length_n - 1))) = 0;
- bignum_divide_unsigned_normalized (u, denominator, q);
+ v1 <<= 1;
+ shift += 1;
}
+ }
+ if (shift == 0)
+ {
+ bignum_destructive_copy (numerator, u);
+ (BIGNUM_REF (u, (length_n - 1))) = 0;
+ bignum_divide_unsigned_normalized (u, denominator, q);
+ }
else
- {
- bignum * v = (allot_bignum (length_d, 0));
+ {
+ bignum * v = (allot_bignum (length_d, 0));
- bignum_destructive_normalization (numerator, u, shift);
- bignum_destructive_normalization (denominator, v, shift);
- bignum_divide_unsigned_normalized (u, v, q);
- if (remainder != ((bignum * *) 0))
- bignum_destructive_unnormalization (u, shift);
- }
+ bignum_destructive_normalization (numerator, u, shift);
+ bignum_destructive_normalization (denominator, v, shift);
+ bignum_divide_unsigned_normalized (u, v, q);
+ if (remainder != ((bignum * *) 0))
+ bignum_destructive_unnormalization (u, shift);
+ }
if(q)
q = bignum_trim (q);
return;
}
-
-void factorvm::bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q)
+void factor_vm::bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q)
{
bignum_length_type u_length = (BIGNUM_LENGTH (u));
bignum_length_type v_length = (BIGNUM_LENGTH (v));
bignum_digit_type * q_scan = NULL;
bignum_digit_type v1 = (v_end[-1]);
bignum_digit_type v2 = (v_end[-2]);
- bignum_digit_type ph; /* high half of double-digit product */
- bignum_digit_type pl; /* low half of double-digit product */
+ bignum_digit_type ph; /* high half of double-digit product */
+ bignum_digit_type pl; /* low half of double-digit product */
bignum_digit_type guess;
- bignum_digit_type gh; /* high half-digit of guess */
- bignum_digit_type ch; /* high half of double-digit comparand */
+ bignum_digit_type gh; /* high half-digit of guess */
+ bignum_digit_type ch; /* high half of double-digit comparand */
bignum_digit_type v2l = (HD_LOW (v2));
bignum_digit_type v2h = (HD_HIGH (v2));
- bignum_digit_type cl; /* low half of double-digit comparand */
-#define gl ph /* low half-digit of guess */
+ bignum_digit_type cl; /* low half of double-digit comparand */
+#define gl ph /* low half-digit of guess */
#define uj pl
#define qj ph
- bignum_digit_type gm; /* memory loc for reference parameter */
+ bignum_digit_type gm; /* memory loc for reference parameter */
if (q != BIGNUM_OUT_OF_BAND)
q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
while (u_scan_limit < u_scan)
+ {
+ uj = (*--u_scan);
+ if (uj != v1)
{
- uj = (*--u_scan);
- if (uj != v1)
- {
- /* comparand =
- (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
- guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
- cl = (u_scan[-2]);
- ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
- guess = gm;
- }
- else
- {
- cl = (u_scan[-2]);
- ch = ((u_scan[-1]) + v1);
- guess = (BIGNUM_RADIX - 1);
- }
- while (1)
- {
- /* product = (guess * v2); */
- gl = (HD_LOW (guess));
- gh = (HD_HIGH (guess));
- pl = (v2l * gl);
- ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
- pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
- ph = ((v2h * gh) + (HD_HIGH (ph)));
- /* if (comparand >= product) */
- if ((ch > ph) || ((ch == ph) && (cl >= pl)))
- break;
- guess -= 1;
- /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
- ch += v1;
- /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
- if (ch >= BIGNUM_RADIX)
- break;
- }
- qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
- if (q != BIGNUM_OUT_OF_BAND)
- (*--q_scan) = qj;
+ /* comparand =
+ (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
+ guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
+ cl = (u_scan[-2]);
+ ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
+ guess = gm;
}
+ else
+ {
+ cl = (u_scan[-2]);
+ ch = ((u_scan[-1]) + v1);
+ guess = (BIGNUM_RADIX - 1);
+ }
+ while (1)
+ {
+ /* product = (guess * v2); */
+ gl = (HD_LOW (guess));
+ gh = (HD_HIGH (guess));
+ pl = (v2l * gl);
+ ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
+ pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
+ ph = ((v2h * gh) + (HD_HIGH (ph)));
+ /* if (comparand >= product) */
+ if ((ch > ph) || ((ch == ph) && (cl >= pl)))
+ break;
+ guess -= 1;
+ /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
+ ch += v1;
+ /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
+ if (ch >= BIGNUM_RADIX)
+ break;
+ }
+ qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
+ if (q != BIGNUM_OUT_OF_BAND)
+ (*--q_scan) = qj;
+ }
return;
#undef gl
#undef uj
#undef qj
}
-
-bignum_digit_type factorvm::bignum_divide_subtract(bignum_digit_type * v_start, bignum_digit_type * v_end, bignum_digit_type guess, bignum_digit_type * u_start)
+bignum_digit_type factor_vm::bignum_divide_subtract(bignum_digit_type * v_start, bignum_digit_type * v_end, bignum_digit_type guess, bignum_digit_type * u_start)
{
bignum_digit_type * v_scan = v_start;
bignum_digit_type * u_scan = u_start;
#define ph carry
#define diff pl
while (v_scan < v_end)
+ {
+ v = (*v_scan++);
+ vl = (HD_LOW (v));
+ vh = (HD_HIGH (v));
+ pl = ((vl * gl) + (HD_LOW (carry)));
+ ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
+ diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
+ if (diff < 0)
{
- v = (*v_scan++);
- vl = (HD_LOW (v));
- vh = (HD_HIGH (v));
- pl = ((vl * gl) + (HD_LOW (carry)));
- ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
- diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
- if (diff < 0)
- {
- (*u_scan++) = (diff + BIGNUM_RADIX);
- carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
- }
- else
- {
- (*u_scan++) = diff;
- carry = ((vh * gh) + (HD_HIGH (ph)));
- }
+ (*u_scan++) = (diff + BIGNUM_RADIX);
+ carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
}
+ else
+ {
+ (*u_scan++) = diff;
+ carry = ((vh * gh) + (HD_HIGH (ph)));
+ }
+ }
if (carry == 0)
return (guess);
diff = ((*u_scan) - carry);
if (diff < 0)
(*u_scan) = (diff + BIGNUM_RADIX);
else
- {
- (*u_scan) = diff;
- return (guess);
- }
+ {
+ (*u_scan) = diff;
+ return (guess);
+ }
#undef vh
#undef ph
#undef diff
u_scan = u_start;
carry = 0;
while (v_scan < v_end)
+ {
+ bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
+ if (sum < BIGNUM_RADIX)
{
- bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
- if (sum < BIGNUM_RADIX)
- {
- (*u_scan++) = sum;
- carry = 0;
- }
- else
- {
- (*u_scan++) = (sum - BIGNUM_RADIX);
- carry = 1;
- }
+ (*u_scan++) = sum;
+ carry = 0;
}
- if (carry == 1)
+ else
{
- bignum_digit_type sum = ((*u_scan) + carry);
- (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
+ (*u_scan++) = (sum - BIGNUM_RADIX);
+ carry = 1;
}
+ }
+ if (carry == 1)
+ {
+ bignum_digit_type sum = ((*u_scan) + carry);
+ (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
+ }
return (guess - 1);
}
-
/* allocates memory */
-void factorvm::bignum_divide_unsigned_medium_denominator(bignum * numerator,bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
+void factor_vm::bignum_divide_unsigned_medium_denominator(bignum * numerator,bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator,this);
+ GC_BIGNUM(numerator);
bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
bignum_length_type length_q;
bignum * q = NULL;
- GC_BIGNUM(q,this);
+ GC_BIGNUM(q);
int shift = 0;
/* Because `bignum_digit_divide' requires a normalized denominator. */
while (denominator < (BIGNUM_RADIX / 2))
- {
- denominator <<= 1;
- shift += 1;
- }
+ {
+ denominator <<= 1;
+ shift += 1;
+ }
if (shift == 0)
- {
- length_q = length_n;
+ {
+ length_q = length_n;
- q = (allot_bignum (length_q, q_negative_p));
- bignum_destructive_copy (numerator, q);
- }
+ q = (allot_bignum (length_q, q_negative_p));
+ bignum_destructive_copy (numerator, q);
+ }
else
- {
- length_q = (length_n + 1);
+ {
+ length_q = (length_n + 1);
- q = (allot_bignum (length_q, q_negative_p));
- bignum_destructive_normalization (numerator, q, shift);
- }
+ q = (allot_bignum (length_q, q_negative_p));
+ bignum_destructive_normalization (numerator, q, shift);
+ }
{
bignum_digit_type r = 0;
bignum_digit_type * start = (BIGNUM_START_PTR (q));
bignum_digit_type qj;
while (start < scan)
- {
- r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
- (*scan) = qj;
- }
+ {
+ r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
+ (*scan) = qj;
+ }
q = bignum_trim (q);
if (remainder != ((bignum * *) 0))
- {
- if (shift != 0)
- r >>= shift;
+ {
+ if (shift != 0)
+ r >>= shift;
- (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- }
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ }
if (quotient != ((bignum * *) 0))
(*quotient) = q;
return;
}
-
-void factorvm::bignum_destructive_normalization(bignum * source, bignum * target, int shift_left)
+void factor_vm::bignum_destructive_normalization(bignum * source, bignum * target, int shift_left)
{
bignum_digit_type digit;
bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
bignum_digit_type mask = (((cell)1 << shift_right) - 1);
while (scan_source < end_source)
- {
- digit = (*scan_source++);
- (*scan_target++) = (((digit & mask) << shift_left) | carry);
- carry = (digit >> shift_right);
- }
+ {
+ digit = (*scan_source++);
+ (*scan_target++) = (((digit & mask) << shift_left) | carry);
+ carry = (digit >> shift_right);
+ }
if (scan_target < end_target)
(*scan_target) = carry;
else
return;
}
-
-void factorvm::bignum_destructive_unnormalization(bignum * bignum, int shift_right)
+void factor_vm::bignum_destructive_unnormalization(bignum * bignum, int shift_right)
{
bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
bignum_digit_type mask = (((fixnum)1 << shift_right) - 1);
while (start < scan)
- {
- digit = (*--scan);
- (*scan) = ((digit >> shift_right) | carry);
- carry = ((digit & mask) << shift_left);
- }
+ {
+ digit = (*--scan);
+ (*scan) = ((digit >> shift_right) | carry);
+ carry = ((digit & mask) << shift_left);
+ }
BIGNUM_ASSERT (carry == 0);
return;
}
-
/* This is a reduced version of the division algorithm, applied to the
case of dividing two bignum digits by one bignum digit. It is
assumed that the numerator, denominator are normalized. */
-#define BDD_STEP(qn, j) \
-{ \
- uj = (u[j]); \
- if (uj != v1) \
- { \
- uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
- guess = (uj_uj1 / v1); \
- comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
- } \
- else \
- { \
- guess = (BIGNUM_RADIX_ROOT - 1); \
- comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
- } \
- while ((guess * v2) > comparand) \
- { \
- guess -= 1; \
- comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
- if (comparand >= BIGNUM_RADIX) \
- break; \
- } \
+#define BDD_STEP(qn, j) \
+{ \
+ uj = (u[j]); \
+ if (uj != v1) \
+ { \
+ uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
+ guess = (uj_uj1 / v1); \
+ comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
+ } \
+ else \
+ { \
+ guess = (BIGNUM_RADIX_ROOT - 1); \
+ comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
+ } \
+ while ((guess * v2) > comparand) \
+ { \
+ guess -= 1; \
+ comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
+ if (comparand >= BIGNUM_RADIX) \
+ break; \
+ } \
qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
}
-bignum_digit_type factorvm::bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul, bignum_digit_type v, bignum_digit_type * q) /* return value */
+bignum_digit_type factor_vm::bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul, bignum_digit_type v, bignum_digit_type * q) /* return value */
{
bignum_digit_type guess;
bignum_digit_type comparand;
bignum_digit_type q2;
bignum_digit_type u [4];
if (uh == 0)
+ {
+ if (ul < v)
{
- if (ul < v)
- {
- (*q) = 0;
- return (ul);
- }
- else if (ul == v)
- {
- (*q) = 1;
- return (0);
- }
+ (*q) = 0;
+ return (ul);
+ }
+ else if (ul == v)
+ {
+ (*q) = 1;
+ return (0);
}
+ }
(u[0]) = (HD_HIGH (uh));
(u[1]) = (HD_LOW (uh));
(u[2]) = (HD_HIGH (ul));
return (HD_CONS ((u[2]), (u[3])));
}
-
#undef BDD_STEP
-#define BDDS_MULSUB(vn, un, carry_in) \
-{ \
- product = ((vn * guess) + carry_in); \
+#define BDDS_MULSUB(vn, un, carry_in) \
+{ \
+ product = ((vn * guess) + carry_in); \
diff = (un - (HD_LOW (product))); \
- if (diff < 0) \
- { \
+ if (diff < 0) \
+ { \
un = (diff + BIGNUM_RADIX_ROOT); \
carry = ((HD_HIGH (product)) + 1); \
- } \
- else \
- { \
- un = diff; \
+ } \
+ else \
+ { \
+ un = diff; \
carry = (HD_HIGH (product)); \
- } \
+ } \
}
#define BDDS_ADD(vn, un, carry_in) \
-{ \
- sum = (vn + un + carry_in); \
+{ \
+ sum = (vn + un + carry_in); \
if (sum < BIGNUM_RADIX_ROOT) \
- { \
- un = sum; \
- carry = 0; \
- } \
- else \
- { \
+ { \
+ un = sum; \
+ carry = 0; \
+ } \
+ else \
+ { \
un = (sum - BIGNUM_RADIX_ROOT); \
- carry = 1; \
- } \
+ carry = 1; \
+ } \
}
-bignum_digit_type factorvm::bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, bignum_digit_type guess, bignum_digit_type * u)
+bignum_digit_type factor_vm::bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, bignum_digit_type guess, bignum_digit_type * u)
{
{
bignum_digit_type product;
if (diff < 0)
(u[0]) = (diff + BIGNUM_RADIX);
else
- {
- (u[0]) = diff;
- return (guess);
- }
+ {
+ (u[0]) = diff;
+ return (guess);
+ }
}
{
bignum_digit_type sum;
return (guess - 1);
}
-
#undef BDDS_MULSUB
#undef BDDS_ADD
/* allocates memory */
-void factorvm::bignum_divide_unsigned_small_denominator(bignum * numerator, bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
+void factor_vm::bignum_divide_unsigned_small_denominator(bignum * numerator, bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator,this);
+ GC_BIGNUM(numerator);
bignum * q = (bignum_new_sign (numerator, q_negative_p));
- GC_BIGNUM(q,this);
+ GC_BIGNUM(q);
bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
return;
}
-
/* Given (denominator > 1), it is fairly easy to show that
(quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see
that all digits are < BIGNUM_RADIX. */
-bignum_digit_type factorvm::bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator)
+bignum_digit_type factor_vm::bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator)
{
bignum_digit_type numerator;
bignum_digit_type remainder = 0;
bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
while (start < scan)
- {
- two_digits = (*--scan);
- numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
- quotient_high = (numerator / denominator);
- numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
- (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
- remainder = (numerator % denominator);
- }
+ {
+ two_digits = (*--scan);
+ numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
+ quotient_high = (numerator / denominator);
+ numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
+ (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
+ remainder = (numerator % denominator);
+ }
return (remainder);
#undef quotient_high
}
-
/* allocates memory */
-bignum * factorvm::bignum_remainder_unsigned_small_denominator(bignum * n, bignum_digit_type d, int negative_p)
+bignum * factor_vm::bignum_remainder_unsigned_small_denominator(bignum * n, bignum_digit_type d, int negative_p)
{
bignum_digit_type two_digits;
bignum_digit_type * start = (BIGNUM_START_PTR (n));
bignum_digit_type r = 0;
BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
while (start < scan)
- {
- two_digits = (*--scan);
- r =
- ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
- (HD_LOW (two_digits))))
- % d);
- }
+ {
+ two_digits = (*--scan);
+ r =
+ ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
+ (HD_LOW (two_digits))))
+ % d);
+ }
return (bignum_digit_to_bignum (r, negative_p));
}
-
/* allocates memory */
-bignum *factorvm::bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
+bignum *factor_vm::bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
{
if (digit == 0)
return (BIGNUM_ZERO ());
else
- {
- bignum * result = (allot_bignum (1, negative_p));
- (BIGNUM_REF (result, 0)) = digit;
- return (result);
- }
+ {
+ bignum * result = (allot_bignum (1, negative_p));
+ (BIGNUM_REF (result, 0)) = digit;
+ return (result);
+ }
}
-
/* allocates memory */
-bignum *factorvm::allot_bignum(bignum_length_type length, int negative_p)
+bignum *factor_vm::allot_bignum(bignum_length_type length, int negative_p)
{
BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
bignum * result = allot_array_internal<bignum>(length + 1);
return (result);
}
-
/* allocates memory */
-bignum * factorvm::allot_bignum_zeroed(bignum_length_type length, int negative_p)
+bignum * factor_vm::allot_bignum_zeroed(bignum_length_type length, int negative_p)
{
bignum * result = allot_bignum(length,negative_p);
bignum_digit_type * scan = (BIGNUM_START_PTR (result));
return (result);
}
-
#define BIGNUM_REDUCE_LENGTH(source, length) \
source = reallot_array(source,length + 1)
/* allocates memory */
-bignum *factorvm::bignum_shorten_length(bignum * bignum, bignum_length_type length)
+bignum *factor_vm::bignum_shorten_length(bignum * bignum, bignum_length_type length)
{
bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
if (length < current_length)
- {
- BIGNUM_REDUCE_LENGTH (bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
+ {
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
return (bignum);
}
-
/* allocates memory */
-bignum *factorvm::bignum_trim(bignum * bignum)
+bignum *factor_vm::bignum_trim(bignum * bignum)
{
bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
;
scan += 1;
if (scan < end)
- {
- bignum_length_type length = (scan - start);
- BIGNUM_REDUCE_LENGTH (bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
+ {
+ bignum_length_type length = (scan - start);
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
return (bignum);
}
-
/* Copying */
/* allocates memory */
-bignum *factorvm::bignum_new_sign(bignum * x, int negative_p)
+bignum *factor_vm::bignum_new_sign(bignum * x, int negative_p)
{
- GC_BIGNUM(x,this);
+ GC_BIGNUM(x);
bignum * result = (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
bignum_destructive_copy (x, result);
return (result);
}
-
/* allocates memory */
-bignum *factorvm::bignum_maybe_new_sign(bignum * x, int negative_p)
+bignum *factor_vm::bignum_maybe_new_sign(bignum * x, int negative_p)
{
if ((BIGNUM_NEGATIVE_P (x)) ? negative_p : (! negative_p))
return (x);
else
- {
- bignum * result =
- (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
- bignum_destructive_copy (x, result);
- return (result);
- }
+ {
+ bignum * result =
+ (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
+ bignum_destructive_copy (x, result);
+ return (result);
+ }
}
-
-void factorvm::bignum_destructive_copy(bignum * source, bignum * target)
+void factor_vm::bignum_destructive_copy(bignum * source, bignum * target)
{
bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
bignum_digit_type * end_source =
return;
}
-
/*
* Added bitwise operations (and oddp).
*/
/* allocates memory */
-bignum *factorvm::bignum_bitwise_not(bignum * x)
+bignum *factor_vm::bignum_bitwise_not(bignum * x)
{
return bignum_subtract(BIGNUM_ONE(1), x);
}
-
/* allocates memory */
-bignum *factorvm::bignum_arithmetic_shift(bignum * arg1, fixnum n)
+bignum *factor_vm::bignum_arithmetic_shift(bignum * arg1, fixnum n)
{
if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
return bignum_magnitude_ash(arg1, n);
}
-
#define AND_OP 0
#define IOR_OP 1
#define XOR_OP 2
/* allocates memory */
-bignum *factorvm::bignum_bitwise_and(bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_bitwise_and(bignum * arg1, bignum * arg2)
{
return(
(BIGNUM_NEGATIVE_P (arg1))
? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(AND_OP, arg2, arg1)
+ ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(AND_OP, arg2, arg1)
: (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
+ ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
);
}
-
/* allocates memory */
-bignum *factorvm::bignum_bitwise_ior(bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_bitwise_ior(bignum * arg1, bignum * arg2)
{
return(
(BIGNUM_NEGATIVE_P (arg1))
? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1)
+ ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1)
: (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
+ ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
);
}
-
/* allocates memory */
-bignum *factorvm::bignum_bitwise_xor(bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_bitwise_xor(bignum * arg1, bignum * arg2)
{
return(
(BIGNUM_NEGATIVE_P (arg1))
? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1)
+ ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1)
: (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2)
+ ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2)
);
}
-
/* allocates memory */
/* ash for the magnitude */
/* assume arg1 is a big number, n is a long */
-bignum *factorvm::bignum_magnitude_ash(bignum * arg1, fixnum n)
+bignum *factor_vm::bignum_magnitude_ash(bignum * arg1, fixnum n)
{
- GC_BIGNUM(arg1,this);
+ GC_BIGNUM(arg1);
bignum * result = NULL;
bignum_digit_type *scan1;
scanr = BIGNUM_START_PTR (result) + digit_offset;
scan1 = BIGNUM_START_PTR (arg1);
end = scan1 + BIGNUM_LENGTH (arg1);
-
+
while (scan1 < end) {
*scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;
*scanr = *scanr & BIGNUM_DIGIT_MASK;
else if (n < 0) {
digit_offset = -n / BIGNUM_DIGIT_LENGTH;
bit_offset = -n % BIGNUM_DIGIT_LENGTH;
-
+
result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
BIGNUM_NEGATIVE_P(arg1));
-
+
scanr = BIGNUM_START_PTR (result);
scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
end = scanr + BIGNUM_LENGTH (result) - 1;
-
+
while (scanr < end) {
*scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
*scanr = (*scanr |
return (bignum_trim (result));
}
-
/* allocates memory */
-bignum *factorvm::bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
bignum * result;
bignum_length_type max_length;
return bignum_trim(result);
}
-
/* allocates memory */
-bignum *factorvm::bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
bignum * result;
bignum_length_type max_length;
if (digit2 < BIGNUM_RADIX)
carry2 = 0;
else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
-
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
+
*scanr++ = (op == AND_OP) ? digit1 & digit2 :
(op == IOR_OP) ? digit1 | digit2 :
digit1 ^ digit2;
return bignum_trim(result);
}
-
/* allocates memory */
-bignum *factorvm::bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
bignum * result;
bignum_length_type max_length;
if (digit1 < BIGNUM_RADIX)
carry1 = 0;
else
- {
- digit1 = (digit1 - BIGNUM_RADIX);
- carry1 = 1;
- }
-
+ {
+ digit1 = (digit1 - BIGNUM_RADIX);
+ carry1 = 1;
+ }
+
if (digit2 < BIGNUM_RADIX)
carry2 = 0;
else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
-
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
+
*scanr++ = (op == AND_OP) ? digit1 & digit2 :
(op == IOR_OP) ? digit1 | digit2 :
digit1 ^ digit2;
return bignum_trim(result);
}
-
-void factorvm::bignum_negate_magnitude(bignum * arg)
+void factor_vm::bignum_negate_magnitude(bignum * arg)
{
bignum_digit_type *scan;
bignum_digit_type *end;
if (digit < BIGNUM_RADIX)
carry = 0;
else
- {
- digit = (digit - BIGNUM_RADIX);
- carry = 1;
- }
-
+ {
+ digit = (digit - BIGNUM_RADIX);
+ carry = 1;
+ }
+
*scan++ = digit;
}
}
-
/* Allocates memory */
-bignum *factorvm::bignum_integer_length(bignum * x)
+bignum *factor_vm::bignum_integer_length(bignum * x)
{
- GC_BIGNUM(x,this);
+ GC_BIGNUM(x);
bignum_length_type index = ((BIGNUM_LENGTH (x)) - 1);
bignum_digit_type digit = (BIGNUM_REF (x, index));
(BIGNUM_REF (result, 1)) = 0;
bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
while (digit > 1)
- {
- bignum_destructive_add (result, ((bignum_digit_type) 1));
- digit >>= 1;
- }
+ {
+ bignum_destructive_add (result, ((bignum_digit_type) 1));
+ digit >>= 1;
+ }
return (bignum_trim (result));
}
-
/* Allocates memory */
-int factorvm::bignum_logbitp(int shift, bignum * arg)
+int factor_vm::bignum_logbitp(int shift, bignum * arg)
{
return((BIGNUM_NEGATIVE_P (arg))
? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg))
: bignum_unsigned_logbitp (shift,arg));
}
-
-int factorvm::bignum_unsigned_logbitp(int shift, bignum * bignum)
+int factor_vm::bignum_unsigned_logbitp(int shift, bignum * bignum)
{
bignum_length_type len = (BIGNUM_LENGTH (bignum));
int index = shift / BIGNUM_DIGIT_LENGTH;
return (digit & mask) ? 1 : 0;
}
-
/* Allocates memory */
-bignum *factorvm::digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factorvm*), unsigned int radix, int negative_p)
+bignum *factor_vm::digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factor_vm*), unsigned int radix, int negative_p)
{
BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
if (n_digits == 0)
return (BIGNUM_ZERO ());
if (n_digits == 1)
- {
- fixnum digit = ((fixnum) ((*producer) (0,this)));
- return (fixnum_to_bignum (negative_p ? (- digit) : digit));
- }
+ {
+ fixnum digit = ((fixnum) ((*producer) (0,this)));
+ return (fixnum_to_bignum (negative_p ? (- digit) : digit));
+ }
{
bignum_length_type length;
{
unsigned int radix_copy = radix;
unsigned int log_radix = 0;
while (radix_copy > 0)
- {
- radix_copy >>= 1;
- log_radix += 1;
- }
+ {
+ radix_copy >>= 1;
+ log_radix += 1;
+ }
/* This length will be at least as large as needed. */
length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
}
{
bignum * result = (allot_bignum_zeroed (length, negative_p));
while ((n_digits--) > 0)
- {
- bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
- bignum_destructive_add
- (result, ((bignum_digit_type) ((*producer) (n_digits,this))));
- }
+ {
+ bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
+ bignum_destructive_add
+ (result, ((bignum_digit_type) ((*producer) (n_digits,this))));
+ }
return (bignum_trim (result));
}
}
}
-
}
namespace factor
{
-/* :tabSize=2:indentSize=2:noTabs=true:
+/*
Copyright (C) 1989-1992 Massachusetts Institute of Technology
Portions copyright (C) 2004-2009 Slava Pestov
bignum_comparison_greater = 1
};
-struct factorvm;
-bignum * digit_stream_to_bignum(unsigned int n_digits,
- unsigned int (*producer)(unsigned int,factorvm*),
- unsigned int radix,
- int negative_p);
+struct factor_vm;
+bignum * digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int,factor_vm*), unsigned int radix, int negative_p);
}
/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
#define BIGNUM_EXCEPTION abort
-
#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2)
#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2)
#define BIGNUM_RADIX (bignum_digit_type)(((cell) 1) << BIGNUM_DIGIT_LENGTH)
namespace factor
{
-void factorvm::box_boolean(bool value)
+void factor_vm::box_boolean(bool value)
{
dpush(value ? T : F);
}
-VM_C_API void box_boolean(bool value, factorvm *myvm)
+VM_C_API void box_boolean(bool value, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_boolean(value);
}
-bool factorvm::to_boolean(cell value)
+bool factor_vm::to_boolean(cell value)
{
return value != F;
}
-VM_C_API bool to_boolean(cell value, factorvm *myvm)
+VM_C_API bool to_boolean(cell value, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_boolean(value);
namespace factor
{
-
-VM_C_API void box_boolean(bool value, factorvm *vm);
-VM_C_API bool to_boolean(cell value, factorvm *vm);
+VM_C_API void box_boolean(bool value, factor_vm *vm);
+VM_C_API bool to_boolean(cell value, factor_vm *vm);
}
namespace factor
{
-byte_array *factorvm::allot_byte_array(cell size)
+byte_array *factor_vm::allot_byte_array(cell size)
{
byte_array *array = allot_array_internal<byte_array>(size);
memset(array + 1,0,size);
return array;
}
-
-inline void factorvm::vmprim_byte_array()
+inline void factor_vm::primitive_byte_array()
{
cell size = unbox_array_size();
dpush(tag<byte_array>(allot_byte_array(size)));
PRIMITIVE(byte_array)
{
- PRIMITIVE_GETVM()->vmprim_byte_array();
+ PRIMITIVE_GETVM()->primitive_byte_array();
}
-inline void factorvm::vmprim_uninitialized_byte_array()
+inline void factor_vm::primitive_uninitialized_byte_array()
{
cell size = unbox_array_size();
dpush(tag<byte_array>(allot_array_internal<byte_array>(size)));
PRIMITIVE(uninitialized_byte_array)
{
- PRIMITIVE_GETVM()->vmprim_uninitialized_byte_array();
+ PRIMITIVE_GETVM()->primitive_uninitialized_byte_array();
}
-inline void factorvm::vmprim_resize_byte_array()
+inline void factor_vm::primitive_resize_byte_array()
{
byte_array *array = untag_check<byte_array>(dpop());
cell capacity = unbox_array_size();
PRIMITIVE(resize_byte_array)
{
- PRIMITIVE_GETVM()->vmprim_resize_byte_array();
+ PRIMITIVE_GETVM()->primitive_resize_byte_array();
}
void growable_byte_array::append_bytes(void *elts, cell len)
{
cell new_size = count + len;
- factorvm *myvm = elements.myvm;
+ factor_vm *parent_vm = elements.parent_vm;
if(new_size >= array_capacity(elements.untagged()))
- elements = myvm->reallot_array(elements.untagged(),new_size * 2);
+ elements = parent_vm->reallot_array(elements.untagged(),new_size * 2);
memcpy(&elements->data<u8>()[count],elts,len);
void growable_byte_array::append_byte_array(cell byte_array_)
{
- gc_root<byte_array> byte_array(byte_array_,elements.myvm);
+ gc_root<byte_array> byte_array(byte_array_,elements.parent_vm);
cell len = array_capacity(byte_array.untagged());
cell new_size = count + len;
- factorvm *myvm = elements.myvm;
+ factor_vm *parent_vm = elements.parent_vm;
if(new_size >= array_capacity(elements.untagged()))
- elements = myvm->reallot_array(elements.untagged(),new_size * 2);
+ elements = parent_vm->reallot_array(elements.untagged(),new_size * 2);
memcpy(&elements->data<u8>()[count],byte_array->data<u8>(),len);
void growable_byte_array::trim()
{
- factorvm *myvm = elements.myvm;
- elements = myvm->reallot_array(elements.untagged(),count);
+ factor_vm *parent_vm = elements.parent_vm;
+ elements = parent_vm->reallot_array(elements.untagged(),count);
}
}
PRIMITIVE(uninitialized_byte_array);
PRIMITIVE(resize_byte_array);
-
}
namespace factor
{
-void factorvm::check_frame(stack_frame *frame)
+void factor_vm::check_frame(stack_frame *frame)
{
#ifdef FACTOR_DEBUG
check_code_pointer((cell)frame->xt);
#endif
}
-callstack *factorvm::allot_callstack(cell size)
+callstack *factor_vm::allot_callstack(cell size)
{
callstack *stack = allot<callstack>(callstack_size(size));
stack->length = tag_fixnum(size);
return stack;
}
-stack_frame *factorvm::fix_callstack_top(stack_frame *top, stack_frame *bottom)
+stack_frame *factor_vm::fix_callstack_top(stack_frame *top, stack_frame *bottom)
{
stack_frame *frame = bottom - 1;
will have popped a necessary frame... however this word is only
called by continuation implementation, and user code shouldn't
be calling it at all, so we leave it as it is for now. */
-stack_frame *factorvm::capture_start()
+stack_frame *factor_vm::capture_start()
{
stack_frame *frame = stack_chain->callstack_bottom - 1;
while(frame >= stack_chain->callstack_top
return frame + 1;
}
-inline void factorvm::vmprim_callstack()
+inline void factor_vm::primitive_callstack()
{
stack_frame *top = capture_start();
stack_frame *bottom = stack_chain->callstack_bottom;
PRIMITIVE(callstack)
{
- PRIMITIVE_GETVM()->vmprim_callstack();
+ PRIMITIVE_GETVM()->primitive_callstack();
}
-inline void factorvm::vmprim_set_callstack()
+inline void factor_vm::primitive_set_callstack()
{
callstack *stack = untag_check<callstack>(dpop());
PRIMITIVE(set_callstack)
{
- PRIMITIVE_GETVM()->vmprim_set_callstack();
+ PRIMITIVE_GETVM()->primitive_set_callstack();
}
-code_block *factorvm::frame_code(stack_frame *frame)
+code_block *factor_vm::frame_code(stack_frame *frame)
{
check_frame(frame);
return (code_block *)frame->xt - 1;
}
-
-cell factorvm::frame_type(stack_frame *frame)
+cell factor_vm::frame_type(stack_frame *frame)
{
return frame_code(frame)->type;
}
-cell factorvm::frame_executing(stack_frame *frame)
+cell factor_vm::frame_executing(stack_frame *frame)
{
code_block *compiled = frame_code(frame);
if(compiled->literals == F || !stack_traces_p())
}
}
-stack_frame *factorvm::frame_successor(stack_frame *frame)
+stack_frame *factor_vm::frame_successor(stack_frame *frame)
{
check_frame(frame);
return (stack_frame *)((cell)frame - frame->size);
}
/* Allocates memory */
-cell factorvm::frame_scan(stack_frame *frame)
+cell factor_vm::frame_scan(stack_frame *frame)
{
switch(frame_type(frame))
{
struct stack_frame_accumulator {
growable_array frames;
- stack_frame_accumulator(factorvm *vm) : frames(vm) {}
+ stack_frame_accumulator(factor_vm *vm) : frames(vm) {}
- void operator()(stack_frame *frame, factorvm *myvm)
+ void operator()(stack_frame *frame, factor_vm *myvm)
{
gc_root<object> executing(myvm->frame_executing(frame),myvm);
gc_root<object> scan(myvm->frame_scan(frame),myvm);
}
-inline void factorvm::vmprim_callstack_to_array()
+inline void factor_vm::primitive_callstack_to_array()
{
gc_root<callstack> callstack(dpop(),this);
PRIMITIVE(callstack_to_array)
{
- PRIMITIVE_GETVM()->vmprim_callstack_to_array();
+ PRIMITIVE_GETVM()->primitive_callstack_to_array();
}
-stack_frame *factorvm::innermost_stack_frame(callstack *stack)
+stack_frame *factor_vm::innermost_stack_frame(callstack *stack)
{
stack_frame *top = stack->top();
stack_frame *bottom = stack->bottom();
return frame;
}
-stack_frame *factorvm::innermost_stack_frame_quot(callstack *callstack)
+stack_frame *factor_vm::innermost_stack_frame_quot(callstack *callstack)
{
stack_frame *inner = innermost_stack_frame(callstack);
tagged<quotation>(frame_executing(inner)).untag_check(this);
/* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */
-inline void factorvm::vmprim_innermost_stack_frame_executing()
+inline void factor_vm::primitive_innermost_stack_frame_executing()
{
dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
}
PRIMITIVE(innermost_stack_frame_executing)
{
- PRIMITIVE_GETVM()->vmprim_innermost_stack_frame_executing();
+ PRIMITIVE_GETVM()->primitive_innermost_stack_frame_executing();
}
-inline void factorvm::vmprim_innermost_stack_frame_scan()
+inline void factor_vm::primitive_innermost_stack_frame_scan()
{
dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
}
PRIMITIVE(innermost_stack_frame_scan)
{
- PRIMITIVE_GETVM()->vmprim_innermost_stack_frame_scan();
+ PRIMITIVE_GETVM()->primitive_innermost_stack_frame_scan();
}
-inline void factorvm::vmprim_set_innermost_stack_frame_quot()
+inline void factor_vm::primitive_set_innermost_stack_frame_quot()
{
gc_root<callstack> callstack(dpop(),this);
gc_root<quotation> quot(dpop(),this);
PRIMITIVE(set_innermost_stack_frame_quot)
{
- PRIMITIVE_GETVM()->vmprim_set_innermost_stack_frame_quot();
+ PRIMITIVE_GETVM()->primitive_set_innermost_stack_frame_quot();
}
/* called before entry into Factor code. */
-void factorvm::save_callstack_bottom(stack_frame *callstack_bottom)
+void factor_vm::save_callstack_bottom(stack_frame *callstack_bottom)
{
stack_chain->callstack_bottom = callstack_bottom;
}
-VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factorvm *myvm)
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->save_callstack_bottom(callstack_bottom);
PRIMITIVE(innermost_stack_frame_scan);
PRIMITIVE(set_innermost_stack_frame_quot);
-VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom,factorvm *vm);
-
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom,factor_vm *vm);
}
namespace factor
{
-relocation_type factorvm::relocation_type_of(relocation_entry r)
+relocation_type factor_vm::relocation_type_of(relocation_entry r)
{
return (relocation_type)((r & 0xf0000000) >> 28);
}
-
-relocation_class factorvm::relocation_class_of(relocation_entry r)
+relocation_class factor_vm::relocation_class_of(relocation_entry r)
{
return (relocation_class)((r & 0x0f000000) >> 24);
}
-
-cell factorvm::relocation_offset_of(relocation_entry r)
+cell factor_vm::relocation_offset_of(relocation_entry r)
{
- return (r & 0x00ffffff);
+ return (r & 0x00ffffff);
}
-
-void factorvm::flush_icache_for(code_block *block)
+void factor_vm::flush_icache_for(code_block *block)
{
flush_icache((cell)block,block->size);
}
-
-int factorvm::number_of_parameters(relocation_type type)
+int factor_vm::number_of_parameters(relocation_type type)
{
switch(type)
{
}
}
-
-void *factorvm::object_xt(cell obj)
+void *factor_vm::object_xt(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-
-void *factorvm::xt_pic(word *w, cell tagged_quot)
+void *factor_vm::xt_pic(word *w, cell tagged_quot)
{
if(tagged_quot == F || max_pic_size == 0)
return w->xt;
}
}
-
-void *factorvm::word_xt_pic(word *w)
+void *factor_vm::word_xt_pic(word *w)
{
return xt_pic(w,w->pic_def);
}
-
-void *factorvm::word_xt_pic_tail(word *w)
+void *factor_vm::word_xt_pic_tail(word *w)
{
return xt_pic(w,w->pic_tail_def);
}
-
/* References to undefined symbols are patched up to call this function on
image load */
-void factorvm::undefined_symbol()
+void factor_vm::undefined_symbol()
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
}
-void undefined_symbol(factorvm *myvm)
+void undefined_symbol(factor_vm *myvm)
{
return myvm->undefined_symbol();
}
/* Look up an external library symbol referenced by a compiled code block */
-void *factorvm::get_rel_symbol(array *literals, cell index)
+void *factor_vm::get_rel_symbol(array *literals, cell index)
{
cell symbol = array_nth(literals,index);
cell library = array_nth(literals,index + 1);
}
}
-
-cell factorvm::compute_relocation(relocation_entry rel, cell index, code_block *compiled)
+cell factor_vm::compute_relocation(relocation_entry rel, cell index, code_block *compiled)
{
array *literals = untag<array>(compiled->literals);
cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
#undef ARG
}
-
-void factorvm::iterate_relocations(code_block *compiled, relocation_iterator iter)
+void factor_vm::iterate_relocations(code_block *compiled, relocation_iterator iter)
{
if(compiled->relocation != F)
{
}
}
-
/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
-void factorvm::store_address_2_2(cell *ptr, cell value)
+void factor_vm::store_address_2_2(cell *ptr, cell value)
{
ptr[-1] = ((ptr[-1] & ~0xffff) | ((value >> 16) & 0xffff));
ptr[ 0] = ((ptr[ 0] & ~0xffff) | (value & 0xffff));
}
-
/* Store a value into a bitfield of a PowerPC instruction */
-void factorvm::store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift)
+void factor_vm::store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift)
{
/* This is unaccurate but good enough */
fixnum test = (fixnum)mask >> 1;
*ptr = ((*ptr & ~mask) | ((value >> shift) & mask));
}
-
/* Perform a fixup on a code block */
-void factorvm::store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
+void factor_vm::store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
{
fixnum relative_value = absolute_value - offset;
}
}
-
-void factorvm::update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
+void factor_vm::update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
{
if(relocation_type_of(rel) == RT_IMMEDIATE)
{
}
}
-void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled, factor_vm *myvm)
{
return myvm->update_literal_references_step(rel,index,compiled);
}
/* Update pointers to literals from compiled code. */
-void factorvm::update_literal_references(code_block *compiled)
+void factor_vm::update_literal_references(code_block *compiled)
{
if(!compiled->needs_fixup)
{
}
}
-
/* Copy all literals referenced from a code block to newspace. Only for
aging and nursery collections */
-void factorvm::copy_literal_references(code_block *compiled)
+void factor_vm::copy_literal_references(code_block *compiled)
{
if(collecting_gen >= compiled->last_scan)
{
}
}
-void copy_literal_references(code_block *compiled, factorvm *myvm)
+void copy_literal_references(code_block *compiled, factor_vm *myvm)
{
return myvm->copy_literal_references(compiled);
}
/* Compute an address to store at a relocation */
-void factorvm::relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
+void factor_vm::relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
{
#ifdef FACTOR_DEBUG
tagged<array>(compiled->literals).untag_check(this);
compute_relocation(rel,index,compiled));
}
-void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled, factor_vm *myvm)
{
return myvm->relocate_code_block_step(rel,index,compiled);
}
-void factorvm::update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
+void factor_vm::update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
{
relocation_type type = relocation_type_of(rel);
if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
relocate_code_block_step(rel,index,compiled);
}
-void update_word_references_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+void update_word_references_step(relocation_entry rel, cell index, code_block *compiled, factor_vm *myvm)
{
return myvm->update_word_references_step(rel,index,compiled);
}
dlsyms, and words. For all other words in the code heap, we only need
to update references to other words, without worrying about literals
or dlsyms. */
-void factorvm::update_word_references(code_block *compiled)
+void factor_vm::update_word_references(code_block *compiled)
{
if(compiled->needs_fixup)
relocate_code_block(compiled);
}
}
-void update_word_references(code_block *compiled, factorvm *myvm)
+void update_word_references(code_block *compiled, factor_vm *myvm)
{
return myvm->update_word_references(compiled);
}
-void factorvm::update_literal_and_word_references(code_block *compiled)
+void factor_vm::update_literal_and_word_references(code_block *compiled)
{
update_literal_references(compiled);
update_word_references(compiled);
}
-void update_literal_and_word_references(code_block *compiled, factorvm *myvm)
+void update_literal_and_word_references(code_block *compiled, factor_vm *myvm)
{
return myvm->update_literal_and_word_references(compiled);
}
-void factorvm::check_code_address(cell address)
+void factor_vm::check_code_address(cell address)
{
#ifdef FACTOR_DEBUG
assert(address >= code.seg->start && address < code.seg->end);
#endif
}
-
/* Update references to words. This is done after a new code block
is added to the heap. */
/* Mark all literals referenced from a word XT. Only for tenured
collections */
-void factorvm::mark_code_block(code_block *compiled)
+void factor_vm::mark_code_block(code_block *compiled)
{
check_code_address((cell)compiled);
copy_handle(&compiled->relocation);
}
-
-void factorvm::mark_stack_frame_step(stack_frame *frame)
+void factor_vm::mark_stack_frame_step(stack_frame *frame)
{
mark_code_block(frame_code(frame));
}
-void mark_stack_frame_step(stack_frame *frame, factorvm *myvm)
+void mark_stack_frame_step(stack_frame *frame, factor_vm *myvm)
{
return myvm->mark_stack_frame_step(frame);
}
/* Mark code blocks executing in currently active stack frames. */
-void factorvm::mark_active_blocks(context *stacks)
+void factor_vm::mark_active_blocks(context *stacks)
{
if(collecting_gen == data->tenured())
{
}
}
-
-void factorvm::mark_object_code_block(object *object)
+void factor_vm::mark_object_code_block(object *object)
{
switch(object->h.hi_tag())
{
}
}
-
/* Perform all fixups on a code block */
-void factorvm::relocate_code_block(code_block *compiled)
+void factor_vm::relocate_code_block(code_block *compiled)
{
compiled->last_scan = data->nursery();
compiled->needs_fixup = false;
flush_icache_for(compiled);
}
-void relocate_code_block(code_block *compiled, factorvm *myvm)
+void relocate_code_block(code_block *compiled, factor_vm *myvm)
{
return myvm->relocate_code_block(compiled);
}
/* Fixup labels. This is done at compile time, not image load time */
-void factorvm::fixup_labels(array *labels, code_block *compiled)
+void factor_vm::fixup_labels(array *labels, code_block *compiled)
{
cell i;
cell size = array_capacity(labels);
}
}
-
/* Might GC */
-code_block *factorvm::allot_code_block(cell size)
+code_block *factor_vm::allot_code_block(cell size)
{
heap_block *block = heap_allot(&code,size + sizeof(code_block));
return (code_block *)block;
}
-
/* Might GC */
-code_block *factorvm::add_code_block(cell type,cell code_,cell labels_,cell relocation_,cell literals_)
+code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell relocation_, cell literals_)
{
gc_root<byte_array> code(code_,this);
gc_root<object> labels(labels_,this);
return compiled;
}
-
}
RT_UNTAGGED,
/* address of megamorphic_cache_hits var */
RT_MEGAMORPHIC_CACHE_HITS,
- /* address of vm object*/
+ /* address of vm object */
RT_VM,
};
/* code relocation table consists of a table of entries for each fixup */
typedef u32 relocation_entry;
-struct factorvm;
+struct factor_vm;
-typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled, factorvm *vm);
+typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled, factor_vm *vm);
// callback functions
-void relocate_code_block(code_block *compiled, factorvm *myvm);
-void copy_literal_references(code_block *compiled, factorvm *myvm);
-void update_word_references(code_block *compiled, factorvm *myvm);
-void update_literal_and_word_references(code_block *compiled, factorvm *myvm);
+void relocate_code_block(code_block *compiled, factor_vm *myvm);
+void copy_literal_references(code_block *compiled, factor_vm *myvm);
+void update_word_references(code_block *compiled, factor_vm *myvm);
+void update_literal_and_word_references(code_block *compiled, factor_vm *myvm);
}
namespace factor
{
-void factorvm::clear_free_list(heap *heap)
+void factor_vm::clear_free_list(heap *heap)
{
memset(&heap->free,0,sizeof(heap_free_list));
}
-
/* This malloc-style heap code is reasonably generic. Maybe in the future, it
will be used for the data heap too, if we ever get incremental
mark/sweep/compact GC. */
-void factorvm::new_heap(heap *heap, cell size)
+void factor_vm::new_heap(heap *heap, cell size)
{
heap->seg = alloc_segment(align_page(size));
if(!heap->seg)
clear_free_list(heap);
}
-
-void factorvm::add_to_free_list(heap *heap, free_heap_block *block)
+void factor_vm::add_to_free_list(heap *heap, free_heap_block *block)
{
if(block->size < free_list_count * block_size_increment)
{
}
}
-
/* Called after reading the code heap from the image file, and after code GC.
In the former case, we must add a large free block from compiling.base + size to
compiling.limit. */
-void factorvm::build_free_list(heap *heap, cell size)
+void factor_vm::build_free_list(heap *heap, cell size)
{
heap_block *prev = NULL;
}
-
-void factorvm::assert_free_block(free_heap_block *block)
+void factor_vm::assert_free_block(free_heap_block *block)
{
if(block->status != B_FREE)
critical_error("Invalid block in free list",(cell)block);
}
-free_heap_block *factorvm::find_free_block(heap *heap, cell size)
+free_heap_block *factor_vm::find_free_block(heap *heap, cell size)
{
cell attempt = size;
return NULL;
}
-
-free_heap_block *factorvm::split_free_block(heap *heap, free_heap_block *block, cell size)
+free_heap_block *factor_vm::split_free_block(heap *heap, free_heap_block *block, cell size)
{
if(block->size != size )
{
return block;
}
-
/* Allocate a block of memory from the mark and sweep GC heap */
-heap_block *factorvm::heap_allot(heap *heap, cell size)
+heap_block *factor_vm::heap_allot(heap *heap, cell size)
{
size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
return NULL;
}
-
/* Deallocates a block manually */
-void factorvm::heap_free(heap *heap, heap_block *block)
+void factor_vm::heap_free(heap *heap, heap_block *block)
{
block->status = B_FREE;
add_to_free_list(heap,(free_heap_block *)block);
}
-
-void factorvm::mark_block(heap_block *block)
+void factor_vm::mark_block(heap_block *block)
{
/* If already marked, do nothing */
switch(block->status)
}
}
-
/* If in the middle of code GC, we have to grow the heap, data GC restarts from
scratch, so we have to unmark any marked blocks. */
-void factorvm::unmark_marked(heap *heap)
+void factor_vm::unmark_marked(heap *heap)
{
heap_block *scan = first_block(heap);
}
}
-
/* After code GC, all referenced code blocks have status set to B_MARKED, so any
which are allocated and not marked can be reclaimed. */
-void factorvm::free_unmarked(heap *heap, heap_iterator iter)
+void factor_vm::free_unmarked(heap *heap, heap_iterator iter)
{
clear_free_list(heap);
add_to_free_list(heap,(free_heap_block *)prev);
}
-
/* Compute total sum of sizes of free blocks, and size of largest free block */
-void factorvm::heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free)
+void factor_vm::heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free)
{
*used = 0;
*total_free = 0;
}
}
-
/* The size of the heap, not including the last block if it's free */
-cell factorvm::heap_size(heap *heap)
+cell factor_vm::heap_size(heap *heap)
{
heap_block *scan = first_block(heap);
return heap->seg->size;
}
-
/* Compute where each block is going to go, after compaction */
-cell factorvm::compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
+cell factor_vm::compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{
heap_block *scan = first_block(heap);
char *address = (char *)first_block(heap);
return (cell)address - heap->seg->start;
}
-
-void factorvm::compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
+void factor_vm::compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{
heap_block *scan = first_block(heap);
heap_free_list free;
};
-typedef void (*heap_iterator)(heap_block *compiled,factorvm *vm);
+typedef void (*heap_iterator)(heap_block *compiled,factor_vm *vm);
inline static heap_block *next_block(heap *h, heap_block *block)
{
{
/* Allocate a code heap during startup */
-void factorvm::init_code_heap(cell size)
+void factor_vm::init_code_heap(cell size)
{
new_heap(&code,size);
}
-bool factorvm::in_code_heap_p(cell ptr)
+bool factor_vm::in_code_heap_p(cell ptr)
{
return (ptr >= code.seg->start && ptr <= code.seg->end);
}
/* Compile a word definition with the non-optimizing compiler. Allocates memory */
-void factorvm::jit_compile_word(cell word_, cell def_, bool relocate)
+void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate)
{
gc_root<word> word(word_,this);
gc_root<quotation> def(def_,this);
if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate);
}
-
/* Apply a function to every code block */
-void factorvm::iterate_code_heap(code_heap_iterator iter)
+void factor_vm::iterate_code_heap(code_heap_iterator iter)
{
heap_block *scan = first_block(&code);
}
}
-
/* Copy literals referenced from all code blocks to newspace. Only for
aging and nursery collections */
-void factorvm::copy_code_heap_roots()
+void factor_vm::copy_code_heap_roots()
{
iterate_code_heap(factor::copy_literal_references);
}
-
/* Update pointers to words referenced from all code blocks. Only after
defining a new word. */
-void factorvm::update_code_heap_words()
+void factor_vm::update_code_heap_words()
{
iterate_code_heap(factor::update_word_references);
}
-
-inline void factorvm::vmprim_modify_code_heap()
+inline void factor_vm::primitive_modify_code_heap()
{
gc_root<array> alist(dpop(),this);
PRIMITIVE(modify_code_heap)
{
- PRIMITIVE_GETVM()->vmprim_modify_code_heap();
+ PRIMITIVE_GETVM()->primitive_modify_code_heap();
}
/* Push the free space and total size of the code heap */
-inline void factorvm::vmprim_code_room()
+inline void factor_vm::primitive_code_room()
{
cell used, total_free, max_free;
heap_usage(&code,&used,&total_free,&max_free);
PRIMITIVE(code_room)
{
- PRIMITIVE_GETVM()->vmprim_code_room();
+ PRIMITIVE_GETVM()->primitive_code_room();
}
-
-code_block *factorvm::forward_xt(code_block *compiled)
+code_block *factor_vm::forward_xt(code_block *compiled)
{
return (code_block *)forwarding[compiled];
}
-
-void factorvm::forward_frame_xt(stack_frame *frame)
+void factor_vm::forward_frame_xt(stack_frame *frame)
{
cell offset = (cell)FRAME_RETURN_ADDRESS(frame) - (cell)frame_code(frame);
code_block *forwarded = forward_xt(frame_code(frame));
FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset);
}
-void forward_frame_xt(stack_frame *frame,factorvm *myvm)
+void forward_frame_xt(stack_frame *frame,factor_vm *myvm)
{
return myvm->forward_frame_xt(frame);
}
-void factorvm::forward_object_xts()
+void factor_vm::forward_object_xts()
{
begin_scan();
end_scan();
}
-
/* Set the XT fields now that the heap has been compacted */
-void factorvm::fixup_object_xts()
+void factor_vm::fixup_object_xts()
{
begin_scan();
end_scan();
}
-
/* Move all free space to the end of the code heap. This is not very efficient,
since it makes several passes over the code and data heaps, but we only ever
do this before saving a deployed image and exiting, so performaance is not
critical here */
-void factorvm::compact_code_heap()
+void factor_vm::compact_code_heap()
{
/* Free all unreachable code blocks */
gc();
namespace factor
{
-struct factorvm;
-typedef void (*code_heap_iterator)(code_block *compiled,factorvm *myvm);
+struct factor_vm;
+typedef void (*code_heap_iterator)(code_block *compiled,factor_vm *myvm);
PRIMITIVE(modify_code_heap);
PRIMITIVE(code_room);
namespace factor
{
-
-void factorvm::reset_datastack()
+void factor_vm::reset_datastack()
{
ds = ds_bot - sizeof(cell);
}
-void factorvm::reset_retainstack()
+void factor_vm::reset_retainstack()
{
rs = rs_bot - sizeof(cell);
}
static const cell stack_reserved = (64 * sizeof(cell));
-void factorvm::fix_stacks()
+void factor_vm::fix_stacks()
{
if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack();
if(rs + sizeof(cell) < rs_bot || rs + stack_reserved >= rs_top) reset_retainstack();
/* called before entry into foreign C code. Note that ds and rs might
be stored in registers, so callbacks must save and restore the correct values */
-void factorvm::save_stacks()
+void factor_vm::save_stacks()
{
if(stack_chain)
{
}
}
-context *factorvm::alloc_context()
+context *factor_vm::alloc_context()
{
context *new_context;
return new_context;
}
-void factorvm::dealloc_context(context *old_context)
+void factor_vm::dealloc_context(context *old_context)
{
old_context->next = unused_contexts;
unused_contexts = old_context;
}
/* called on entry into a compiled callback */
-void factorvm::nest_stacks()
+void factor_vm::nest_stacks()
{
context *new_context = alloc_context();
reset_retainstack();
}
-void nest_stacks(factorvm *myvm)
+void nest_stacks(factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->nest_stacks();
}
/* called when leaving a compiled callback */
-void factorvm::unnest_stacks()
+void factor_vm::unnest_stacks()
{
ds = stack_chain->datastack_save;
rs = stack_chain->retainstack_save;
dealloc_context(old_stacks);
}
-void unnest_stacks(factorvm *myvm)
+void unnest_stacks(factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->unnest_stacks();
}
/* called on startup */
-void factorvm::init_stacks(cell ds_size_, cell rs_size_)
+void factor_vm::init_stacks(cell ds_size_, cell rs_size_)
{
ds_size = ds_size_;
rs_size = rs_size_;
unused_contexts = NULL;
}
-bool factorvm::stack_to_array(cell bottom, cell top)
+bool factor_vm::stack_to_array(cell bottom, cell top)
{
fixnum depth = (fixnum)(top - bottom + sizeof(cell));
}
}
-inline void factorvm::vmprim_datastack()
+inline void factor_vm::primitive_datastack()
{
if(!stack_to_array(ds_bot,ds))
general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
PRIMITIVE(datastack)
{
- PRIMITIVE_GETVM()->vmprim_datastack();
+ PRIMITIVE_GETVM()->primitive_datastack();
}
-inline void factorvm::vmprim_retainstack()
+inline void factor_vm::primitive_retainstack()
{
if(!stack_to_array(rs_bot,rs))
general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
PRIMITIVE(retainstack)
{
- PRIMITIVE_GETVM()->vmprim_retainstack();
+ PRIMITIVE_GETVM()->primitive_retainstack();
}
/* returns pointer to top of stack */
-cell factorvm::array_to_stack(array *array, cell bottom)
+cell factor_vm::array_to_stack(array *array, cell bottom)
{
cell depth = array_capacity(array) * sizeof(cell);
memcpy((void*)bottom,array + 1,depth);
return bottom + depth - sizeof(cell);
}
-inline void factorvm::vmprim_set_datastack()
+inline void factor_vm::primitive_set_datastack()
{
ds = array_to_stack(untag_check<array>(dpop()),ds_bot);
}
PRIMITIVE(set_datastack)
{
- PRIMITIVE_GETVM()->vmprim_set_datastack();
+ PRIMITIVE_GETVM()->primitive_set_datastack();
}
-inline void factorvm::vmprim_set_retainstack()
+inline void factor_vm::primitive_set_retainstack()
{
rs = array_to_stack(untag_check<array>(dpop()),rs_bot);
}
PRIMITIVE(set_retainstack)
{
- PRIMITIVE_GETVM()->vmprim_set_retainstack();
+ PRIMITIVE_GETVM()->primitive_set_retainstack();
}
/* Used to implement call( */
-inline void factorvm::vmprim_check_datastack()
+inline void factor_vm::primitive_check_datastack()
{
fixnum out = to_fixnum(dpop());
fixnum in = to_fixnum(dpop());
PRIMITIVE(check_datastack)
{
- PRIMITIVE_GETVM()->vmprim_check_datastack();
+ PRIMITIVE_GETVM()->primitive_check_datastack();
}
}
PRIMITIVE(set_retainstack);
PRIMITIVE(check_datastack);
-struct factorvm;
-VM_C_API void nest_stacks(factorvm *vm);
-VM_C_API void unnest_stacks(factorvm *vm);
+struct factor_vm;
+VM_C_API void nest_stacks(factor_vm *vm);
+VM_C_API void unnest_stacks(factor_vm *vm);
}
mov NV_TEMP_REG,ARG1
jmp *QUOT_XT_OFFSET(ARG0)
-
DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot, void *vm)):
mov ARG1,NV_TEMP_REG /* stash vm ptr */
mov STACK_REG,ARG1 /* Save stack pointer */
pop NV_TEMP_REG
mov RETURN_REG,ARG0 /* No-op on 32-bit */
add $STACK_PADDING,STACK_REG
- jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
+ jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
#include "cpu-x86.S"
add $STACK_PADDING,%rsp
jmp *%rax
-
DEF(void,get_sse_env,(void*)):
stmxcsr (%rdi)
ret
pop ARG2
jmp MANGLE(overflow_fixnum_multiply)
-
DEF(F_FASTCALL void,c_to_factor,(CELL quot, void *vm)):
PUSH_NONVOLATILE
mov ARG0,NV_TEMP_REG
+
/* Create register shadow area for Win64 */
sub $32,STACK_REG
-
+
/* Save stack pointer */
lea -CELL_SIZE(STACK_REG),ARG0
push ARG1 /* save vm ptr */
namespace factor
{
-void factorvm::init_data_gc()
+void factor_vm::init_data_gc()
{
performing_gc = false;
last_code_heap_scan = data->nursery();
collecting_aging_again = false;
}
-
/* Given a pointer to oldspace, copy it to newspace */
-object *factorvm::copy_untagged_object_impl(object *pointer, cell size)
+object *factor_vm::copy_untagged_object_impl(object *pointer, cell size)
{
if(newspace->here + size >= newspace->end)
longjmp(gc_jmp,1);
return newpointer;
}
-
-object *factorvm::copy_object_impl(object *untagged)
+object *factor_vm::copy_object_impl(object *untagged)
{
object *newpointer = copy_untagged_object_impl(untagged,untagged_object_size(untagged));
untagged->h.forward_to(newpointer);
return newpointer;
}
-
-bool factorvm::should_copy_p(object *untagged)
+bool factor_vm::should_copy_p(object *untagged)
{
if(in_zone(newspace,untagged))
return false;
}
}
-
/* Follow a chain of forwarding pointers */
-object *factorvm::resolve_forwarding(object *untagged)
+object *factor_vm::resolve_forwarding(object *untagged)
{
check_data_pointer(untagged);
}
}
-
-template <typename TYPE> TYPE *factorvm::copy_untagged_object(TYPE *untagged)
+template <typename TYPE> TYPE *factor_vm::copy_untagged_object(TYPE *untagged)
{
check_data_pointer(untagged);
return untagged;
}
-
-cell factorvm::copy_object(cell pointer)
+cell factor_vm::copy_object(cell pointer)
{
return RETAG(copy_untagged_object(untag<object>(pointer)),TAG(pointer));
}
-
-void factorvm::copy_handle(cell *handle)
+void factor_vm::copy_handle(cell *handle)
{
cell pointer = *handle;
}
}
-
/* Scan all the objects in the card */
-void factorvm::copy_card(card *ptr, cell gen, cell here)
+void factor_vm::copy_card(card *ptr, cell gen, cell here)
{
cell card_scan = card_to_addr(ptr) + card_offset(ptr);
cell card_end = card_to_addr(ptr + 1);
cards_scanned++;
}
-
-void factorvm::copy_card_deck(card_deck *deck, cell gen, card mask, card unmask)
+void factor_vm::copy_card_deck(card_deck *deck, cell gen, card mask, card unmask)
{
card *first_card = deck_to_card(deck);
card *last_card = deck_to_card(deck + 1);
decks_scanned++;
}
-
/* Copy all newspace objects referenced from marked cards to the destination */
-void factorvm::copy_gen_cards(cell gen)
+void factor_vm::copy_gen_cards(cell gen)
{
card_deck *first_deck = addr_to_deck(data->generations[gen].start);
card_deck *last_deck = addr_to_deck(data->generations[gen].end);
}
}
-
/* Scan cards in all generations older than the one being collected, copying
old->new references */
-void factorvm::copy_cards()
+void factor_vm::copy_cards()
{
u64 start = current_micros();
card_scan_time += (current_micros() - start);
}
-
/* Copy all tagged pointers in a range of memory */
-void factorvm::copy_stack_elements(segment *region, cell top)
+void factor_vm::copy_stack_elements(segment *region, cell top)
{
cell ptr = region->start;
copy_handle((cell*)ptr);
}
-
-void factorvm::copy_registered_locals()
+void factor_vm::copy_registered_locals()
{
std::vector<cell>::const_iterator iter = gc_locals.begin();
std::vector<cell>::const_iterator end = gc_locals.end();
copy_handle((cell *)(*iter));
}
-
-void factorvm::copy_registered_bignums()
+void factor_vm::copy_registered_bignums()
{
std::vector<cell>::const_iterator iter = gc_bignums.begin();
std::vector<cell>::const_iterator end = gc_bignums.end();
}
}
-
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered by local_roots.hpp */
-void factorvm::copy_roots()
+void factor_vm::copy_roots()
{
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&userenv[i]);
}
-
-cell factorvm::copy_next_from_nursery(cell scan)
+cell factor_vm::copy_next_from_nursery(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-
-cell factorvm::copy_next_from_aging(cell scan)
+cell factor_vm::copy_next_from_aging(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-
-cell factorvm::copy_next_from_tenured(cell scan)
+cell factor_vm::copy_next_from_tenured(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-
-void factorvm::copy_reachable_objects(cell scan, cell *end)
+void factor_vm::copy_reachable_objects(cell scan, cell *end)
{
if(collecting_gen == data->nursery())
{
}
}
-
/* Prepare to start copying reachable objects into an unused zone */
-void factorvm::begin_gc(cell requested_bytes)
+void factor_vm::begin_gc(cell requested_bytes)
{
if(growing_data_heap)
{
}
}
-
-void factorvm::end_gc(cell gc_elapsed)
+void factor_vm::end_gc(cell gc_elapsed)
{
gc_stats *s = &stats[collecting_gen];
collecting_aging_again = false;
}
-
/* Collect gen and all younger generations.
If growing_data_heap_ is true, we must grow the data heap to such a size that
an allocation of requested_bytes won't fail */
-void factorvm::garbage_collection(cell gen,bool growing_data_heap_,cell requested_bytes)
+void factor_vm::garbage_collection(cell gen,bool growing_data_heap_,cell requested_bytes)
{
if(gc_off)
{
performing_gc = false;
}
-
-void factorvm::gc()
+void factor_vm::gc()
{
garbage_collection(data->tenured(),false,0);
}
-
-inline void factorvm::vmprim_gc()
+inline void factor_vm::primitive_gc()
{
gc();
}
PRIMITIVE(gc)
{
- PRIMITIVE_GETVM()->vmprim_gc();
+ PRIMITIVE_GETVM()->primitive_gc();
}
-inline void factorvm::vmprim_gc_stats()
+inline void factor_vm::primitive_gc_stats()
{
growable_array result(this);
PRIMITIVE(gc_stats)
{
- PRIMITIVE_GETVM()->vmprim_gc_stats();
+ PRIMITIVE_GETVM()->primitive_gc_stats();
}
-void factorvm::clear_gc_stats()
+void factor_vm::clear_gc_stats()
{
for(cell i = 0; i < max_gen_count; i++)
memset(&stats[i],0,sizeof(gc_stats));
code_heap_scans = 0;
}
-inline void factorvm::vmprim_clear_gc_stats()
+inline void factor_vm::primitive_clear_gc_stats()
{
clear_gc_stats();
}
PRIMITIVE(clear_gc_stats)
{
- PRIMITIVE_GETVM()->vmprim_clear_gc_stats();
+ PRIMITIVE_GETVM()->primitive_clear_gc_stats();
}
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */
-inline void factorvm::vmprim_become()
+inline void factor_vm::primitive_become()
{
array *new_objects = untag_check<array>(dpop());
array *old_objects = untag_check<array>(dpop());
PRIMITIVE(become)
{
- PRIMITIVE_GETVM()->vmprim_become();
+ PRIMITIVE_GETVM()->primitive_become();
}
-void factorvm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
+void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
{
for(cell i = 0; i < gc_roots_size; i++)
gc_locals.push_back((cell)&gc_roots_base[i]);
gc_locals.pop_back();
}
-VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factorvm *myvm)
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm)
{
ASSERTVM();
VM_PTR->inline_gc(gc_roots_base,gc_roots_size);
PRIMITIVE(gc_stats);
PRIMITIVE(clear_gc_stats);
PRIMITIVE(become);
-struct factorvm;
-VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factorvm *myvm);
+struct factor_vm;
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm);
}
namespace factor
{
-cell factorvm::init_zone(zone *z, cell size, cell start)
+cell factor_vm::init_zone(zone *z, cell size, cell start)
{
z->size = size;
z->start = z->here = start;
return z->end;
}
-
-void factorvm::init_card_decks()
+void factor_vm::init_card_decks()
{
cell start = align(data->seg->start,deck_size);
allot_markers_offset = (cell)data->allot_markers - (start >> card_bits);
decks_offset = (cell)data->decks - (start >> deck_bits);
}
-data_heap *factorvm::alloc_data_heap(cell gens, cell young_size,cell aging_size,cell tenured_size)
+data_heap *factor_vm::alloc_data_heap(cell gens, cell young_size,cell aging_size,cell tenured_size)
{
young_size = align(young_size,deck_size);
aging_size = align(aging_size,deck_size);
return data;
}
-
-data_heap *factorvm::grow_data_heap(data_heap *data, cell requested_bytes)
+data_heap *factor_vm::grow_data_heap(data_heap *data, cell requested_bytes)
{
cell new_tenured_size = (data->tenured_size * 2) + requested_bytes;
new_tenured_size);
}
-
-void factorvm::dealloc_data_heap(data_heap *data)
+void factor_vm::dealloc_data_heap(data_heap *data)
{
dealloc_segment(data->seg);
free(data->generations);
free(data);
}
-
-void factorvm::clear_cards(cell from, cell to)
+void factor_vm::clear_cards(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_card(data->generations[to].start);
memset(first_card,0,last_card - first_card);
}
-
-void factorvm::clear_decks(cell from, cell to)
+void factor_vm::clear_decks(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card_deck *first_deck = addr_to_deck(data->generations[to].start);
memset(first_deck,0,last_deck - first_deck);
}
-
-void factorvm::clear_allot_markers(cell from, cell to)
+void factor_vm::clear_allot_markers(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_allot_marker((object *)data->generations[to].start);
memset(first_card,invalid_allot_marker,last_card - first_card);
}
-
-void factorvm::reset_generation(cell i)
+void factor_vm::reset_generation(cell i)
{
zone *z = (i == data->nursery() ? &nursery : &data->generations[i]);
memset((void*)z->start,69,z->size);
}
-
/* After garbage collection, any generations which are now empty need to have
their allocation pointers and cards reset. */
-void factorvm::reset_generations(cell from, cell to)
+void factor_vm::reset_generations(cell from, cell to)
{
cell i;
for(i = from; i <= to; i++)
clear_allot_markers(from,to);
}
-
-void factorvm::set_data_heap(data_heap *data_)
+void factor_vm::set_data_heap(data_heap *data_)
{
data = data_;
nursery = data->generations[data->nursery()];
clear_allot_markers(data->nursery(),data->tenured());
}
-
-void factorvm::init_data_heap(cell gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_)
+void factor_vm::init_data_heap(cell gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_)
{
set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
secure_gc = secure_gc_;
init_data_gc();
}
-
/* Size of the object pointed to by a tagged pointer */
-cell factorvm::object_size(cell tagged)
+cell factor_vm::object_size(cell tagged)
{
if(immediate_p(tagged))
return 0;
return untagged_object_size(untag<object>(tagged));
}
-
/* Size of the object pointed to by an untagged pointer */
-cell factorvm::untagged_object_size(object *pointer)
+cell factor_vm::untagged_object_size(object *pointer)
{
return align8(unaligned_object_size(pointer));
}
-
/* Size of the data area of an object pointed to by an untagged pointer */
-cell factorvm::unaligned_object_size(object *pointer)
+cell factor_vm::unaligned_object_size(object *pointer)
{
switch(pointer->h.hi_tag())
{
}
}
-
-inline void factorvm::vmprim_size()
+inline void factor_vm::primitive_size()
{
box_unsigned_cell(object_size(dpop()));
}
PRIMITIVE(size)
{
- PRIMITIVE_GETVM()->vmprim_size();
+ PRIMITIVE_GETVM()->primitive_size();
}
/* The number of cells from the start of the object which should be scanned by
the GC. Some types have a binary payload at the end (string, word, DLL) which
we ignore. */
-cell factorvm::binary_payload_start(object *pointer)
+cell factor_vm::binary_payload_start(object *pointer)
{
switch(pointer->h.hi_tag())
{
}
}
-
/* Push memory usage statistics in data heap */
-inline void factorvm::vmprim_data_room()
+inline void factor_vm::primitive_data_room()
{
dpush(tag_fixnum((data->cards_end - data->cards) >> 10));
dpush(tag_fixnum((data->decks_end - data->decks) >> 10));
PRIMITIVE(data_room)
{
- PRIMITIVE_GETVM()->vmprim_data_room();
+ PRIMITIVE_GETVM()->primitive_data_room();
}
/* Disables GC and activates next-object ( -- obj ) primitive */
-void factorvm::begin_scan()
+void factor_vm::begin_scan()
{
heap_scan_ptr = data->generations[data->tenured()].start;
gc_off = true;
}
-
-void factorvm::end_scan()
+void factor_vm::end_scan()
{
gc_off = false;
}
-
-inline void factorvm::vmprim_begin_scan()
+inline void factor_vm::primitive_begin_scan()
{
begin_scan();
}
PRIMITIVE(begin_scan)
{
- PRIMITIVE_GETVM()->vmprim_begin_scan();
+ PRIMITIVE_GETVM()->primitive_begin_scan();
}
-cell factorvm::next_object()
+cell factor_vm::next_object()
{
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
return tag_dynamic(obj);
}
-
/* Push object at heap scan cursor and advance; pushes f when done */
-inline void factorvm::vmprim_next_object()
+inline void factor_vm::primitive_next_object()
{
dpush(next_object());
}
PRIMITIVE(next_object)
{
- PRIMITIVE_GETVM()->vmprim_next_object();
+ PRIMITIVE_GETVM()->primitive_next_object();
}
/* Re-enables GC */
-inline void factorvm::vmprim_end_scan()
+inline void factor_vm::primitive_end_scan()
{
gc_off = false;
}
PRIMITIVE(end_scan)
{
- PRIMITIVE_GETVM()->vmprim_end_scan();
+ PRIMITIVE_GETVM()->primitive_end_scan();
}
-template<typename TYPE> void factorvm::each_object(TYPE &functor)
+template<typename TYPE> void factor_vm::each_object(TYPE &functor)
{
begin_scan();
cell obj;
end_scan();
}
-
namespace
{
struct word_accumulator {
growable_array words;
- word_accumulator(int count,factorvm *vm) : words(vm,count) {}
+ word_accumulator(int count,factor_vm *vm) : words(vm,count) {}
void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) words.add(obj.value()); }
};
}
-cell factorvm::find_all_words()
+cell factor_vm::find_all_words()
{
word_counter counter;
each_object(counter);
return accum.words.elements.value();
}
-
}
namespace factor
{
-
/* generational copying GC divides memory into zones */
struct zone {
/* allocation pointer is 'here'; its offset is hardcoded in the
bool have_aging_p() { return gen_count > 2; }
};
-
static const cell max_gen_count = 3;
inline static bool in_zone(zone *z, object *pointer)
namespace factor
{
-
-void factorvm::print_chars(string* str)
+void factor_vm::print_chars(string* str)
{
cell i;
for(i = 0; i < string_capacity(str); i++)
putchar(string_nth(str,i));
}
-
-void factorvm::print_word(word* word, cell nesting)
+void factor_vm::print_word(word* word, cell nesting)
{
if(tagged<object>(word->vocabulary).type_p(STRING_TYPE))
{
}
}
-
-void factorvm::print_factor_string(string* str)
+void factor_vm::print_factor_string(string* str)
{
putchar('"');
print_chars(str);
putchar('"');
}
-
-void factorvm::print_array(array* array, cell nesting)
+void factor_vm::print_array(array* array, cell nesting)
{
cell length = array_capacity(array);
cell i;
print_string("...");
}
-
-void factorvm::print_tuple(tuple *tuple, cell nesting)
+void factor_vm::print_tuple(tuple *tuple, cell nesting)
{
tuple_layout *layout = untag<tuple_layout>(tuple->layout);
cell length = to_fixnum(layout->size);
print_string("...");
}
-
-void factorvm::print_nested_obj(cell obj, fixnum nesting)
+void factor_vm::print_nested_obj(cell obj, fixnum nesting)
{
if(nesting <= 0 && !full_output)
{
}
}
-
-void factorvm::print_obj(cell obj)
+void factor_vm::print_obj(cell obj)
{
print_nested_obj(obj,10);
}
-
-void factorvm::print_objects(cell *start, cell *end)
+void factor_vm::print_objects(cell *start, cell *end)
{
for(; start <= end; start++)
{
}
}
-
-void factorvm::print_datastack()
+void factor_vm::print_datastack()
{
print_string("==== DATA STACK:\n");
print_objects((cell *)ds_bot,(cell *)ds);
}
-
-void factorvm::print_retainstack()
+void factor_vm::print_retainstack()
{
print_string("==== RETAIN STACK:\n");
print_objects((cell *)rs_bot,(cell *)rs);
}
-
-void factorvm::print_stack_frame(stack_frame *frame)
+void factor_vm::print_stack_frame(stack_frame *frame)
{
print_obj(frame_executing(frame));
print_string("\n");
print_string("\n");
}
-void print_stack_frame(stack_frame *frame, factorvm *myvm)
+void print_stack_frame(stack_frame *frame, factor_vm *myvm)
{
return myvm->print_stack_frame(frame);
}
-void factorvm::print_callstack()
+void factor_vm::print_callstack()
{
print_string("==== CALL STACK:\n");
cell bottom = (cell)stack_chain->callstack_bottom;
iterate_callstack(top,bottom,factor::print_stack_frame);
}
-
-void factorvm::dump_cell(cell x)
+void factor_vm::dump_cell(cell x)
{
print_cell_hex_pad(x); print_string(": ");
x = *(cell *)x;
nl();
}
-
-void factorvm::dump_memory(cell from, cell to)
+void factor_vm::dump_memory(cell from, cell to)
{
from = UNTAG(from);
dump_cell(from);
}
-
-void factorvm::dump_zone(zone *z)
+void factor_vm::dump_zone(zone *z)
{
print_string("Start="); print_cell(z->start);
print_string(", size="); print_cell(z->size);
print_string(", here="); print_cell(z->here - z->start); nl();
}
-
-void factorvm::dump_generations()
+void factor_vm::dump_generations()
{
cell i;
nl();
}
-
-void factorvm::dump_objects(cell type)
+void factor_vm::dump_objects(cell type)
{
gc();
begin_scan();
}
-
-void factorvm::find_data_references_step(cell *scan)
+void factor_vm::find_data_references_step(cell *scan)
{
if(look_for == *scan)
{
}
}
-void find_data_references_step(cell *scan,factorvm *myvm)
+void find_data_references_step(cell *scan,factor_vm *myvm)
{
return myvm->find_data_references_step(scan);
}
-void factorvm::find_data_references(cell look_for_)
+void factor_vm::find_data_references(cell look_for_)
{
look_for = look_for_;
end_scan();
}
-
/* Dump all code blocks for debugging */
-void factorvm::dump_code_heap()
+void factor_vm::dump_code_heap()
{
cell reloc_size = 0, literal_size = 0;
print_cell(literal_size); print_string(" bytes of literal data\n");
}
-
-void factorvm::factorbug()
+void factor_vm::factorbug()
{
if(fep_disabled)
{
}
}
-
-inline void factorvm::vmprim_die()
+inline void factor_vm::primitive_die()
{
print_string("The die word was called by the library. Unless you called it yourself,\n");
print_string("you have triggered a bug in Factor. Please report.\n");
PRIMITIVE(die)
{
- PRIMITIVE_GETVM()->vmprim_die();
+ PRIMITIVE_GETVM()->primitive_die();
}
}
namespace factor
{
-
PRIMITIVE(die);
}
namespace factor
{
-cell factorvm::search_lookup_alist(cell table, cell klass)
+cell factor_vm::search_lookup_alist(cell table, cell klass)
{
array *elements = untag<array>(table);
fixnum index = array_capacity(elements) - 2;
return F;
}
-cell factorvm::search_lookup_hash(cell table, cell klass, cell hashcode)
+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));
return search_lookup_alist(bucket,klass);
}
-cell factorvm::nth_superclass(tuple_layout *layout, fixnum echelon)
+cell factor_vm::nth_superclass(tuple_layout *layout, fixnum echelon)
{
cell *ptr = (cell *)(layout + 1);
return ptr[echelon * 2];
}
-cell factorvm::nth_hashcode(tuple_layout *layout, fixnum echelon)
+cell factor_vm::nth_hashcode(tuple_layout *layout, fixnum echelon)
{
cell *ptr = (cell *)(layout + 1);
return ptr[echelon * 2 + 1];
}
-cell factorvm::lookup_tuple_method(cell obj, cell methods)
+cell factor_vm::lookup_tuple_method(cell obj, cell methods)
{
tuple_layout *layout = untag<tuple_layout>(untag<tuple>(obj)->layout);
return F;
}
-cell factorvm::lookup_hi_tag_method(cell obj, cell methods)
+cell factor_vm::lookup_hi_tag_method(cell obj, cell methods)
{
array *hi_tag_methods = untag<array>(methods);
cell tag = untag<object>(obj)->h.hi_tag() - HEADER_TYPE;
return array_nth(hi_tag_methods,tag);
}
-cell factorvm::lookup_hairy_method(cell obj, cell methods)
+cell factor_vm::lookup_hairy_method(cell obj, cell methods)
{
cell method = array_nth(untag<array>(methods),TAG(obj));
if(tagged<object>(method).type_p(WORD_TYPE))
}
}
-cell factorvm::lookup_method(cell obj, cell methods)
+cell factor_vm::lookup_method(cell obj, cell methods)
{
cell tag = TAG(obj);
if(tag == TUPLE_TYPE || tag == OBJECT_TYPE)
return array_nth(untag<array>(methods),TAG(obj));
}
-inline void factorvm::vmprim_lookup_method()
+inline void factor_vm::primitive_lookup_method()
{
cell methods = dpop();
cell obj = dpop();
PRIMITIVE(lookup_method)
{
- PRIMITIVE_GETVM()->vmprim_lookup_method();
+ PRIMITIVE_GETVM()->primitive_lookup_method();
}
-cell factorvm::object_class(cell obj)
+cell factor_vm::object_class(cell obj)
{
switch(TAG(obj))
{
}
}
-cell factorvm::method_cache_hashcode(cell klass, array *array)
+cell factor_vm::method_cache_hashcode(cell klass, array *array)
{
cell capacity = (array_capacity(array) >> 1) - 1;
return ((klass >> TAG_BITS) & capacity) << 1;
}
-void factorvm::update_method_cache(cell cache, cell klass, cell method)
+void factor_vm::update_method_cache(cell cache, cell klass, cell method)
{
array *cache_elements = untag<array>(cache);
cell hashcode = method_cache_hashcode(klass,cache_elements);
set_array_nth(cache_elements,hashcode + 1,method);
}
-inline void factorvm::vmprim_mega_cache_miss()
+inline void factor_vm::primitive_mega_cache_miss()
{
megamorphic_cache_misses++;
PRIMITIVE(mega_cache_miss)
{
- PRIMITIVE_GETVM()->vmprim_mega_cache_miss();
+ PRIMITIVE_GETVM()->primitive_mega_cache_miss();
}
-inline void factorvm::vmprim_reset_dispatch_stats()
+inline void factor_vm::primitive_reset_dispatch_stats()
{
megamorphic_cache_hits = megamorphic_cache_misses = 0;
}
PRIMITIVE(reset_dispatch_stats)
{
- PRIMITIVE_GETVM()->vmprim_reset_dispatch_stats();
+ PRIMITIVE_GETVM()->primitive_reset_dispatch_stats();
}
-inline void factorvm::vmprim_dispatch_stats()
+inline void factor_vm::primitive_dispatch_stats()
{
growable_array stats(this);
stats.add(allot_cell(megamorphic_cache_hits));
PRIMITIVE(dispatch_stats)
{
- PRIMITIVE_GETVM()->vmprim_dispatch_stats();
+ PRIMITIVE_GETVM()->primitive_dispatch_stats();
}
void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_)
{
- gc_root<array> methods(methods_,myvm);
- gc_root<array> cache(cache_,myvm);
+ gc_root<array> methods(methods_,parent_vm);
+ gc_root<array> cache(cache_,parent_vm);
/* Generate machine code to determine the object's class. */
emit_class_lookup(index,PIC_HI_TAG_TUPLE);
/* Do a cache lookup. */
- emit_with(myvm->userenv[MEGA_LOOKUP],cache.value());
+ emit_with(parent_vm->userenv[MEGA_LOOKUP],cache.value());
/* If we end up here, the cache missed. */
- emit(myvm->userenv[JIT_PROLOG]);
+ emit(parent_vm->userenv[JIT_PROLOG]);
/* Push index, method table and cache on the stack. */
push(methods.value());
push(tag_fixnum(index));
push(cache.value());
- word_call(myvm->userenv[MEGA_MISS_WORD]);
+ word_call(parent_vm->userenv[MEGA_MISS_WORD]);
/* Now the new method has been stored into the cache, and its on
the stack. */
- emit(myvm->userenv[JIT_EPILOG]);
- emit(myvm->userenv[JIT_EXECUTE_JUMP]);
+ emit(parent_vm->userenv[JIT_EPILOG]);
+ emit(parent_vm->userenv[JIT_EXECUTE_JUMP]);
}
}
namespace factor
{
-void factorvm::out_of_memory()
+void factor_vm::out_of_memory()
{
print_string("Out of memory\n\n");
dump_generations();
exit(1);
}
-void factorvm::critical_error(const char* msg, cell tagged)
+void factor_vm::critical_error(const char* msg, cell tagged)
{
print_string("You have triggered a bug in Factor. Please report.\n");
print_string("critical_error: "); print_string(msg);
factorbug();
}
-void factorvm::throw_error(cell error, stack_frame *callstack_top)
+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. */
}
}
-void factorvm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *callstack_top)
+void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *callstack_top)
{
throw_error(allot_array_4(userenv[ERROR_ENV],
tag_fixnum(error),arg1,arg2),callstack_top);
}
-
-void factorvm::type_error(cell type, cell tagged)
+void factor_vm::type_error(cell type, cell tagged)
{
general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
}
-void factorvm::not_implemented_error()
+void factor_vm::not_implemented_error()
{
general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
}
-
/* Test if 'fault' is in the guard page at the top or bottom (depending on
offset being 0 or -1) of area+area_size */
-bool factorvm::in_page(cell fault, cell area, cell area_size, int offset)
+bool factor_vm::in_page(cell fault, cell area, cell area_size, int offset)
{
int pagesize = getpagesize();
area += area_size;
return fault >= area && fault <= area + pagesize;
}
-void factorvm::memory_protection_error(cell addr, stack_frame *native_stack)
+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_MEMORY,allot_cell(addr),F,native_stack);
}
-void factorvm::signal_error(int signal, stack_frame *native_stack)
+void factor_vm::signal_error(int signal, stack_frame *native_stack)
{
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
}
-void factorvm::divide_by_zero_error()
+void factor_vm::divide_by_zero_error()
{
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
-void factorvm::fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
+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);
}
-inline void factorvm::vmprim_call_clear()
+inline void factor_vm::primitive_call_clear()
{
throw_impl(dpop(),stack_chain->callstack_bottom,this);
}
PRIMITIVE(call_clear)
{
- PRIMITIVE_GETVM()->vmprim_call_clear();
+ PRIMITIVE_GETVM()->primitive_call_clear();
}
/* For testing purposes */
-inline void factorvm::vmprim_unimplemented()
+inline void factor_vm::primitive_unimplemented()
{
not_implemented_error();
}
PRIMITIVE(unimplemented)
{
- PRIMITIVE_GETVM()->vmprim_unimplemented();
+ PRIMITIVE_GETVM()->primitive_unimplemented();
}
-void factorvm::memory_signal_handler_impl()
+void factor_vm::memory_signal_handler_impl()
{
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
SIGNAL_VM_PTR()->memory_signal_handler_impl();
}
-void factorvm::misc_signal_handler_impl()
+void factor_vm::misc_signal_handler_impl()
{
signal_error(signal_number,signal_callstack_top);
}
SIGNAL_VM_PTR()->misc_signal_handler_impl();
}
-void factorvm::fp_signal_handler_impl()
+void factor_vm::fp_signal_handler_impl()
{
fp_trap_error(signal_fpu_status,signal_callstack_top);
}
namespace factor
{
-factorvm *vm;
+factor_vm *vm;
void init_globals()
{
init_platform_globals();
}
-void factorvm::default_parameters(vm_parameters *p)
+void factor_vm::default_parameters(vm_parameters *p)
{
p->image_path = NULL;
p->stack_traces = true;
}
-bool factorvm::factor_arg(const vm_char* str, const vm_char* arg, cell* value)
+bool factor_vm::factor_arg(const vm_char* str, const vm_char* arg, cell* value)
{
int val;
if(SSCANF(str,arg,&val) > 0)
return false;
}
-void factorvm::init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv)
+void factor_vm::init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv)
{
default_parameters(p);
p->executable_path = argv[0];
}
/* Do some initialization that we do once only */
-void factorvm::do_stage1_init()
+void factor_vm::do_stage1_init()
{
print_string("*** Stage 2 early init... ");
fflush(stdout);
fflush(stdout);
}
-void factorvm::init_factor(vm_parameters *p)
+void factor_vm::init_factor(vm_parameters *p)
{
/* Kilobytes */
p->ds_size = align_page(p->ds_size << 10);
}
/* May allocate memory */
-void factorvm::pass_args_to_factor(int argc, vm_char **argv)
+void factor_vm::pass_args_to_factor(int argc, vm_char **argv)
{
growable_array args(this);
int i;
userenv[ARGS_ENV] = args.elements.value();
}
-void factorvm::start_factor(vm_parameters *p)
+void factor_vm::start_factor(vm_parameters *p)
{
if(p->fep) factorbug();
unnest_stacks();
}
-
-char *factorvm::factor_eval_string(char *string)
+char *factor_vm::factor_eval_string(char *string)
{
char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
return callback(string);
}
-void factorvm::factor_eval_free(char *result)
+void factor_vm::factor_eval_free(char *result)
{
free(result);
}
-void factorvm::factor_yield()
+void factor_vm::factor_yield()
{
void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
callback();
}
-void factorvm::factor_sleep(long us)
+void factor_vm::factor_sleep(long us)
{
void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
callback(us);
}
-void factorvm::start_standalone_factor(int argc, vm_char **argv)
+void factor_vm::start_standalone_factor(int argc, vm_char **argv)
{
vm_parameters p;
default_parameters(&p);
void* start_standalone_factor_thread(void *arg)
{
- factorvm *newvm = new factorvm;
+ factor_vm *newvm = new factor_vm;
register_vm_with_thread(newvm);
startargs *args = (startargs*) arg;
newvm->start_standalone_factor(args->argc, args->argv);
return 0;
}
-
VM_C_API void start_standalone_factor(int argc, vm_char **argv)
{
- factorvm *newvm = new factorvm;
+ factor_vm *newvm = new factor_vm;
vm = newvm;
register_vm_with_thread(newvm);
return newvm->start_standalone_factor(argc,argv);
{
/* Certain special objects in the image are known to the runtime */
-void factorvm::init_objects(image_header *h)
+void factor_vm::init_objects(image_header *h)
{
memcpy(userenv,h->userenv,sizeof(userenv));
bignum_neg_one = h->bignum_neg_one;
}
-
-
-void factorvm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
+void factor_vm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
{
cell good_size = h->data_size + (1 << 20);
data_relocation_base = h->data_relocation_base;
}
-
-
-void factorvm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
+void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
{
if(h->code_size > p->code_size)
fatal_error("Code heap too small to fit image",h->code_size);
build_free_list(&code,h->code_size);
}
-
/* Save the current image to disk */
-bool factorvm::save_image(const vm_char *filename)
+bool factor_vm::save_image(const vm_char *filename)
{
FILE* file;
image_header h;
return ok;
}
-
-inline void factorvm::vmprim_save_image()
+inline void factor_vm::primitive_save_image()
{
/* do a full GC to push everything into tenured space */
gc();
PRIMITIVE(save_image)
{
- PRIMITIVE_GETVM()->vmprim_save_image();
+ PRIMITIVE_GETVM()->primitive_save_image();
}
-inline void factorvm::vmprim_save_image_and_exit()
+inline void factor_vm::primitive_save_image_and_exit()
{
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
PRIMITIVE(save_image_and_exit)
{
- PRIMITIVE_GETVM()->vmprim_save_image_and_exit();
+ PRIMITIVE_GETVM()->primitive_save_image_and_exit();
}
-void factorvm::data_fixup(cell *cell)
+void factor_vm::data_fixup(cell *cell)
{
if(immediate_p(*cell))
return;
*cell += (tenured->start - data_relocation_base);
}
-void data_fixup(cell *cell, factorvm *myvm)
+void data_fixup(cell *cell, factor_vm *myvm)
{
return myvm->data_fixup(cell);
}
-template <typename TYPE> void factorvm::code_fixup(TYPE **handle)
+template <typename TYPE> void factor_vm::code_fixup(TYPE **handle)
{
TYPE *ptr = *handle;
TYPE *new_ptr = (TYPE *)(((cell)ptr) + (code.seg->start - code_relocation_base));
*handle = new_ptr;
}
-
-void factorvm::fixup_word(word *word)
+void factor_vm::fixup_word(word *word)
{
if(word->code)
code_fixup(&word->code);
code_fixup(&word->xt);
}
-
-void factorvm::fixup_quotation(quotation *quot)
+void factor_vm::fixup_quotation(quotation *quot)
{
if(quot->code)
{
quot->xt = (void *)lazy_jit_compile;
}
-
-void factorvm::fixup_alien(alien *d)
+void factor_vm::fixup_alien(alien *d)
{
d->expired = T;
}
-
-void factorvm::fixup_stack_frame(stack_frame *frame)
+void factor_vm::fixup_stack_frame(stack_frame *frame)
{
code_fixup(&frame->xt);
code_fixup(&FRAME_RETURN_ADDRESS(frame));
}
-void fixup_stack_frame(stack_frame *frame, factorvm *myvm)
+void fixup_stack_frame(stack_frame *frame, factor_vm *myvm)
{
return myvm->fixup_stack_frame(frame);
}
-void factorvm::fixup_callstack_object(callstack *stack)
+void factor_vm::fixup_callstack_object(callstack *stack)
{
iterate_callstack_object(stack,factor::fixup_stack_frame);
}
-
/* Initialize an object in a newly-loaded image */
-void factorvm::relocate_object(object *object)
+void factor_vm::relocate_object(object *object)
{
cell hi_tag = object->h.hi_tag();
}
}
-
/* Since the image might have been saved with a different base address than
where it is loaded, we need to fix up pointers in the image. */
-void factorvm::relocate_data()
+void factor_vm::relocate_data()
{
cell relocating;
}
}
-
-void factorvm::fixup_code_block(code_block *compiled)
+void factor_vm::fixup_code_block(code_block *compiled)
{
/* relocate literal table data */
data_fixup(&compiled->relocation);
relocate_code_block(compiled);
}
-void fixup_code_block(code_block *compiled,factorvm *myvm)
+void fixup_code_block(code_block *compiled, factor_vm *myvm)
{
return myvm->fixup_code_block(compiled);
}
-void factorvm::relocate_code()
+void factor_vm::relocate_code()
{
iterate_code_heap(factor::fixup_code_block);
}
-
/* Read an image file from disk, only done once during startup */
/* This function also initializes the data and code heaps */
-void factorvm::load_image(vm_parameters *p)
+void factor_vm::load_image(vm_parameters *p)
{
FILE *file = OPEN_READ(p->image_path);
if(file == NULL)
userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path);
}
-
}
namespace factor
{
-
-void factorvm::init_inline_caching(int max_size)
+void factor_vm::init_inline_caching(int max_size)
{
max_pic_size = max_size;
}
-void factorvm::deallocate_inline_cache(cell return_address)
+void factor_vm::deallocate_inline_cache(cell return_address)
{
/* Find the call target. */
void *old_xt = get_call_target(return_address);
/* Figure out what kind of type check the PIC needs based on the methods
it contains */
-cell factorvm::determine_inline_cache_type(array *cache_entries)
+cell factor_vm::determine_inline_cache_type(array *cache_entries)
{
bool seen_hi_tag = false, seen_tuple = false;
return 0;
}
-void factorvm::update_pic_count(cell type)
+void factor_vm::update_pic_count(cell type)
{
pic_counts[type - PIC_TAG]++;
}
struct inline_cache_jit : public jit {
fixnum index;
- inline_cache_jit(cell generic_word_,factorvm *vm) : jit(PIC_TYPE,generic_word_,vm) {};
+ inline_cache_jit(cell generic_word_,factor_vm *vm) : jit(PIC_TYPE,generic_word_,vm) {};
void emit_check(cell klass);
void compile_inline_cache(fixnum index,
{
cell code_template;
if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
- code_template = myvm->userenv[PIC_CHECK_TAG];
+ code_template = parent_vm->userenv[PIC_CHECK_TAG];
else
- code_template = myvm->userenv[PIC_CHECK];
+ code_template = parent_vm->userenv[PIC_CHECK];
emit_with(code_template,klass);
}
cell cache_entries_,
bool tail_call_p)
{
- gc_root<word> generic_word(generic_word_,myvm);
- gc_root<array> methods(methods_,myvm);
- gc_root<array> cache_entries(cache_entries_,myvm);
+ 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);
- cell inline_cache_type = myvm->determine_inline_cache_type(cache_entries.untagged());
- myvm->update_pic_count(inline_cache_type);
+ cell inline_cache_type = parent_vm->determine_inline_cache_type(cache_entries.untagged());
+ parent_vm->update_pic_count(inline_cache_type);
/* Generate machine code to determine the object's class. */
emit_class_lookup(index,inline_cache_type);
/* Yes? Jump to method */
cell method = array_nth(cache_entries.untagged(),i + 1);
- emit_with(myvm->userenv[PIC_HIT],method);
+ emit_with(parent_vm->userenv[PIC_HIT],method);
}
/* Generate machine code to handle a cache miss, which ultimately results in
push(methods.value());
push(tag_fixnum(index));
push(cache_entries.value());
- word_special(myvm->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
+ word_special(parent_vm->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
}
-code_block *factorvm::compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p)
+code_block *factor_vm::compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p)
{
gc_root<word> generic_word(generic_word_,this);
gc_root<array> methods(methods_,this);
}
/* A generic word's definition performs general method lookup. Allocates memory */
-void *factorvm::megamorphic_call_stub(cell generic_word)
+void *factor_vm::megamorphic_call_stub(cell generic_word)
{
return untag<word>(generic_word)->xt;
}
-cell factorvm::inline_cache_size(cell cache_entries)
+cell factor_vm::inline_cache_size(cell cache_entries)
{
return array_capacity(untag_check<array>(cache_entries)) / 2;
}
/* Allocates memory */
-cell factorvm::add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_)
+cell factor_vm::add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_)
{
gc_root<array> cache_entries(cache_entries_,this);
gc_root<object> klass(klass_,this);
return new_cache_entries.value();
}
-void factorvm::update_pic_transitions(cell pic_size)
+void factor_vm::update_pic_transitions(cell pic_size)
{
if(pic_size == max_pic_size)
pic_to_mega_transitions++;
/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss).
Called from assembly with the actual return address */
-void *factorvm::inline_cache_miss(cell return_address)
+void *factor_vm::inline_cache_miss(cell return_address)
{
check_code_pointer(return_address);
return xt;
}
-VM_C_API void *inline_cache_miss(cell return_address, factorvm *myvm)
+VM_C_API void *inline_cache_miss(cell return_address, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->inline_cache_miss(return_address);
}
-
-inline void factorvm::vmprim_reset_inline_cache_stats()
+inline void factor_vm::primitive_reset_inline_cache_stats()
{
cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0;
cell i;
PRIMITIVE(reset_inline_cache_stats)
{
- PRIMITIVE_GETVM()->vmprim_reset_inline_cache_stats();
+ PRIMITIVE_GETVM()->primitive_reset_inline_cache_stats();
}
-inline void factorvm::vmprim_inline_cache_stats()
+inline void factor_vm::primitive_inline_cache_stats()
{
growable_array stats(this);
stats.add(allot_cell(cold_call_to_ic_transitions));
PRIMITIVE(inline_cache_stats)
{
- PRIMITIVE_GETVM()->vmprim_inline_cache_stats();
+ PRIMITIVE_GETVM()->primitive_inline_cache_stats();
}
}
PRIMITIVE(inline_cache_miss);
PRIMITIVE(inline_cache_miss_tail);
-VM_C_API void *inline_cache_miss(cell return_address, factorvm *vm);
+VM_C_API void *inline_cache_miss(cell return_address, factor_vm *vm);
}
// segments.hpp
-inline cell factorvm::align_page(cell a)
+inline cell factor_vm::align_page(cell a)
{
return align(a,getpagesize());
}
// write_barrier.hpp
-inline card *factorvm::addr_to_card(cell a)
+inline card *factor_vm::addr_to_card(cell a)
{
return (card*)(((cell)(a) >> card_bits) + cards_offset);
}
-
-inline cell factorvm::card_to_addr(card *c)
+inline cell factor_vm::card_to_addr(card *c)
{
return ((cell)c - cards_offset) << card_bits;
}
-
-inline cell factorvm::card_offset(card *c)
+inline cell factor_vm::card_offset(card *c)
{
return *(c - (cell)data->cards + (cell)data->allot_markers);
}
-inline card_deck *factorvm::addr_to_deck(cell a)
+inline card_deck *factor_vm::addr_to_deck(cell a)
{
return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
}
-inline cell factorvm::deck_to_addr(card_deck *c)
+inline cell factor_vm::deck_to_addr(card_deck *c)
{
return ((cell)c - decks_offset) << deck_bits;
}
-inline card *factorvm::deck_to_card(card_deck *d)
+inline card *factor_vm::deck_to_card(card_deck *d)
{
return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
}
-inline card *factorvm::addr_to_allot_marker(object *a)
+inline card *factor_vm::addr_to_allot_marker(object *a)
{
return (card *)(((cell)a >> card_bits) + allot_markers_offset);
}
/* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */
-inline void factorvm::write_barrier(object *obj)
+inline void factor_vm::write_barrier(object *obj)
{
*addr_to_card((cell)obj) = card_mark_mask;
*addr_to_deck((cell)obj) = card_mark_mask;
}
/* we need to remember the first object allocated in the card */
-inline void factorvm::allot_barrier(object *address)
+inline void factor_vm::allot_barrier(object *address)
{
card *ptr = addr_to_allot_marker(address);
if(*ptr == invalid_allot_marker)
*ptr = ((cell)address & addr_card_mask);
}
-
//data_gc.hpp
-inline bool factorvm::collecting_accumulation_gen_p()
+inline bool factor_vm::collecting_accumulation_gen_p()
{
return ((data->have_aging_p()
&& collecting_gen == data->aging()
|| collecting_gen == data->tenured());
}
-inline object *factorvm::allot_zone(zone *z, cell a)
+inline object *factor_vm::allot_zone(zone *z, cell a)
{
cell h = z->here;
z->here = h + align8(a);
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
-inline object *factorvm::allot_object(header header, cell size)
+inline object *factor_vm::allot_object(header header, cell size)
{
#ifdef GC_DEBUG
if(!gc_off)
return obj;
}
-template<typename TYPE> TYPE *factorvm::allot(cell size)
+template<typename TYPE> TYPE *factor_vm::allot(cell size)
{
return (TYPE *)allot_object(header(TYPE::type_number),size);
}
-inline void factorvm::check_data_pointer(object *pointer)
+inline void factor_vm::check_data_pointer(object *pointer)
{
#ifdef FACTOR_DEBUG
if(!growing_data_heap)
#endif
}
-inline void factorvm::check_tagged_pointer(cell tagged)
+inline void factor_vm::check_tagged_pointer(cell tagged)
{
#ifdef FACTOR_DEBUG
if(!immediate_p(tagged))
template <typename TYPE>
struct gc_root : public tagged<TYPE>
{
- factorvm *myvm;
+ factor_vm *parent_vm;
- void push() { myvm->check_tagged_pointer(tagged<TYPE>::value()); myvm->gc_locals.push_back((cell)this); }
+ void push() { parent_vm->check_tagged_pointer(tagged<TYPE>::value()); parent_vm->gc_locals.push_back((cell)this); }
- explicit gc_root(cell value_,factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
- explicit gc_root(TYPE *value_, factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
+ 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(); }
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; }
#ifdef FACTOR_DEBUG
assert(myvm->gc_locals.back() == (cell)this);
#endif
- myvm->gc_locals.pop_back();
+ parent_vm->gc_locals.pop_back();
}
};
struct gc_bignum
{
bignum **addr;
- factorvm *myvm;
- gc_bignum(bignum **addr_, factorvm *vm) : addr(addr_), myvm(vm) {
+ factor_vm *parent_vm;
+ gc_bignum(bignum **addr_, factor_vm *vm) : addr(addr_), parent_vm(vm) {
if(*addr_)
- myvm->check_data_pointer(*addr_);
- myvm->gc_bignums.push_back((cell)addr);
+ parent_vm->check_data_pointer(*addr_);
+ parent_vm->gc_bignums.push_back((cell)addr);
}
~gc_bignum() {
#ifdef FACTOR_DEBUG
assert(myvm->gc_bignums.back() == (cell)addr);
#endif
- myvm->gc_bignums.pop_back();
+ parent_vm->gc_bignums.pop_back();
}
};
-#define GC_BIGNUM(x,vm) gc_bignum x##__gc_root(&x,vm)
+#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x,this)
//generic_arrays.hpp
-template <typename TYPE> TYPE *factorvm::allot_array_internal(cell capacity)
+template <typename TYPE> TYPE *factor_vm::allot_array_internal(cell capacity)
{
TYPE *array = allot<TYPE>(array_size<TYPE>(capacity));
array->capacity = tag_fixnum(capacity);
return array;
}
-template <typename TYPE> bool factorvm::reallot_array_in_place_p(TYPE *array, cell capacity)
+template <typename TYPE> bool factor_vm::reallot_array_in_place_p(TYPE *array, cell capacity)
{
return in_zone(&nursery,array) && capacity <= array_capacity(array);
}
-template <typename TYPE> TYPE *factorvm::reallot_array(TYPE *array_, cell capacity)
+template <typename TYPE> TYPE *factor_vm::reallot_array(TYPE *array_, cell capacity)
{
gc_root<TYPE> array(array_,this);
}
//arrays.hpp
-inline void factorvm::set_array_nth(array *array, cell slot, cell value)
+inline void factor_vm::set_array_nth(array *array, cell slot, cell value)
{
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
cell count;
gc_root<array> elements;
- growable_array(factorvm *myvm, cell capacity = 10) : count(0), elements(myvm->allot_array(capacity,F),myvm) {}
+ growable_array(factor_vm *myvm, cell capacity = 10) : count(0), elements(myvm->allot_array(capacity,F),myvm) {}
void add(cell elt);
void trim();
cell count;
gc_root<byte_array> elements;
- growable_byte_array(factorvm *myvm,cell capacity = 40) : count(0), elements(myvm->allot_byte_array(capacity),myvm) { }
+ growable_byte_array(factor_vm *myvm,cell capacity = 40) : count(0), elements(myvm->allot_byte_array(capacity),myvm) { }
void append_bytes(void *elts, cell len);
void append_byte_array(cell elts);
};
//math.hpp
-inline cell factorvm::allot_integer(fixnum x)
+inline cell factor_vm::allot_integer(fixnum x)
{
if(x < fixnum_min || x > fixnum_max)
return tag<bignum>(fixnum_to_bignum(x));
return tag_fixnum(x);
}
-inline cell factorvm::allot_cell(cell x)
+inline cell factor_vm::allot_cell(cell x)
{
if(x > (cell)fixnum_max)
return tag<bignum>(cell_to_bignum(x));
return tag_fixnum(x);
}
-inline cell factorvm::allot_float(double n)
+inline cell factor_vm::allot_float(double n)
{
boxed_float *flo = allot<boxed_float>(sizeof(boxed_float));
flo->n = n;
return tag(flo);
}
-inline bignum *factorvm::float_to_bignum(cell tagged)
+inline bignum *factor_vm::float_to_bignum(cell tagged)
{
return double_to_bignum(untag_float(tagged));
}
-inline double factorvm::bignum_to_float(cell tagged)
+inline double factor_vm::bignum_to_float(cell tagged)
{
return bignum_to_double(untag<bignum>(tagged));
}
-inline double factorvm::untag_float(cell tagged)
+inline double factor_vm::untag_float(cell tagged)
{
return untag<boxed_float>(tagged)->n;
}
-inline double factorvm::untag_float_check(cell tagged)
+inline double factor_vm::untag_float_check(cell tagged)
{
return untag_check<boxed_float>(tagged)->n;
}
-inline fixnum factorvm::float_to_fixnum(cell tagged)
+inline fixnum factor_vm::float_to_fixnum(cell tagged)
{
return (fixnum)untag_float(tagged);
}
-inline double factorvm::fixnum_to_float(cell tagged)
+inline double factor_vm::fixnum_to_float(cell tagged)
{
return (double)untag_fixnum(tagged);
}
//callstack.hpp
/* This is a little tricky. The iterator may allocate memory, so we
keep the callstack in a GC root and use relative offsets */
-template<typename TYPE> void factorvm::iterate_callstack_object(callstack *stack_, TYPE &iterator)
+template<typename TYPE> void factor_vm::iterate_callstack_object(callstack *stack_, TYPE &iterator)
{
gc_root<callstack> stack(stack_,this);
fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
}
//booleans.hpp
-inline cell factorvm::tag_boolean(cell untagged)
+inline cell factor_vm::tag_boolean(cell untagged)
{
return (untagged ? T : F);
}
// callstack.hpp
-template<typename TYPE> void factorvm::iterate_callstack(cell top, cell bottom, TYPE &iterator)
+template<typename TYPE> void factor_vm::iterate_callstack(cell top, cell bottom, TYPE &iterator)
{
stack_frame *frame = (stack_frame *)bottom - 1;
}
}
-
// data_heap.hpp
/* Every object has a regular representation in the runtime, which makes GC
much simpler. Every slot of the object until binary_payload_start is a pointer
to some other object. */
-struct factorvm;
-inline void factorvm::do_slots(cell obj, void (* iter)(cell *,factorvm*))
+struct factor_vm;
+inline void factor_vm::do_slots(cell obj, void (* iter)(cell *,factor_vm*))
{
cell scan = obj;
cell payload_start = binary_payload_start((object *)obj);
// code_heap.hpp
-inline void factorvm::check_code_pointer(cell ptr)
+inline void factor_vm::check_code_pointer(cell ptr)
{
#ifdef FACTOR_DEBUG
assert(in_code_heap_p(ptr));
with many more capabilities so these words are not usually used in
normal operation. */
-void factorvm::init_c_io()
+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);
}
-
-void factorvm::io_error()
+void factor_vm::io_error()
{
#ifndef WINCE
if(errno == EINTR)
general_error(ERROR_IO,tag_fixnum(errno),F,NULL);
}
-
-inline void factorvm::vmprim_fopen()
+inline void factor_vm::primitive_fopen()
{
gc_root<byte_array> mode(dpop(),this);
gc_root<byte_array> path(dpop(),this);
PRIMITIVE(fopen)
{
- PRIMITIVE_GETVM()->vmprim_fopen();
+ PRIMITIVE_GETVM()->primitive_fopen();
}
-inline void factorvm::vmprim_fgetc()
+inline void factor_vm::primitive_fgetc()
{
FILE *file = (FILE *)unbox_alien();
PRIMITIVE(fgetc)
{
- PRIMITIVE_GETVM()->vmprim_fgetc();
+ PRIMITIVE_GETVM()->primitive_fgetc();
}
-inline void factorvm::vmprim_fread()
+inline void factor_vm::primitive_fread()
{
FILE *file = (FILE *)unbox_alien();
fixnum size = unbox_array_size();
PRIMITIVE(fread)
{
- PRIMITIVE_GETVM()->vmprim_fread();
+ PRIMITIVE_GETVM()->primitive_fread();
}
-inline void factorvm::vmprim_fputc()
+inline void factor_vm::primitive_fputc()
{
FILE *file = (FILE *)unbox_alien();
fixnum ch = to_fixnum(dpop());
PRIMITIVE(fputc)
{
- PRIMITIVE_GETVM()->vmprim_fputc();
+ PRIMITIVE_GETVM()->primitive_fputc();
}
-inline void factorvm::vmprim_fwrite()
+inline void factor_vm::primitive_fwrite()
{
FILE *file = (FILE *)unbox_alien();
byte_array *text = untag_check<byte_array>(dpop());
PRIMITIVE(fwrite)
{
- PRIMITIVE_GETVM()->vmprim_fwrite();
+ PRIMITIVE_GETVM()->primitive_fwrite();
}
-inline void factorvm::vmprim_fseek()
+inline void factor_vm::primitive_fseek()
{
int whence = to_fixnum(dpop());
FILE *file = (FILE *)unbox_alien();
PRIMITIVE(fseek)
{
- PRIMITIVE_GETVM()->vmprim_fseek();
+ PRIMITIVE_GETVM()->primitive_fseek();
}
-inline void factorvm::vmprim_fflush()
+inline void factor_vm::primitive_fflush()
{
FILE *file = (FILE *)unbox_alien();
for(;;)
PRIMITIVE(fflush)
{
- PRIMITIVE_GETVM()->vmprim_fflush();
+ PRIMITIVE_GETVM()->primitive_fflush();
}
-inline void factorvm::vmprim_fclose()
+inline void factor_vm::primitive_fclose()
{
FILE *file = (FILE *)unbox_alien();
for(;;)
PRIMITIVE(fclose)
{
- PRIMITIVE_GETVM()->vmprim_fclose();
+ PRIMITIVE_GETVM()->primitive_fclose();
}
/* This function is used by FFI I/O. Accessing the errno global directly is
- polymorphic inline caches (inline_cache.cpp) */
/* Allocates memory */
-jit::jit(cell type_, cell owner_, factorvm *vm)
+jit::jit(cell type_, cell owner_, factor_vm *vm)
: type(type_),
owner(owner_,vm),
code(vm),
computing_offset_p(false),
position(0),
offset(0),
- myvm(vm)
+ parent_vm(vm)
{
- if(myvm->stack_traces_p()) literal(owner.value());
+ if(parent_vm->stack_traces_p()) literal(owner.value());
}
void jit::emit_relocation(cell code_template_)
{
- gc_root<array> code_template(code_template_,myvm);
+ gc_root<array> code_template(code_template_,parent_vm);
cell capacity = array_capacity(code_template.untagged());
for(cell i = 1; i < capacity; i += 3)
{
/* Allocates memory */
void jit::emit(cell code_template_)
{
- gc_root<array> code_template(code_template_,myvm);
+ gc_root<array> code_template(code_template_,parent_vm);
emit_relocation(code_template.value());
- gc_root<byte_array> insns(array_nth(code_template.untagged(),0),myvm);
+ gc_root<byte_array> insns(array_nth(code_template.untagged(),0),parent_vm);
if(computing_offset_p)
{
}
void jit::emit_with(cell code_template_, cell argument_) {
- gc_root<array> code_template(code_template_,myvm);
- gc_root<object> argument(argument_,myvm);
+ gc_root<array> code_template(code_template_,parent_vm);
+ gc_root<object> argument(argument_,parent_vm);
literal(argument.value());
emit(code_template.value());
}
void jit::emit_class_lookup(fixnum index, cell type)
{
- emit_with(myvm->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
- emit(myvm->userenv[type]);
+ emit_with(parent_vm->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
+ emit(parent_vm->userenv[type]);
}
/* Facility to convert compiled code offsets to quotation offsets.
relocation.trim();
literals.trim();
- return myvm->add_code_block(
+ return parent_vm->add_code_block(
type,
code.elements.value(),
F, /* no labels */
bool computing_offset_p;
fixnum position;
cell offset;
- factorvm *myvm;
+ factor_vm *parent_vm;
- jit(cell jit_type, cell owner, factorvm *vm);
+ jit(cell jit_type, cell owner, factor_vm *vm);
void compute_position(cell offset);
void emit_relocation(cell code_template);
void emit_with(cell code_template_, cell literal_);
void push(cell literal) {
- emit_with(myvm->userenv[JIT_PUSH_IMMEDIATE],literal);
+ emit_with(parent_vm->userenv[JIT_PUSH_IMMEDIATE],literal);
}
void word_jump(cell word) {
literal(tag_fixnum(xt_tail_pic_offset));
literal(word);
- emit(myvm->userenv[JIT_WORD_JUMP]);
+ emit(parent_vm->userenv[JIT_WORD_JUMP]);
}
void word_call(cell word) {
- emit_with(myvm->userenv[JIT_WORD_CALL],word);
+ emit_with(parent_vm->userenv[JIT_WORD_CALL],word);
}
void word_special(cell word) {
- emit_with(myvm->userenv[JIT_WORD_SPECIAL],word);
+ emit_with(parent_vm->userenv[JIT_WORD_SPECIAL],word);
}
void emit_subprimitive(cell word_) {
- gc_root<word> word(word_,myvm);
- gc_root<array> code_template(word->subprimitive,myvm);
- if(array_capacity(code_template.untagged()) > 1) literal(myvm->T);
+ gc_root<word> word(word_,parent_vm);
+ gc_root<array> code_template(word->subprimitive,parent_vm);
+ if(array_capacity(code_template.untagged()) > 1) literal(parent_vm->T);
emit(code_template.value());
}
/* Modify a suspended thread's thread_state so that when the thread resumes
executing, the call frame of the current C primitive (if any) is rewound, and
the appropriate Factor error is thrown from the top-most Factor frame. */
-void factorvm::call_fault_handler(
+void factor_vm::call_fault_handler(
exception_type_t exception,
exception_data_type_t code,
MACH_EXC_STATE_TYPE *exc_state,
return KERN_SUCCESS;
}
-
/* The main function of the thread listening for exceptions. */
static void *
mach_exception_thread (void *arg)
exception thread directly. */
extern "C" boolean_t exc_server (mach_msg_header_t *request_msg, mach_msg_header_t *reply_msg);
-
/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/catch_exception_raise.html
These functions are defined in this file, and called by exc_server.
FIXME: What needs to be done when this code is put into a shared library? */
#include "factor.hpp"
#include "utilities.hpp"
-
-
#endif /* __FACTOR_MASTER_H__ */
namespace factor
{
-inline void factorvm::vmprim_bignum_to_fixnum()
+inline void factor_vm::primitive_bignum_to_fixnum()
{
drepl(tag_fixnum(bignum_to_fixnum(untag<bignum>(dpeek()))));
}
PRIMITIVE(bignum_to_fixnum)
{
- PRIMITIVE_GETVM()->vmprim_bignum_to_fixnum();
+ PRIMITIVE_GETVM()->primitive_bignum_to_fixnum();
}
-inline void factorvm::vmprim_float_to_fixnum()
+inline void factor_vm::primitive_float_to_fixnum()
{
drepl(tag_fixnum(float_to_fixnum(dpeek())));
}
PRIMITIVE(float_to_fixnum)
{
- PRIMITIVE_GETVM()->vmprim_float_to_fixnum();
+ PRIMITIVE_GETVM()->primitive_float_to_fixnum();
}
/* Division can only overflow when we are dividing the most negative fixnum
by -1. */
-inline void factorvm::vmprim_fixnum_divint()
+inline void factor_vm::primitive_fixnum_divint()
{
fixnum y = untag_fixnum(dpop()); \
fixnum x = untag_fixnum(dpeek());
PRIMITIVE(fixnum_divint)
{
- PRIMITIVE_GETVM()->vmprim_fixnum_divint();
+ PRIMITIVE_GETVM()->primitive_fixnum_divint();
}
-inline void factorvm::vmprim_fixnum_divmod()
+inline void factor_vm::primitive_fixnum_divmod()
{
cell y = ((cell *)ds)[0];
cell x = ((cell *)ds)[-1];
PRIMITIVE(fixnum_divmod)
{
- PRIMITIVE_GETVM()->vmprim_fixnum_divmod();
+ PRIMITIVE_GETVM()->primitive_fixnum_divmod();
}
/*
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
-inline fixnum factorvm::sign_mask(fixnum x)
+inline fixnum factor_vm::sign_mask(fixnum x)
{
return x >> (WORD_SIZE - 1);
}
-
-inline fixnum factorvm::branchless_max(fixnum x, fixnum y)
+inline fixnum factor_vm::branchless_max(fixnum x, fixnum y)
{
return (x - ((x - y) & sign_mask(x - y)));
}
-
-inline fixnum factorvm::branchless_abs(fixnum x)
+inline fixnum factor_vm::branchless_abs(fixnum x)
{
return (x ^ sign_mask(x)) - sign_mask(x);
}
-
-inline void factorvm::vmprim_fixnum_shift()
+inline void factor_vm::primitive_fixnum_shift()
{
fixnum y = untag_fixnum(dpop());
fixnum x = untag_fixnum(dpeek());
PRIMITIVE(fixnum_shift)
{
- PRIMITIVE_GETVM()->vmprim_fixnum_shift();
+ PRIMITIVE_GETVM()->primitive_fixnum_shift();
}
-inline void factorvm::vmprim_fixnum_to_bignum()
+inline void factor_vm::primitive_fixnum_to_bignum()
{
drepl(tag<bignum>(fixnum_to_bignum(untag_fixnum(dpeek()))));
}
PRIMITIVE(fixnum_to_bignum)
{
- PRIMITIVE_GETVM()->vmprim_fixnum_to_bignum();
+ PRIMITIVE_GETVM()->primitive_fixnum_to_bignum();
}
-inline void factorvm::vmprim_float_to_bignum()
+inline void factor_vm::primitive_float_to_bignum()
{
drepl(tag<bignum>(float_to_bignum(dpeek())));
}
PRIMITIVE(float_to_bignum)
{
- PRIMITIVE_GETVM()->vmprim_float_to_bignum();
+ PRIMITIVE_GETVM()->primitive_float_to_bignum();
}
#define POP_BIGNUMS(x,y) \
bignum * y = untag<bignum>(dpop()); \
bignum * x = untag<bignum>(dpop());
-inline void factorvm::vmprim_bignum_eq()
+inline void factor_vm::primitive_bignum_eq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_equal_p(x,y));
PRIMITIVE(bignum_eq)
{
- PRIMITIVE_GETVM()->vmprim_bignum_eq();
+ PRIMITIVE_GETVM()->primitive_bignum_eq();
}
-inline void factorvm::vmprim_bignum_add()
+inline void factor_vm::primitive_bignum_add()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_add(x,y)));
PRIMITIVE(bignum_add)
{
- PRIMITIVE_GETVM()->vmprim_bignum_add();
+ PRIMITIVE_GETVM()->primitive_bignum_add();
}
-inline void factorvm::vmprim_bignum_subtract()
+inline void factor_vm::primitive_bignum_subtract()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_subtract(x,y)));
PRIMITIVE(bignum_subtract)
{
- PRIMITIVE_GETVM()->vmprim_bignum_subtract();
+ PRIMITIVE_GETVM()->primitive_bignum_subtract();
}
-inline void factorvm::vmprim_bignum_multiply()
+inline void factor_vm::primitive_bignum_multiply()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_multiply(x,y)));
PRIMITIVE(bignum_multiply)
{
- PRIMITIVE_GETVM()->vmprim_bignum_multiply();
+ PRIMITIVE_GETVM()->primitive_bignum_multiply();
}
-inline void factorvm::vmprim_bignum_divint()
+inline void factor_vm::primitive_bignum_divint()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_quotient(x,y)));
PRIMITIVE(bignum_divint)
{
- PRIMITIVE_GETVM()->vmprim_bignum_divint();
+ PRIMITIVE_GETVM()->primitive_bignum_divint();
}
-inline void factorvm::vmprim_bignum_divmod()
+inline void factor_vm::primitive_bignum_divmod()
{
bignum *q, *r;
POP_BIGNUMS(x,y);
PRIMITIVE(bignum_divmod)
{
- PRIMITIVE_GETVM()->vmprim_bignum_divmod();
+ PRIMITIVE_GETVM()->primitive_bignum_divmod();
}
-inline void factorvm::vmprim_bignum_mod()
+inline void factor_vm::primitive_bignum_mod()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_remainder(x,y)));
PRIMITIVE(bignum_mod)
{
- PRIMITIVE_GETVM()->vmprim_bignum_mod();
+ PRIMITIVE_GETVM()->primitive_bignum_mod();
}
-inline void factorvm::vmprim_bignum_and()
+inline void factor_vm::primitive_bignum_and()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_and(x,y)));
PRIMITIVE(bignum_and)
{
- PRIMITIVE_GETVM()->vmprim_bignum_and();
+ PRIMITIVE_GETVM()->primitive_bignum_and();
}
-inline void factorvm::vmprim_bignum_or()
+inline void factor_vm::primitive_bignum_or()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_ior(x,y)));
PRIMITIVE(bignum_or)
{
- PRIMITIVE_GETVM()->vmprim_bignum_or();
+ PRIMITIVE_GETVM()->primitive_bignum_or();
}
-inline void factorvm::vmprim_bignum_xor()
+inline void factor_vm::primitive_bignum_xor()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_xor(x,y)));
PRIMITIVE(bignum_xor)
{
- PRIMITIVE_GETVM()->vmprim_bignum_xor();
+ PRIMITIVE_GETVM()->primitive_bignum_xor();
}
-inline void factorvm::vmprim_bignum_shift()
+inline void factor_vm::primitive_bignum_shift()
{
fixnum y = untag_fixnum(dpop());
bignum* x = untag<bignum>(dpop());
PRIMITIVE(bignum_shift)
{
- PRIMITIVE_GETVM()->vmprim_bignum_shift();
+ PRIMITIVE_GETVM()->primitive_bignum_shift();
}
-inline void factorvm::vmprim_bignum_less()
+inline void factor_vm::primitive_bignum_less()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_less);
PRIMITIVE(bignum_less)
{
- PRIMITIVE_GETVM()->vmprim_bignum_less();
+ PRIMITIVE_GETVM()->primitive_bignum_less();
}
-inline void factorvm::vmprim_bignum_lesseq()
+inline void factor_vm::primitive_bignum_lesseq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
PRIMITIVE(bignum_lesseq)
{
- PRIMITIVE_GETVM()->vmprim_bignum_lesseq();
+ PRIMITIVE_GETVM()->primitive_bignum_lesseq();
}
-inline void factorvm::vmprim_bignum_greater()
+inline void factor_vm::primitive_bignum_greater()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
PRIMITIVE(bignum_greater)
{
- PRIMITIVE_GETVM()->vmprim_bignum_greater();
+ PRIMITIVE_GETVM()->primitive_bignum_greater();
}
-inline void factorvm::vmprim_bignum_greatereq()
+inline void factor_vm::primitive_bignum_greatereq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_less);
PRIMITIVE(bignum_greatereq)
{
- PRIMITIVE_GETVM()->vmprim_bignum_greatereq();
+ PRIMITIVE_GETVM()->primitive_bignum_greatereq();
}
-inline void factorvm::vmprim_bignum_not()
+inline void factor_vm::primitive_bignum_not()
{
drepl(tag<bignum>(bignum_bitwise_not(untag<bignum>(dpeek()))));
}
PRIMITIVE(bignum_not)
{
- PRIMITIVE_GETVM()->vmprim_bignum_not();
+ PRIMITIVE_GETVM()->primitive_bignum_not();
}
-inline void factorvm::vmprim_bignum_bitp()
+inline void factor_vm::primitive_bignum_bitp()
{
fixnum bit = to_fixnum(dpop());
bignum *x = untag<bignum>(dpop());
PRIMITIVE(bignum_bitp)
{
- PRIMITIVE_GETVM()->vmprim_bignum_bitp();
+ PRIMITIVE_GETVM()->primitive_bignum_bitp();
}
-inline void factorvm::vmprim_bignum_log2()
+inline void factor_vm::primitive_bignum_log2()
{
drepl(tag<bignum>(bignum_integer_length(untag<bignum>(dpeek()))));
}
PRIMITIVE(bignum_log2)
{
- PRIMITIVE_GETVM()->vmprim_bignum_log2();
+ PRIMITIVE_GETVM()->primitive_bignum_log2();
}
-unsigned int factorvm::bignum_producer(unsigned int digit)
+unsigned int factor_vm::bignum_producer(unsigned int digit)
{
unsigned char *ptr = (unsigned char *)alien_offset(dpeek());
return *(ptr + digit);
}
-unsigned int bignum_producer(unsigned int digit, factorvm *myvm)
+unsigned int bignum_producer(unsigned int digit, factor_vm *myvm)
{
return myvm->bignum_producer(digit);
}
-inline void factorvm::vmprim_byte_array_to_bignum()
+inline void factor_vm::primitive_byte_array_to_bignum()
{
cell n_digits = array_capacity(untag_check<byte_array>(dpeek()));
- // bignum * result = factor::digit_stream_to_bignum(n_digits,factor::bignum_producer,0x100,0);
bignum * result = digit_stream_to_bignum(n_digits,factor::bignum_producer,0x100,0);
drepl(tag<bignum>(result));
}
PRIMITIVE(byte_array_to_bignum)
{
- PRIMITIVE_GETVM()->vmprim_byte_array_to_bignum();
+ PRIMITIVE_GETVM()->primitive_byte_array_to_bignum();
}
-cell factorvm::unbox_array_size()
+cell factor_vm::unbox_array_size()
{
switch(tagged<object>(dpeek()).type())
{
return 0; /* can't happen */
}
-
-inline void factorvm::vmprim_fixnum_to_float()
+inline void factor_vm::primitive_fixnum_to_float()
{
drepl(allot_float(fixnum_to_float(dpeek())));
}
PRIMITIVE(fixnum_to_float)
{
- PRIMITIVE_GETVM()->vmprim_fixnum_to_float();
+ PRIMITIVE_GETVM()->primitive_fixnum_to_float();
}
-inline void factorvm::vmprim_bignum_to_float()
+inline void factor_vm::primitive_bignum_to_float()
{
drepl(allot_float(bignum_to_float(dpeek())));
}
PRIMITIVE(bignum_to_float)
{
- PRIMITIVE_GETVM()->vmprim_bignum_to_float();
+ PRIMITIVE_GETVM()->primitive_bignum_to_float();
}
-inline void factorvm::vmprim_str_to_float()
+inline void factor_vm::primitive_str_to_float()
{
byte_array *bytes = untag_check<byte_array>(dpeek());
cell capacity = array_capacity(bytes);
PRIMITIVE(str_to_float)
{
- PRIMITIVE_GETVM()->vmprim_str_to_float();
+ PRIMITIVE_GETVM()->primitive_str_to_float();
}
-inline void factorvm::vmprim_float_to_str()
+inline void factor_vm::primitive_float_to_str()
{
byte_array *array = allot_byte_array(33);
snprintf((char *)(array + 1),32,"%.16g",untag_float_check(dpop()));
PRIMITIVE(float_to_str)
{
- PRIMITIVE_GETVM()->vmprim_float_to_str();
+ PRIMITIVE_GETVM()->primitive_float_to_str();
}
#define POP_FLOATS(x,y) \
double y = untag_float(dpop()); \
double x = untag_float(dpop());
-inline void factorvm::vmprim_float_eq()
+inline void factor_vm::primitive_float_eq()
{
POP_FLOATS(x,y);
box_boolean(x == y);
PRIMITIVE(float_eq)
{
- PRIMITIVE_GETVM()->vmprim_float_eq();
+ PRIMITIVE_GETVM()->primitive_float_eq();
}
-inline void factorvm::vmprim_float_add()
+inline void factor_vm::primitive_float_add()
{
POP_FLOATS(x,y);
box_double(x + y);
PRIMITIVE(float_add)
{
- PRIMITIVE_GETVM()->vmprim_float_add();
+ PRIMITIVE_GETVM()->primitive_float_add();
}
-inline void factorvm::vmprim_float_subtract()
+inline void factor_vm::primitive_float_subtract()
{
POP_FLOATS(x,y);
box_double(x - y);
PRIMITIVE(float_subtract)
{
- PRIMITIVE_GETVM()->vmprim_float_subtract();
+ PRIMITIVE_GETVM()->primitive_float_subtract();
}
-inline void factorvm::vmprim_float_multiply()
+inline void factor_vm::primitive_float_multiply()
{
POP_FLOATS(x,y);
box_double(x * y);
PRIMITIVE(float_multiply)
{
- PRIMITIVE_GETVM()->vmprim_float_multiply();
+ PRIMITIVE_GETVM()->primitive_float_multiply();
}
-inline void factorvm::vmprim_float_divfloat()
+inline void factor_vm::primitive_float_divfloat()
{
POP_FLOATS(x,y);
box_double(x / y);
PRIMITIVE(float_divfloat)
{
- PRIMITIVE_GETVM()->vmprim_float_divfloat();
+ PRIMITIVE_GETVM()->primitive_float_divfloat();
}
-inline void factorvm::vmprim_float_mod()
+inline void factor_vm::primitive_float_mod()
{
POP_FLOATS(x,y);
box_double(fmod(x,y));
PRIMITIVE(float_mod)
{
- PRIMITIVE_GETVM()->vmprim_float_mod();
+ PRIMITIVE_GETVM()->primitive_float_mod();
}
-inline void factorvm::vmprim_float_less()
+inline void factor_vm::primitive_float_less()
{
POP_FLOATS(x,y);
box_boolean(x < y);
PRIMITIVE(float_less)
{
- PRIMITIVE_GETVM()->vmprim_float_less();
+ PRIMITIVE_GETVM()->primitive_float_less();
}
-inline void factorvm::vmprim_float_lesseq()
+inline void factor_vm::primitive_float_lesseq()
{
POP_FLOATS(x,y);
box_boolean(x <= y);
PRIMITIVE(float_lesseq)
{
- PRIMITIVE_GETVM()->vmprim_float_lesseq();
+ PRIMITIVE_GETVM()->primitive_float_lesseq();
}
-inline void factorvm::vmprim_float_greater()
+inline void factor_vm::primitive_float_greater()
{
POP_FLOATS(x,y);
box_boolean(x > y);
PRIMITIVE(float_greater)
{
- PRIMITIVE_GETVM()->vmprim_float_greater();
+ PRIMITIVE_GETVM()->primitive_float_greater();
}
-inline void factorvm::vmprim_float_greatereq()
+inline void factor_vm::primitive_float_greatereq()
{
POP_FLOATS(x,y);
box_boolean(x >= y);
PRIMITIVE(float_greatereq)
{
- PRIMITIVE_GETVM()->vmprim_float_greatereq();
+ PRIMITIVE_GETVM()->primitive_float_greatereq();
}
-inline void factorvm::vmprim_float_bits()
+inline void factor_vm::primitive_float_bits()
{
box_unsigned_4(float_bits(untag_float_check(dpop())));
}
PRIMITIVE(float_bits)
{
- PRIMITIVE_GETVM()->vmprim_float_bits();
+ PRIMITIVE_GETVM()->primitive_float_bits();
}
-inline void factorvm::vmprim_bits_float()
+inline void factor_vm::primitive_bits_float()
{
box_float(bits_float(to_cell(dpop())));
}
PRIMITIVE(bits_float)
{
- PRIMITIVE_GETVM()->vmprim_bits_float();
+ PRIMITIVE_GETVM()->primitive_bits_float();
}
-inline void factorvm::vmprim_double_bits()
+inline void factor_vm::primitive_double_bits()
{
box_unsigned_8(double_bits(untag_float_check(dpop())));
}
PRIMITIVE(double_bits)
{
- PRIMITIVE_GETVM()->vmprim_double_bits();
+ PRIMITIVE_GETVM()->primitive_double_bits();
}
-inline void factorvm::vmprim_bits_double()
+inline void factor_vm::primitive_bits_double()
{
box_double(bits_double(to_unsigned_8(dpop())));
}
PRIMITIVE(bits_double)
{
- PRIMITIVE_GETVM()->vmprim_bits_double();
+ PRIMITIVE_GETVM()->primitive_bits_double();
}
-fixnum factorvm::to_fixnum(cell tagged)
+fixnum factor_vm::to_fixnum(cell tagged)
{
switch(TAG(tagged))
{
}
}
-VM_C_API fixnum to_fixnum(cell tagged,factorvm *myvm)
+VM_C_API fixnum to_fixnum(cell tagged,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_fixnum(tagged);
}
-cell factorvm::to_cell(cell tagged)
+cell factor_vm::to_cell(cell tagged)
{
return (cell)to_fixnum(tagged);
}
-VM_C_API cell to_cell(cell tagged, factorvm *myvm)
+VM_C_API cell to_cell(cell tagged, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_cell(tagged);
}
-void factorvm::box_signed_1(s8 n)
+void factor_vm::box_signed_1(s8 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_1(s8 n,factorvm *myvm)
+VM_C_API void box_signed_1(s8 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_signed_1(n);
}
-void factorvm::box_unsigned_1(u8 n)
+void factor_vm::box_unsigned_1(u8 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_1(u8 n,factorvm *myvm)
+VM_C_API void box_unsigned_1(u8 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_unsigned_1(n);
}
-void factorvm::box_signed_2(s16 n)
+void factor_vm::box_signed_2(s16 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_2(s16 n,factorvm *myvm)
+VM_C_API void box_signed_2(s16 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_signed_2(n);
}
-void factorvm::box_unsigned_2(u16 n)
+void factor_vm::box_unsigned_2(u16 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_2(u16 n,factorvm *myvm)
+VM_C_API void box_unsigned_2(u16 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_unsigned_2(n);
}
-void factorvm::box_signed_4(s32 n)
+void factor_vm::box_signed_4(s32 n)
{
dpush(allot_integer(n));
}
-VM_C_API void box_signed_4(s32 n,factorvm *myvm)
+VM_C_API void box_signed_4(s32 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_signed_4(n);
}
-void factorvm::box_unsigned_4(u32 n)
+void factor_vm::box_unsigned_4(u32 n)
{
dpush(allot_cell(n));
}
-VM_C_API void box_unsigned_4(u32 n,factorvm *myvm)
+VM_C_API void box_unsigned_4(u32 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_unsigned_4(n);
}
-void factorvm::box_signed_cell(fixnum integer)
+void factor_vm::box_signed_cell(fixnum integer)
{
dpush(allot_integer(integer));
}
-VM_C_API void box_signed_cell(fixnum integer,factorvm *myvm)
+VM_C_API void box_signed_cell(fixnum integer,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_signed_cell(integer);
}
-void factorvm::box_unsigned_cell(cell cell)
+void factor_vm::box_unsigned_cell(cell cell)
{
dpush(allot_cell(cell));
}
-VM_C_API void box_unsigned_cell(cell cell,factorvm *myvm)
+VM_C_API void box_unsigned_cell(cell cell,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_unsigned_cell(cell);
}
-void factorvm::box_signed_8(s64 n)
+void factor_vm::box_signed_8(s64 n)
{
if(n < fixnum_min || n > fixnum_max)
dpush(tag<bignum>(long_long_to_bignum(n)));
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_8(s64 n,factorvm *myvm)
+VM_C_API void box_signed_8(s64 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_signed_8(n);
}
-s64 factorvm::to_signed_8(cell obj)
+s64 factor_vm::to_signed_8(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-VM_C_API s64 to_signed_8(cell obj,factorvm *myvm)
+VM_C_API s64 to_signed_8(cell obj,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_signed_8(obj);
}
-void factorvm::box_unsigned_8(u64 n)
+void factor_vm::box_unsigned_8(u64 n)
{
if(n > (u64)fixnum_max)
dpush(tag<bignum>(ulong_long_to_bignum(n)));
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_8(u64 n,factorvm *myvm)
+VM_C_API void box_unsigned_8(u64 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_unsigned_8(n);
}
-u64 factorvm::to_unsigned_8(cell obj)
+u64 factor_vm::to_unsigned_8(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-VM_C_API u64 to_unsigned_8(cell obj,factorvm *myvm)
+VM_C_API u64 to_unsigned_8(cell obj,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_unsigned_8(obj);
}
-void factorvm::box_float(float flo)
+void factor_vm::box_float(float flo)
{
dpush(allot_float(flo));
}
-VM_C_API void box_float(float flo,factorvm *myvm) // not sure if this is ever called
+VM_C_API void box_float(float flo, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_float(flo);
}
-float factorvm::to_float(cell value)
+float factor_vm::to_float(cell value)
{
return untag_float_check(value);
}
-VM_C_API float to_float(cell value,factorvm *myvm)
+VM_C_API float to_float(cell value,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_float(value);
}
-void factorvm::box_double(double flo)
+void factor_vm::box_double(double flo)
{
dpush(allot_float(flo));
}
-VM_C_API void box_double(double flo,factorvm *myvm)
+VM_C_API void box_double(double flo,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_double(flo);
}
-double factorvm::to_double(cell value)
+double factor_vm::to_double(cell value)
{
return untag_float_check(value);
}
-VM_C_API double to_double(cell value,factorvm *myvm)
+VM_C_API double to_double(cell value,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_double(value);
/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
overflow, they call these functions. */
-inline void factorvm::overflow_fixnum_add(fixnum x, fixnum y)
+inline void factor_vm::overflow_fixnum_add(fixnum x, fixnum y)
{
drepl(tag<bignum>(fixnum_to_bignum(
untag_fixnum(x) + untag_fixnum(y))));
}
-VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factorvm *myvm)
+VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *myvm)
{
PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_add(x,y);
}
-inline void factorvm::overflow_fixnum_subtract(fixnum x, fixnum y)
+inline void factor_vm::overflow_fixnum_subtract(fixnum x, fixnum y)
{
drepl(tag<bignum>(fixnum_to_bignum(
untag_fixnum(x) - untag_fixnum(y))));
}
-VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factorvm *myvm)
+VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *myvm)
{
PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_subtract(x,y);
}
-inline void factorvm::overflow_fixnum_multiply(fixnum x, fixnum y)
+inline void factor_vm::overflow_fixnum_multiply(fixnum x, fixnum y)
{
bignum *bx = fixnum_to_bignum(x);
- GC_BIGNUM(bx,this);
+ GC_BIGNUM(bx);
bignum *by = fixnum_to_bignum(y);
- GC_BIGNUM(by,this);
+ GC_BIGNUM(by);
drepl(tag<bignum>(bignum_multiply(bx,by)));
}
-VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factorvm *myvm)
+VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *myvm)
{
PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_multiply(x,y);
}
PRIMITIVE(double_bits);
PRIMITIVE(bits_double);
-VM_C_API void box_float(float flo, factorvm *vm);
-VM_C_API float to_float(cell value, factorvm *vm);
-VM_C_API void box_double(double flo, factorvm *vm);
-VM_C_API double to_double(cell value, factorvm *vm);
+VM_C_API void box_float(float flo, factor_vm *vm);
+VM_C_API float to_float(cell value, factor_vm *vm);
+VM_C_API void box_double(double flo, factor_vm *vm);
+VM_C_API double to_double(cell value, factor_vm *vm);
-VM_C_API void box_signed_1(s8 n, factorvm *vm);
-VM_C_API void box_unsigned_1(u8 n, factorvm *vm);
-VM_C_API void box_signed_2(s16 n, factorvm *vm);
-VM_C_API void box_unsigned_2(u16 n, factorvm *vm);
-VM_C_API void box_signed_4(s32 n, factorvm *vm);
-VM_C_API void box_unsigned_4(u32 n, factorvm *vm);
-VM_C_API void box_signed_cell(fixnum integer, factorvm *vm);
-VM_C_API void box_unsigned_cell(cell cell, factorvm *vm);
-VM_C_API void box_signed_8(s64 n, factorvm *vm);
-VM_C_API void box_unsigned_8(u64 n, factorvm *vm);
+VM_C_API void box_signed_1(s8 n, factor_vm *vm);
+VM_C_API void box_unsigned_1(u8 n, factor_vm *vm);
+VM_C_API void box_signed_2(s16 n, factor_vm *vm);
+VM_C_API void box_unsigned_2(u16 n, factor_vm *vm);
+VM_C_API void box_signed_4(s32 n, factor_vm *vm);
+VM_C_API void box_unsigned_4(u32 n, factor_vm *vm);
+VM_C_API void box_signed_cell(fixnum integer, factor_vm *vm);
+VM_C_API void box_unsigned_cell(cell cell, factor_vm *vm);
+VM_C_API void box_signed_8(s64 n, factor_vm *vm);
+VM_C_API void box_unsigned_8(u64 n, factor_vm *vm);
-VM_C_API s64 to_signed_8(cell obj, factorvm *vm);
-VM_C_API u64 to_unsigned_8(cell obj, factorvm *vm);
+VM_C_API s64 to_signed_8(cell obj, factor_vm *vm);
+VM_C_API u64 to_unsigned_8(cell obj, factor_vm *vm);
-VM_C_API fixnum to_fixnum(cell tagged, factorvm *vm);
-VM_C_API cell to_cell(cell tagged, factorvm *vm);
+VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm);
+VM_C_API cell to_cell(cell tagged, factor_vm *vm);
-VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factorvm *vm);
-VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factorvm *vm);
-VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factorvm *vm);
+VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *vm);
+VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *vm);
+VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *vm);
}
namespace factor
{
-void factorvm::c_to_factor_toplevel(cell quot)
+void factor_vm::c_to_factor_toplevel(cell quot)
{
c_to_factor(quot,this);
}
namespace factor
{
-void factorvm::c_to_factor_toplevel(cell quot)
+void factor_vm::c_to_factor_toplevel(cell quot)
{
for(;;)
{
return thread;
}
-
pthread_key_t tlsKey = 0;
void init_platform_globals()
}
-void register_vm_with_thread(factorvm *vm)
+void register_vm_with_thread(factor_vm *vm)
{
pthread_setspecific(tlsKey,vm);
}
-factorvm *tls_vm()
+factor_vm *tls_vm()
{
- return (factorvm*)pthread_getspecific(tlsKey);
+ return (factor_vm*)pthread_getspecific(tlsKey);
}
static void *null_dll;
usleep(usec);
}
-void factorvm::init_ffi()
+void factor_vm::init_ffi()
{
/* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */
null_dll = dlopen(NULL_DLL,RTLD_LAZY);
}
-void factorvm::ffi_dlopen(dll *dll)
+void factor_vm::ffi_dlopen(dll *dll)
{
dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
}
-void *factorvm::ffi_dlsym(dll *dll, symbol_char *symbol)
+void *factor_vm::ffi_dlsym(dll *dll, symbol_char *symbol)
{
void *handle = (dll == NULL ? null_dll : dll->dll);
return dlsym(handle,symbol);
}
-void factorvm::ffi_dlclose(dll *dll)
+void factor_vm::ffi_dlclose(dll *dll)
{
if(dlclose(dll->dll))
general_error(ERROR_FFI,F,F,NULL);
-
-inline void factorvm::vmprim_existsp()
+inline void factor_vm::primitive_existsp()
{
struct stat sb;
char *path = (char *)(untag_check<byte_array>(dpop()) + 1);
PRIMITIVE(existsp)
{
- PRIMITIVE_GETVM()->vmprim_existsp();
+ PRIMITIVE_GETVM()->primitive_existsp();
}
-segment *factorvm::alloc_segment(cell size)
+segment *factor_vm::alloc_segment(cell size)
{
int pagesize = getpagesize();
free(block);
}
-stack_frame *factorvm::uap_stack_pointer(void *uap)
+stack_frame *factor_vm::uap_stack_pointer(void *uap)
{
/* There is a race condition here, but in practice a signal
delivered during stack frame setup/teardown or while transitioning
}
-
-void factorvm::memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void factor_vm::memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_fault_addr = (cell)siginfo->si_addr;
signal_callstack_top = uap_stack_pointer(uap);
SIGNAL_VM_PTR()->memory_signal_handler(signal,siginfo,uap);
}
-
-void factorvm::misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void factor_vm::misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
SIGNAL_VM_PTR()->misc_signal_handler(signal,siginfo,uap);
}
-void factorvm::fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void factor_vm::fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
void sleep_micros(cell usec);
void init_platform_globals();
-struct factorvm;
-void register_vm_with_thread(factorvm *vm);
-factorvm *tls_vm();
+struct factor_vm;
+void register_vm_with_thread(factor_vm *vm);
+factor_vm *tls_vm();
void open_console();
}
namespace factor
{
-
THREADHANDLE start_thread(void *(*start_routine)(void *),void *args){
return (void*) CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0);
}
-
DWORD dwTlsIndex;
void init_platform_globals()
{
- if ((dwTlsIndex = TlsAlloc()) == TLS_OUT_OF_INDEXES) {
+ if ((dwTlsIndex = TlsAlloc()) == TLS_OUT_OF_INDEXES)
fatal_error("TlsAlloc failed - out of indexes",0);
- }
}
-void register_vm_with_thread(factorvm *vm)
+void register_vm_with_thread(factor_vm *vm)
{
- if (! TlsSetValue(dwTlsIndex, vm)) {
+ if (! TlsSetValue(dwTlsIndex, vm))
fatal_error("TlsSetValue failed",0);
- }
}
-factorvm *tls_vm()
+factor_vm *tls_vm()
{
- return (factorvm*)TlsGetValue(dwTlsIndex);
+ return (factor_vm*)TlsGetValue(dwTlsIndex);
}
-
s64 current_micros()
{
FILETIME t;
- EPOCH_OFFSET) / 10;
}
-LONG factorvm::exception_handler(PEXCEPTION_POINTERS pe)
+LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe)
{
PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
CONTEXT *c = (CONTEXT*)pe->ContextRecord;
return EXCEPTION_CONTINUE_EXECUTION;
}
-
FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
{
return SIGNAL_VM_PTR()->exception_handler(pe);
bool handler_added = 0;
-void factorvm::c_to_factor_toplevel(cell quot)
+void factor_vm::c_to_factor_toplevel(cell quot)
{
if(!handler_added){
if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler))
RemoveVectoredExceptionHandler((void *)factor::exception_handler);
}
-void factorvm::open_console()
+void factor_vm::open_console()
{
}
THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
void init_platform_globals();
-struct factorvm;
-void register_vm_with_thread(factorvm *vm);
-factorvm *tls_vm();
+struct factor_vm;
+void register_vm_with_thread(factor_vm *vm);
+factor_vm *tls_vm();
}
HMODULE hFactorDll;
-void factorvm::init_ffi()
+void factor_vm::init_ffi()
{
hFactorDll = GetModuleHandle(FACTOR_DLL);
if(!hFactorDll)
fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
}
-void factorvm::ffi_dlopen(dll *dll)
+void factor_vm::ffi_dlopen(dll *dll)
{
dll->dll = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0);
}
-void *factorvm::ffi_dlsym(dll *dll, symbol_char *symbol)
+void *factor_vm::ffi_dlsym(dll *dll, symbol_char *symbol)
{
return (void *)GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
}
-void factorvm::ffi_dlclose(dll *dll)
+void factor_vm::ffi_dlclose(dll *dll)
{
FreeLibrary((HMODULE)dll->dll);
dll->dll = NULL;
}
-bool factorvm::windows_stat(vm_char *path)
+bool factor_vm::windows_stat(vm_char *path)
{
BY_HANDLE_FILE_INFORMATION bhfi;
HANDLE h = CreateFileW(path,
return ret;
}
-
-void factorvm::windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length)
+void factor_vm::windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length)
{
snwprintf(temp_path, length-1, L"%s.image", full_path);
temp_path[length - 1] = 0;
}
/* You must free() this yourself. */
-const vm_char *factorvm::default_image_path()
+const vm_char *factor_vm::default_image_path()
{
vm_char full_path[MAX_UNICODE_PATH];
vm_char *ptr;
}
/* You must free() this yourself. */
-const vm_char *factorvm::vm_executable_path()
+const vm_char *factor_vm::vm_executable_path()
{
vm_char full_path[MAX_UNICODE_PATH];
if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
return safe_strdup(full_path);
}
-
-inline void factorvm::vmprim_existsp()
+inline void factor_vm::primitive_existsp()
{
vm_char *path = untag_check<byte_array>(dpop())->data<vm_char>();
box_boolean(windows_stat(path));
PRIMITIVE(existsp)
{
- PRIMITIVE_GETVM()->vmprim_existsp();
+ PRIMITIVE_GETVM()->primitive_existsp();
}
-segment *factorvm::alloc_segment(cell size)
+segment *factor_vm::alloc_segment(cell size)
{
char *mem;
DWORD ignore;
return block;
}
-void factorvm::dealloc_segment(segment *block)
+void factor_vm::dealloc_segment(segment *block)
{
SYSTEM_INFO si;
GetSystemInfo(&si);
free(block);
}
-long factorvm::getpagesize()
+long factor_vm::getpagesize()
{
static long g_pagesize = 0;
if (! g_pagesize)
return g_pagesize;
}
-void factorvm::sleep_micros(u64 usec)
+void factor_vm::sleep_micros(u64 usec)
{
Sleep((DWORD)(usec / 1000));
}
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
-
inline static void init_signals() {}
inline static void early_init() {}
namespace factor
{
-
-void factorvm::init_profiler()
+void factor_vm::init_profiler()
{
profiling_p = false;
}
-
/* Allocates memory */
-code_block *factorvm::compile_profiling_stub(cell word_)
+code_block *factor_vm::compile_profiling_stub(cell word_)
{
gc_root<word> word(word_,this);
return jit.to_code_block();
}
-
/* Allocates memory */
-void factorvm::set_profiling(bool profiling)
+void factor_vm::set_profiling(bool profiling)
{
if(profiling == profiling_p)
return;
iterate_code_heap(factor::relocate_code_block);
}
-
-inline void factorvm::vmprim_profiling()
+inline void factor_vm::primitive_profiling()
{
set_profiling(to_boolean(dpop()));
}
PRIMITIVE(profiling)
{
- PRIMITIVE_GETVM()->vmprim_profiling();
+ PRIMITIVE_GETVM()->primitive_profiling();
}
}
{
return (i + 2) == array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(FIXNUM_TYPE)
- && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_PRIMITIVE_WORD];
+ && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_PRIMITIVE_WORD];
}
bool quotation_jit::fast_if_p(cell i)
return (i + 3) == array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 2) == myvm->userenv[JIT_IF_WORD];
+ && array_nth(elements.untagged(),i + 2) == parent_vm->userenv[JIT_IF_WORD];
}
bool quotation_jit::fast_dip_p(cell i)
{
return (i + 2) <= array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_DIP_WORD];
+ && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DIP_WORD];
}
bool quotation_jit::fast_2dip_p(cell i)
{
return (i + 2) <= array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_2DIP_WORD];
+ && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_2DIP_WORD];
}
bool quotation_jit::fast_3dip_p(cell i)
{
return (i + 2) <= array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_3DIP_WORD];
+ && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_3DIP_WORD];
}
bool quotation_jit::mega_lookup_p(cell i)
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(ARRAY_TYPE)
&& 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) == myvm->userenv[MEGA_LOOKUP_WORD];
+ && array_nth(elements.untagged(),i + 3) == parent_vm->userenv[MEGA_LOOKUP_WORD];
}
bool quotation_jit::stack_frame_p()
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
- if(myvm->untag<word>(obj)->subprimitive == F)
+ if(parent_vm->untag<word>(obj)->subprimitive == F)
return true;
break;
case QUOTATION_TYPE:
set_position(0);
if(stack_frame)
- emit(myvm->userenv[JIT_PROLOG]);
+ emit(parent_vm->userenv[JIT_PROLOG]);
cell i;
cell length = array_capacity(elements.untagged());
{
set_position(i);
- gc_root<object> obj(array_nth(elements.untagged(),i),myvm);
+ gc_root<object> obj(array_nth(elements.untagged(),i),parent_vm);
switch(obj.type())
{
if(obj.as<word>()->subprimitive != F)
emit_subprimitive(obj.value());
/* The (execute) primitive is special-cased */
- else if(obj.value() == myvm->userenv[JIT_EXECUTE_WORD])
+ else if(obj.value() == parent_vm->userenv[JIT_EXECUTE_WORD])
{
if(i == length - 1)
{
- if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]);
tail_call = true;
- emit(myvm->userenv[JIT_EXECUTE_JUMP]);
+ emit(parent_vm->userenv[JIT_EXECUTE_JUMP]);
}
else
- emit(myvm->userenv[JIT_EXECUTE_CALL]);
+ emit(parent_vm->userenv[JIT_EXECUTE_CALL]);
}
/* Everything else */
else
{
if(i == length - 1)
{
- if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]);
tail_call = true;
/* Inline cache misses are special-cased.
The calling convention for tail
the inline cache miss primitive, and
we don't want to clobber the saved
address. */
- if(obj.value() == myvm->userenv[PIC_MISS_WORD]
- || obj.value() == myvm->userenv[PIC_MISS_TAIL_WORD])
+ if(obj.value() == parent_vm->userenv[PIC_MISS_WORD]
+ || obj.value() == parent_vm->userenv[PIC_MISS_TAIL_WORD])
{
word_special(obj.value());
}
/* Primitive calls */
if(primitive_call_p(i))
{
- emit_with(myvm->userenv[JIT_PRIMITIVE],obj.value());
+ emit_with(parent_vm->userenv[JIT_PRIMITIVE],obj.value());
i++;
mutually recursive in the library, but both still work) */
if(fast_if_p(i))
{
- if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]);
tail_call = true;
if(compiling)
{
- myvm->jit_compile(array_nth(elements.untagged(),i),relocate);
- myvm->jit_compile(array_nth(elements.untagged(),i + 1),relocate);
+ parent_vm->jit_compile(array_nth(elements.untagged(),i),relocate);
+ parent_vm->jit_compile(array_nth(elements.untagged(),i + 1),relocate);
}
literal(array_nth(elements.untagged(),i));
literal(array_nth(elements.untagged(),i + 1));
- emit(myvm->userenv[JIT_IF]);
+ emit(parent_vm->userenv[JIT_IF]);
i += 2;
else if(fast_dip_p(i))
{
if(compiling)
- myvm->jit_compile(obj.value(),relocate);
- emit_with(myvm->userenv[JIT_DIP],obj.value());
+ parent_vm->jit_compile(obj.value(),relocate);
+ emit_with(parent_vm->userenv[JIT_DIP],obj.value());
i++;
break;
}
else if(fast_2dip_p(i))
{
if(compiling)
- myvm->jit_compile(obj.value(),relocate);
- emit_with(myvm->userenv[JIT_2DIP],obj.value());
+ parent_vm->jit_compile(obj.value(),relocate);
+ emit_with(parent_vm->userenv[JIT_2DIP],obj.value());
i++;
break;
}
else if(fast_3dip_p(i))
{
if(compiling)
- myvm->jit_compile(obj.value(),relocate);
- emit_with(myvm->userenv[JIT_3DIP],obj.value());
+ parent_vm->jit_compile(obj.value(),relocate);
+ emit_with(parent_vm->userenv[JIT_3DIP],obj.value());
i++;
break;
}
set_position(length);
if(stack_frame)
- emit(myvm->userenv[JIT_EPILOG]);
- emit(myvm->userenv[JIT_RETURN]);
+ emit(parent_vm->userenv[JIT_EPILOG]);
+ emit(parent_vm->userenv[JIT_RETURN]);
}
}
-void factorvm::set_quot_xt(quotation *quot, code_block *code)
+void factor_vm::set_quot_xt(quotation *quot, code_block *code)
{
if(code->type != QUOTATION_TYPE)
critical_error("Bad param to set_quot_xt",(cell)code);
}
/* Allocates memory */
-void factorvm::jit_compile(cell quot_, bool relocating)
+void factor_vm::jit_compile(cell quot_, bool relocating)
{
gc_root<quotation> quot(quot_,this);
if(quot->code) return;
if(relocating) relocate_code_block(compiled);
}
-inline void factorvm::vmprim_jit_compile()
+inline void factor_vm::primitive_jit_compile()
{
jit_compile(dpop(),true);
}
PRIMITIVE(jit_compile)
{
- PRIMITIVE_GETVM()->vmprim_jit_compile();
+ PRIMITIVE_GETVM()->primitive_jit_compile();
}
/* push a new quotation on the stack */
-inline void factorvm::vmprim_array_to_quotation()
+inline void factor_vm::primitive_array_to_quotation()
{
quotation *quot = allot<quotation>(sizeof(quotation));
quot->array = dpeek();
PRIMITIVE(array_to_quotation)
{
- PRIMITIVE_GETVM()->vmprim_array_to_quotation();
+ PRIMITIVE_GETVM()->primitive_array_to_quotation();
}
-inline void factorvm::vmprim_quotation_xt()
+inline void factor_vm::primitive_quotation_xt()
{
quotation *quot = untag_check<quotation>(dpeek());
drepl(allot_cell((cell)quot->xt));
PRIMITIVE(quotation_xt)
{
- PRIMITIVE_GETVM()->vmprim_quotation_xt();
+ PRIMITIVE_GETVM()->primitive_quotation_xt();
}
-void factorvm::compile_all_words()
+void factor_vm::compile_all_words()
{
gc_root<array> words(find_all_words(),this);
}
/* Allocates memory */
-fixnum factorvm::quot_code_offset_to_scan(cell quot_, cell offset)
+fixnum factor_vm::quot_code_offset_to_scan(cell quot_, cell offset)
{
gc_root<quotation> quot(quot_,this);
gc_root<array> array(quot->array,this);
return compiler.get_position();
}
-cell factorvm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
+cell factor_vm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
{
gc_root<quotation> quot(quot_,this);
stack_chain->callstack_top = stack;
return quot.value();
}
-VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factorvm *myvm)
+VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->lazy_jit_compile_impl(quot_,stack);
}
-inline void factorvm::vmprim_quot_compiled_p()
+inline void factor_vm::primitive_quot_compiled_p()
{
tagged<quotation> quot(dpop());
quot.untag_check(this);
PRIMITIVE(quot_compiled_p)
{
- PRIMITIVE_GETVM()->vmprim_quot_compiled_p();
+ PRIMITIVE_GETVM()->primitive_quot_compiled_p();
}
}
gc_root<array> elements;
bool compiling, relocate;
- quotation_jit(cell quot, bool compiling_, bool relocate_, factorvm *vm)
+ quotation_jit(cell quot, bool compiling_, bool relocate_, factor_vm *vm)
: jit(QUOTATION_TYPE,quot,vm),
elements(owner.as<quotation>().untagged()->array,vm),
compiling(compiling_),
PRIMITIVE(array_to_quotation);
PRIMITIVE(quotation_xt);
-VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factorvm *myvm);
+VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *myvm);
PRIMITIVE(quot_compiled_p);
namespace factor
{
-
-inline void factorvm::vmprim_getenv()
+inline void factor_vm::primitive_getenv()
{
fixnum e = untag_fixnum(dpeek());
drepl(userenv[e]);
PRIMITIVE(getenv)
{
- PRIMITIVE_GETVM()->vmprim_getenv();
+ PRIMITIVE_GETVM()->primitive_getenv();
}
-inline void factorvm::vmprim_setenv()
+inline void factor_vm::primitive_setenv()
{
fixnum e = untag_fixnum(dpop());
cell value = dpop();
PRIMITIVE(setenv)
{
- PRIMITIVE_GETVM()->vmprim_setenv();
+ PRIMITIVE_GETVM()->primitive_setenv();
}
-inline void factorvm::vmprim_exit()
+inline void factor_vm::primitive_exit()
{
exit(to_fixnum(dpop()));
}
PRIMITIVE(exit)
{
- PRIMITIVE_GETVM()->vmprim_exit();
+ PRIMITIVE_GETVM()->primitive_exit();
}
-inline void factorvm::vmprim_micros()
+inline void factor_vm::primitive_micros()
{
box_unsigned_8(current_micros());
}
PRIMITIVE(micros)
{
- PRIMITIVE_GETVM()->vmprim_micros();
+ PRIMITIVE_GETVM()->primitive_micros();
}
-inline void factorvm::vmprim_sleep()
+inline void factor_vm::primitive_sleep()
{
sleep_micros(to_cell(dpop()));
}
PRIMITIVE(sleep)
{
- PRIMITIVE_GETVM()->vmprim_sleep();
+ PRIMITIVE_GETVM()->primitive_sleep();
}
-inline void factorvm::vmprim_set_slot()
+inline void factor_vm::primitive_set_slot()
{
fixnum slot = untag_fixnum(dpop());
object *obj = untag<object>(dpop());
PRIMITIVE(set_slot)
{
- PRIMITIVE_GETVM()->vmprim_set_slot();
+ PRIMITIVE_GETVM()->primitive_set_slot();
}
-inline void factorvm::vmprim_load_locals()
+inline void factor_vm::primitive_load_locals()
{
fixnum count = untag_fixnum(dpop());
memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count);
PRIMITIVE(load_locals)
{
- PRIMITIVE_GETVM()->vmprim_load_locals();
+ PRIMITIVE_GETVM()->primitive_load_locals();
}
-cell factorvm::clone_object(cell obj_)
+cell factor_vm::clone_object(cell obj_)
{
gc_root<object> obj(obj_,this);
}
}
-inline void factorvm::vmprim_clone()
+inline void factor_vm::primitive_clone()
{
drepl(clone_object(dpeek()));
}
PRIMITIVE(clone)
{
- PRIMITIVE_GETVM()->vmprim_clone();
+ PRIMITIVE_GETVM()->primitive_clone();
}
}
namespace factor
{
-cell factorvm::string_nth(string* str, cell index)
+cell factor_vm::string_nth(string* str, cell index)
{
/* If high bit is set, the most significant 16 bits of the char
come from the aux vector. The least significant bit of the
}
}
-
-void factorvm::set_string_nth_fast(string *str, cell index, cell ch)
+void factor_vm::set_string_nth_fast(string *str, cell index, cell ch)
{
str->data()[index] = ch;
}
-
-void factorvm::set_string_nth_slow(string *str_, cell index, cell ch)
+void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
{
gc_root<string> str(str_,this);
aux->data<u16>()[index] = ((ch >> 7) ^ 1);
}
-
/* allocates memory */
-void factorvm::set_string_nth(string *str, cell index, cell ch)
+void factor_vm::set_string_nth(string *str, cell index, cell ch)
{
if(ch <= 0x7f)
set_string_nth_fast(str,index,ch);
set_string_nth_slow(str,index,ch);
}
-
/* Allocates memory */
-string *factorvm::allot_string_internal(cell capacity)
+string *factor_vm::allot_string_internal(cell capacity)
{
string *str = allot<string>(string_size(capacity));
return str;
}
-
/* Allocates memory */
-void factorvm::fill_string(string *str_, cell start, cell capacity, cell fill)
+void factor_vm::fill_string(string *str_, cell start, cell capacity, cell fill)
{
gc_root<string> str(str_,this);
}
}
-
/* Allocates memory */
-string *factorvm::allot_string(cell capacity, cell fill)
+string *factor_vm::allot_string(cell capacity, cell fill)
{
gc_root<string> str(allot_string_internal(capacity),this);
fill_string(str.untagged(),0,capacity,fill);
return str.untagged();
}
-
-inline void factorvm::vmprim_string()
+inline void factor_vm::primitive_string()
{
cell initial = to_cell(dpop());
cell length = unbox_array_size();
PRIMITIVE(string)
{
- PRIMITIVE_GETVM()->vmprim_string();
+ PRIMITIVE_GETVM()->primitive_string();
}
-bool factorvm::reallot_string_in_place_p(string *str, cell capacity)
+bool factor_vm::reallot_string_in_place_p(string *str, cell capacity)
{
return in_zone(&nursery,str)
&& (str->aux == F || in_zone(&nursery,untag<byte_array>(str->aux)))
&& capacity <= string_capacity(str);
}
-
-string* factorvm::reallot_string(string *str_, cell capacity)
+string* factor_vm::reallot_string(string *str_, cell capacity)
{
gc_root<string> str(str_,this);
}
}
-
-inline void factorvm::vmprim_resize_string()
+inline void factor_vm::primitive_resize_string()
{
string* str = untag_check<string>(dpop());
cell capacity = unbox_array_size();
PRIMITIVE(resize_string)
{
- PRIMITIVE_GETVM()->vmprim_resize_string();
+ PRIMITIVE_GETVM()->primitive_resize_string();
}
-inline void factorvm::vmprim_string_nth()
+inline void factor_vm::primitive_string_nth()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
PRIMITIVE(string_nth)
{
- PRIMITIVE_GETVM()->vmprim_string_nth();
+ PRIMITIVE_GETVM()->primitive_string_nth();
}
-inline void factorvm::vmprim_set_string_nth_fast()
+inline void factor_vm::primitive_set_string_nth_fast()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
PRIMITIVE(set_string_nth_fast)
{
- PRIMITIVE_GETVM()->vmprim_set_string_nth_fast();
+ PRIMITIVE_GETVM()->primitive_set_string_nth_fast();
}
-inline void factorvm::vmprim_set_string_nth_slow()
+inline void factor_vm::primitive_set_string_nth_slow()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
PRIMITIVE(set_string_nth_slow)
{
- PRIMITIVE_GETVM()->vmprim_set_string_nth_slow();
+ PRIMITIVE_GETVM()->primitive_set_string_nth_slow();
}
}
bool type_p(cell type_) const { return type() == type_; }
- TYPE *untag_check(factorvm *myvm) const {
+ TYPE *untag_check(factor_vm *myvm) const {
if(TYPE::type_number != TYPE_COUNT && !type_p(TYPE::type_number))
myvm->type_error(TYPE::type_number,value_);
return untagged();
template<typename X> tagged<X> as() { return tagged<X>(value_); }
};
-template <typename TYPE> TYPE *factorvm::untag_check(cell value)
+template <typename TYPE> TYPE *factor_vm::untag_check(cell value)
{
return tagged<TYPE>(value).untag_check(this);
}
-template <typename TYPE> TYPE *factorvm::untag(cell value)
+template <typename TYPE> TYPE *factor_vm::untag(cell value)
{
return tagged<TYPE>(value).untagged();
}
{
/* push a new tuple on the stack */
-tuple *factorvm::allot_tuple(cell layout_)
+tuple *factor_vm::allot_tuple(cell layout_)
{
gc_root<tuple_layout> layout(layout_,this);
gc_root<tuple> t(allot<tuple>(tuple_size(layout.untagged())),this);
return t.untagged();
}
-inline void factorvm::vmprim_tuple()
+inline void factor_vm::primitive_tuple()
{
gc_root<tuple_layout> layout(dpop(),this);
tuple *t = allot_tuple(layout.value());
PRIMITIVE(tuple)
{
- PRIMITIVE_GETVM()->vmprim_tuple();
+ PRIMITIVE_GETVM()->primitive_tuple();
}
/* push a new tuple on the stack, filling its slots from the stack */
-inline void factorvm::vmprim_tuple_boa()
+inline void factor_vm::primitive_tuple_boa()
{
gc_root<tuple_layout> layout(dpop(),this);
gc_root<tuple> t(allot_tuple(layout.value()),this);
PRIMITIVE(tuple_boa)
{
- PRIMITIVE_GETVM()->vmprim_tuple_boa();
+ PRIMITIVE_GETVM()->primitive_tuple_boa();
}
}
return ptr;
}
-
/* We don't use printf directly, because format directives are not portable.
Instead we define the common cases here. */
void nl()
fputs(str,stdout);
}
-
void print_cell(cell x)
{
printf(CELL_FORMAT,x);
namespace factor
{
-struct factorvmdata {
+struct factor_vm_data {
// if you change this struct, also change vm.factor k--------
context *stack_chain;
zone nursery; /* new objects are allocated here */
cell pic_to_mega_transitions;
cell pic_counts[4]; /* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
- factorvmdata()
+ factor_vm_data()
: profiling_p(false),
secure_gc(false),
gc_off(false),
namespace factor
{
-struct factorvm : factorvmdata {
+struct factor_vm : factor_vm_data {
// segments
inline cell align_page(cell a);
void init_stacks(cell ds_size_, cell rs_size_);
bool stack_to_array(cell bottom, cell top);
cell array_to_stack(array *array, cell bottom);
- inline void vmprim_datastack();
- inline void vmprim_retainstack();
- inline void vmprim_set_datastack();
- inline void vmprim_set_retainstack();
- inline void vmprim_check_datastack();
+ inline void primitive_datastack();
+ inline void primitive_retainstack();
+ inline void primitive_set_datastack();
+ inline void primitive_set_retainstack();
+ inline void primitive_check_datastack();
// run
- inline void vmprim_getenv();
- inline void vmprim_setenv();
- inline void vmprim_exit();
- inline void vmprim_micros();
- inline void vmprim_sleep();
- inline void vmprim_set_slot();
- inline void vmprim_load_locals();
+ inline void primitive_getenv();
+ inline void primitive_setenv();
+ inline void primitive_exit();
+ inline void primitive_micros();
+ inline void primitive_sleep();
+ inline void primitive_set_slot();
+ inline void primitive_load_locals();
cell clone_object(cell obj_);
- inline void vmprim_clone();
+ inline void primitive_clone();
// profiler
void init_profiler();
code_block *compile_profiling_stub(cell word_);
void set_profiling(bool profiling);
- inline void vmprim_profiling();
+ inline void primitive_profiling();
// errors
void out_of_memory();
void signal_error(int signal, stack_frame *native_stack);
void divide_by_zero_error();
void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top);
- inline void vmprim_call_clear();
- inline void vmprim_unimplemented();
+ inline void primitive_call_clear();
+ inline void primitive_unimplemented();
void memory_signal_handler_impl();
void misc_signal_handler_impl();
void fp_signal_handler_impl();
bignum *bignum_integer_length(bignum * x);
int bignum_logbitp(int shift, bignum * arg);
int bignum_unsigned_logbitp(int shift, bignum * bignum);
- bignum *digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factorvm *), unsigned int radix, int negative_p);
+ bignum *digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factor_vm *), unsigned int radix, int negative_p);
//data_heap
cell init_zone(zone *z, cell size, cell start);
void init_data_heap(cell gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_);
cell untagged_object_size(object *pointer);
cell unaligned_object_size(object *pointer);
- inline void vmprim_size();
+ inline void primitive_size();
cell binary_payload_start(object *pointer);
- inline void vmprim_data_room();
+ inline void primitive_data_room();
void begin_scan();
void end_scan();
- inline void vmprim_begin_scan();
+ inline void primitive_begin_scan();
cell next_object();
- inline void vmprim_next_object();
- inline void vmprim_end_scan();
+ inline void primitive_next_object();
+ inline void primitive_end_scan();
template<typename T> void each_object(T &functor);
cell find_all_words();
cell object_size(cell tagged);
inline void write_barrier(object *obj);
inline void allot_barrier(object *address);
-
//data_gc
void init_data_gc();
object *copy_untagged_object_impl(object *pointer, cell size);
void end_gc(cell gc_elapsed);
void garbage_collection(cell gen,bool growing_data_heap_,cell requested_bytes);
void gc();
- inline void vmprim_gc();
- inline void vmprim_gc_stats();
+ inline void primitive_gc();
+ inline void primitive_gc_stats();
void clear_gc_stats();
- inline void vmprim_become();
+ inline void primitive_become();
void inline_gc(cell *gc_roots_base, cell gc_roots_size);
inline bool collecting_accumulation_gen_p();
inline object *allot_zone(zone *z, cell a);
template <typename TYPE> TYPE *allot(cell size);
inline void check_data_pointer(object *pointer);
inline void check_tagged_pointer(cell tagged);
- inline void vmprim_clear_gc_stats();
+ inline void primitive_clear_gc_stats();
// generic arrays
template <typename T> T *allot_array_internal(cell capacity);
void find_data_references(cell look_for_);
void dump_code_heap();
void factorbug();
- inline void vmprim_die();
+ inline void primitive_die();
//arrays
array *allot_array(cell capacity, cell fill_);
- inline void vmprim_array();
+ inline void primitive_array();
cell allot_array_1(cell obj_);
cell allot_array_2(cell v1_, cell v2_);
cell allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_);
- inline void vmprim_resize_array();
+ inline void primitive_resize_array();
inline void set_array_nth(array *array, cell slot, cell value);
//strings
string *allot_string_internal(cell capacity);
void fill_string(string *str_, cell start, cell capacity, cell fill);
string *allot_string(cell capacity, cell fill);
- inline void vmprim_string();
+ inline void primitive_string();
bool reallot_string_in_place_p(string *str, cell capacity);
string* reallot_string(string *str_, cell capacity);
- inline void vmprim_resize_string();
- inline void vmprim_string_nth();
- inline void vmprim_set_string_nth_fast();
- inline void vmprim_set_string_nth_slow();
+ inline void primitive_resize_string();
+ inline void primitive_string_nth();
+ inline void primitive_set_string_nth_fast();
+ inline void primitive_set_string_nth_slow();
//booleans
void box_boolean(bool value);
//byte arrays
byte_array *allot_byte_array(cell size);
- inline void vmprim_byte_array();
- inline void vmprim_uninitialized_byte_array();
- inline void vmprim_resize_byte_array();
+ inline void primitive_byte_array();
+ inline void primitive_uninitialized_byte_array();
+ inline void primitive_resize_byte_array();
//tuples
tuple *allot_tuple(cell layout_);
- inline void vmprim_tuple();
- inline void vmprim_tuple_boa();
+ inline void primitive_tuple();
+ inline void primitive_tuple_boa();
//words
word *allot_word(cell vocab_, cell name_);
- inline void vmprim_word();
- inline void vmprim_word_xt();
+ inline void primitive_word();
+ inline void primitive_word_xt();
void update_word_xt(cell w_);
- inline void vmprim_optimized_p();
- inline void vmprim_wrapper();
+ inline void primitive_optimized_p();
+ inline void primitive_wrapper();
//math
- inline void vmprim_bignum_to_fixnum();
- inline void vmprim_float_to_fixnum();
- inline void vmprim_fixnum_divint();
- inline void vmprim_fixnum_divmod();
+ inline void primitive_bignum_to_fixnum();
+ inline void primitive_float_to_fixnum();
+ inline void primitive_fixnum_divint();
+ inline void primitive_fixnum_divmod();
bignum *fixnum_to_bignum(fixnum);
bignum *cell_to_bignum(cell);
bignum *long_long_to_bignum(s64 n);
inline fixnum sign_mask(fixnum x);
inline fixnum branchless_max(fixnum x, fixnum y);
inline fixnum branchless_abs(fixnum x);
- inline void vmprim_fixnum_shift();
- inline void vmprim_fixnum_to_bignum();
- inline void vmprim_float_to_bignum();
- inline void vmprim_bignum_eq();
- inline void vmprim_bignum_add();
- inline void vmprim_bignum_subtract();
- inline void vmprim_bignum_multiply();
- inline void vmprim_bignum_divint();
- inline void vmprim_bignum_divmod();
- inline void vmprim_bignum_mod();
- inline void vmprim_bignum_and();
- inline void vmprim_bignum_or();
- inline void vmprim_bignum_xor();
- inline void vmprim_bignum_shift();
- inline void vmprim_bignum_less();
- inline void vmprim_bignum_lesseq();
- inline void vmprim_bignum_greater();
- inline void vmprim_bignum_greatereq();
- inline void vmprim_bignum_not();
- inline void vmprim_bignum_bitp();
- inline void vmprim_bignum_log2();
+ inline void primitive_fixnum_shift();
+ inline void primitive_fixnum_to_bignum();
+ inline void primitive_float_to_bignum();
+ inline void primitive_bignum_eq();
+ inline void primitive_bignum_add();
+ inline void primitive_bignum_subtract();
+ inline void primitive_bignum_multiply();
+ inline void primitive_bignum_divint();
+ inline void primitive_bignum_divmod();
+ inline void primitive_bignum_mod();
+ inline void primitive_bignum_and();
+ inline void primitive_bignum_or();
+ inline void primitive_bignum_xor();
+ inline void primitive_bignum_shift();
+ inline void primitive_bignum_less();
+ inline void primitive_bignum_lesseq();
+ inline void primitive_bignum_greater();
+ inline void primitive_bignum_greatereq();
+ inline void primitive_bignum_not();
+ inline void primitive_bignum_bitp();
+ inline void primitive_bignum_log2();
unsigned int bignum_producer(unsigned int digit);
- inline void vmprim_byte_array_to_bignum();
+ inline void primitive_byte_array_to_bignum();
cell unbox_array_size();
- inline void vmprim_fixnum_to_float();
- inline void vmprim_bignum_to_float();
- inline void vmprim_str_to_float();
- inline void vmprim_float_to_str();
- inline void vmprim_float_eq();
- inline void vmprim_float_add();
- inline void vmprim_float_subtract();
- inline void vmprim_float_multiply();
- inline void vmprim_float_divfloat();
- inline void vmprim_float_mod();
- inline void vmprim_float_less();
- inline void vmprim_float_lesseq();
- inline void vmprim_float_greater();
- inline void vmprim_float_greatereq();
- inline void vmprim_float_bits();
- inline void vmprim_bits_float();
- inline void vmprim_double_bits();
- inline void vmprim_bits_double();
+ inline void primitive_fixnum_to_float();
+ inline void primitive_bignum_to_float();
+ inline void primitive_str_to_float();
+ inline void primitive_float_to_str();
+ inline void primitive_float_eq();
+ inline void primitive_float_add();
+ inline void primitive_float_subtract();
+ inline void primitive_float_multiply();
+ inline void primitive_float_divfloat();
+ inline void primitive_float_mod();
+ inline void primitive_float_less();
+ inline void primitive_float_lesseq();
+ inline void primitive_float_greater();
+ inline void primitive_float_greatereq();
+ inline void primitive_float_bits();
+ inline void primitive_bits_float();
+ inline void primitive_double_bits();
+ inline void primitive_bits_double();
fixnum to_fixnum(cell tagged);
cell to_cell(cell tagged);
void box_signed_1(s8 n);
//io
void init_c_io();
void io_error();
- inline void vmprim_fopen();
- inline void vmprim_fgetc();
- inline void vmprim_fread();
- inline void vmprim_fputc();
- inline void vmprim_fwrite();
- inline void vmprim_fseek();
- inline void vmprim_fflush();
- inline void vmprim_fclose();
+ inline void primitive_fopen();
+ inline void primitive_fgetc();
+ inline void primitive_fread();
+ inline void primitive_fputc();
+ inline void primitive_fwrite();
+ inline void primitive_fseek();
+ inline void primitive_fflush();
+ inline void primitive_fclose();
//code_gc
void clear_free_list(heap *heap);
void iterate_code_heap(code_heap_iterator iter);
void copy_code_heap_roots();
void update_code_heap_words();
- inline void vmprim_modify_code_heap();
- inline void vmprim_code_room();
+ inline void primitive_modify_code_heap();
+ inline void primitive_code_room();
code_block *forward_xt(code_block *compiled);
void forward_frame_xt(stack_frame *frame);
void forward_object_xts();
void compact_code_heap();
inline void check_code_pointer(cell ptr);
-
//image
void init_objects(image_header *h);
void load_data_heap(FILE *file, image_header *h, vm_parameters *p);
void load_code_heap(FILE *file, image_header *h, vm_parameters *p);
bool save_image(const vm_char *filename);
- inline void vmprim_save_image();
- inline void vmprim_save_image_and_exit();
+ inline void primitive_save_image();
+ inline void primitive_save_image_and_exit();
void data_fixup(cell *cell);
template <typename T> void code_fixup(T **handle);
void fixup_word(word *word);
callstack *allot_callstack(cell size);
stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
stack_frame *capture_start();
- inline void vmprim_callstack();
- inline void vmprim_set_callstack();
+ inline void primitive_callstack();
+ inline void primitive_set_callstack();
code_block *frame_code(stack_frame *frame);
cell frame_type(stack_frame *frame);
cell frame_executing(stack_frame *frame);
stack_frame *frame_successor(stack_frame *frame);
cell frame_scan(stack_frame *frame);
- inline void vmprim_callstack_to_array();
+ inline void primitive_callstack_to_array();
stack_frame *innermost_stack_frame(callstack *stack);
stack_frame *innermost_stack_frame_quot(callstack *callstack);
- inline void vmprim_innermost_stack_frame_executing();
- inline void vmprim_innermost_stack_frame_scan();
- inline void vmprim_set_innermost_stack_frame_quot();
+ inline void primitive_innermost_stack_frame_executing();
+ inline void primitive_innermost_stack_frame_scan();
+ inline void primitive_set_innermost_stack_frame_quot();
void save_callstack_bottom(stack_frame *callstack_bottom);
template<typename T> void iterate_callstack(cell top, cell bottom, T &iterator);
- inline void do_slots(cell obj, void (* iter)(cell *,factorvm*));
-
+ inline void do_slots(cell obj, void (* iter)(cell *,factor_vm*));
//alien
char *pinned_alien_offset(cell obj);
cell allot_alien(cell delegate_, cell displacement);
- inline void vmprim_displaced_alien();
- inline void vmprim_alien_address();
+ inline void primitive_displaced_alien();
+ inline void primitive_alien_address();
void *alien_pointer();
- inline void vmprim_dlopen();
- inline void vmprim_dlsym();
- inline void vmprim_dlclose();
- inline void vmprim_dll_validp();
- inline void vmprim_vm_ptr();
+ inline void primitive_dlopen();
+ inline void primitive_dlsym();
+ inline void primitive_dlclose();
+ inline void primitive_dll_validp();
+ inline void primitive_vm_ptr();
char *alien_offset(cell obj);
char *unbox_alien();
void box_alien(void *ptr);
void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
//quotations
- inline void vmprim_jit_compile();
- inline void vmprim_array_to_quotation();
- inline void vmprim_quotation_xt();
+ inline void primitive_jit_compile();
+ inline void primitive_array_to_quotation();
+ inline void primitive_quotation_xt();
void set_quot_xt(quotation *quot, code_block *code);
void jit_compile(cell quot_, bool relocating);
void compile_all_words();
fixnum quot_code_offset_to_scan(cell quot_, cell offset);
cell lazy_jit_compile_impl(cell quot_, stack_frame *stack);
- inline void vmprim_quot_compiled_p();
+ inline void primitive_quot_compiled_p();
//dispatch
cell search_lookup_alist(cell table, cell klass);
cell lookup_hi_tag_method(cell obj, cell methods);
cell lookup_hairy_method(cell obj, cell methods);
cell lookup_method(cell obj, cell methods);
- inline void vmprim_lookup_method();
+ inline void primitive_lookup_method();
cell object_class(cell obj);
cell method_cache_hashcode(cell klass, array *array);
void update_method_cache(cell cache, cell klass, cell method);
- inline void vmprim_mega_cache_miss();
- inline void vmprim_reset_dispatch_stats();
- inline void vmprim_dispatch_stats();
+ inline void primitive_mega_cache_miss();
+ inline void primitive_reset_dispatch_stats();
+ inline void primitive_dispatch_stats();
//inline cache
void init_inline_caching(int max_size);
cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_);
void update_pic_transitions(cell pic_size);
void *inline_cache_miss(cell return_address);
- inline void vmprim_reset_inline_cache_stats();
- inline void vmprim_inline_cache_stats();
+ inline void primitive_reset_inline_cache_stats();
+ inline void primitive_inline_cache_stats();
//factor
void default_parameters(vm_parameters *p);
void factor_sleep(long us);
// os-*
- inline void vmprim_existsp();
+ inline void primitive_existsp();
void init_ffi();
void ffi_dlopen(dll *dll);
void *ffi_dlsym(dll *dll, symbol_char *symbol);
void print_vm_data();
};
-
#ifndef FACTOR_REENTRANT
#define FACTOR_SINGLE_THREADED_SINGLETON
#endif
#ifdef FACTOR_SINGLE_THREADED_SINGLETON
/* calls are dispatched using the singleton vm ptr */
- extern factorvm *vm;
+ extern factor_vm *vm;
#define PRIMITIVE_GETVM() vm
#define PRIMITIVE_OVERFLOW_GETVM() vm
#define VM_PTR vm
#ifdef FACTOR_SINGLE_THREADED_TESTING
/* calls are dispatched as per multithreaded, but checked against singleton */
- extern factorvm *vm;
+ extern factor_vm *vm;
#define ASSERTVM() assert(vm==myvm)
- #define PRIMITIVE_GETVM() ((factorvm*)myvm)
+ #define PRIMITIVE_GETVM() ((factor_vm*)myvm)
#define PRIMITIVE_OVERFLOW_GETVM() ASSERTVM(); myvm
#define VM_PTR myvm
#define SIGNAL_VM_PTR() tls_vm()
#endif
#ifdef FACTOR_REENTRANT
- #define PRIMITIVE_GETVM() ((factorvm*)myvm)
- #define PRIMITIVE_OVERFLOW_GETVM() ((factorvm*)myvm)
+ #define PRIMITIVE_GETVM() ((factor_vm*)myvm)
+ #define PRIMITIVE_OVERFLOW_GETVM() ((factor_vm*)myvm)
#define VM_PTR myvm
#define ASSERTVM()
#define SIGNAL_VM_PTR() tls_vm()
namespace factor
{
-word *factorvm::allot_word(cell vocab_, cell name_)
+word *factor_vm::allot_word(cell vocab_, cell name_)
{
gc_root<object> vocab(vocab_,this);
gc_root<object> name(name_,this);
}
/* <word> ( name vocabulary -- word ) */
-inline void factorvm::vmprim_word()
+inline void factor_vm::primitive_word()
{
cell vocab = dpop();
cell name = dpop();
PRIMITIVE(word)
{
- PRIMITIVE_GETVM()->vmprim_word();
+ PRIMITIVE_GETVM()->primitive_word();
}
/* word-xt ( word -- start end ) */
-inline void factorvm::vmprim_word_xt()
+inline void factor_vm::primitive_word_xt()
{
word *w = untag_check<word>(dpop());
code_block *code = (profiling_p ? w->profiling : w->code);
PRIMITIVE(word_xt)
{
- PRIMITIVE_GETVM()->vmprim_word_xt();
+ PRIMITIVE_GETVM()->primitive_word_xt();
}
/* Allocates memory */
-void factorvm::update_word_xt(cell w_)
+void factor_vm::update_word_xt(cell w_)
{
gc_root<word> w(w_,this);
if(profiling_p)
{
if(!w->profiling)
- w->profiling = compile_profiling_stub(w.value());
+ {
+ /* Note: can't do w->profiling = ... since if LHS
+ evaluates before RHS, since in that case if RHS does a
+ GC, we will have an invalid pointer on the LHS */
+ code_block *profiling = compile_profiling_stub(w.value());
+ w->profiling = profiling;
+ }
w->xt = w->profiling->xt();
}
w->xt = w->code->xt();
}
-inline void factorvm::vmprim_optimized_p()
+inline void factor_vm::primitive_optimized_p()
{
drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek()))));
}
PRIMITIVE(optimized_p)
{
- PRIMITIVE_GETVM()->vmprim_optimized_p();
+ PRIMITIVE_GETVM()->primitive_optimized_p();
}
-inline void factorvm::vmprim_wrapper()
+inline void factor_vm::primitive_wrapper()
{
wrapper *new_wrapper = allot<wrapper>(sizeof(wrapper));
new_wrapper->object = dpeek();
PRIMITIVE(wrapper)
{
- PRIMITIVE_GETVM()->vmprim_wrapper();
+ PRIMITIVE_GETVM()->primitive_wrapper();
}
}
using namespace factor;
-
static const cell card_size = (1<<card_bits);
static const cell addr_card_mask = (card_size-1);
-
typedef u8 card_deck;
static const cell deck_bits = (card_bits + 10);
projects / factor.git / commitdiff