-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings arrays byte-arrays generic hashtables
hashtables.private io io.binary io.files io.encodings.binary
io.pathnames kernel kernel.private math namespaces make parser
-prettyprint sequences strings sbufs vectors words quotations
-assocs system layouts splitting grouping growable classes
-classes.builtin classes.tuple classes.tuple.private vocabs
-vocabs.loader source-files definitions debugger
-quotations.private combinators combinators.short-circuit
-math.order math.private accessors slots.private
-generic.single.private compiler.units compiler.constants fry
-locals bootstrap.image.syntax generalizations ;
+prettyprint sequences combinators.smart strings sbufs vectors
+words quotations assocs system layouts splitting grouping
+growable classes classes.private classes.builtin classes.tuple
+classes.tuple.private vocabs vocabs.loader source-files
+definitions debugger quotations.private combinators
+combinators.short-circuit math.order math.private accessors
+slots.private generic.single.private compiler.units
+compiler.constants compiler.codegen.relocation fry locals
+bootstrap.image.syntax parser.notes ;
IN: bootstrap.image
: arch ( os cpu -- arch )
- {
- { "ppc" [ "-ppc" append ] }
- { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
- [ nip ]
- } case ;
+ 2dup [ windows? ] [ ppc? ] bi* or [
+ [ drop unix ] dip
+ ] unless
+ [ name>> ] [ name>> ] bi* "-" glue ;
: my-arch ( -- arch )
- os name>> cpu name>> arch ;
+ os cpu arch ;
: boot-image-name ( arch -- string )
"boot." ".image" surround ;
: images ( -- seq )
{
- "x86.32"
- "winnt-x86.64" "unix-x86.64"
- "linux-ppc" "macosx-ppc"
+ "windows-x86.32" "unix-x86.32"
+ "windows-x86.64" "unix-x86.64"
} ;
<PRIVATE
GENERIC: (eql?) ( obj1 obj2 -- ? )
: eql? ( obj1 obj2 -- ? )
- { [ [ class ] bi@ = ] [ (eql?) ] } 2&& ;
+ { [ [ class-of ] bi@ = ] [ (eql?) ] } 2&& ;
M: fixnum (eql?) eq? ;
! Constants
-CONSTANT: image-magic HEX: 0f0e0d0c
+CONSTANT: image-magic 0x0f0e0d0c
CONSTANT: image-version 4
CONSTANT: data-base 1024
-CONSTANT: userenv-size 70
+CONSTANT: special-objects-size 80
CONSTANT: header-size 10
SYMBOL: sub-primitives
-SYMBOL: jit-relocations
-
-SYMBOL: jit-offset
-
-: compute-offset ( rc -- offset )
- [ building get length jit-offset get + ] dip
- rc-absolute-cell = bootstrap-cell 4 ? - ;
-
-: jit-rel ( rc rt -- )
- over compute-offset 3array jit-relocations get push-all ;
-
-SYMBOL: jit-parameters
-
-: jit-parameter ( parameter -- )
- jit-parameters get push ;
-
-SYMBOL: jit-literals
-
-: jit-literal ( literal -- )
- jit-literals get push ;
-
-: jit-vm ( offset rc -- )
- [ jit-parameter ] dip rt-vm jit-rel ;
-
-: jit-dlsym ( name library rc -- )
- rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
-
:: jit-conditional ( test-quot false-quot -- )
[ 0 test-quot call ] B{ } make length :> len
- building get length jit-offset get + len +
- [ jit-offset set false-quot call ] B{ } make
+ building get length extra-offset get + len +
+ [ extra-offset set false-quot call ] B{ } make
[ length test-quot call ] [ % ] bi ; inline
-: make-jit ( quot -- jit-parameters jit-literals jit-code )
+: make-jit ( quot -- parameters literals code )
+ #! code is a { relocation insns } pair
[
- 0 jit-offset set
- V{ } clone jit-parameters set
- V{ } clone jit-literals set
- V{ } clone jit-relocations set
+ 0 extra-offset set
+ init-relocation
call( -- )
- jit-parameters get >array
- jit-literals get >array
- jit-relocations get >array
- ] B{ } make prefix ;
+ parameter-table get >array
+ literal-table get >array
+ relocation-table get >byte-array
+ ] B{ } make 2array ;
+
+: make-jit-no-params ( quot -- code )
+ make-jit 2nip ;
: jit-define ( quot name -- )
- [ make-jit 2nip ] dip set ;
+ [ make-jit-no-params ] dip set ;
: define-sub-primitive ( quot word -- )
[ make-jit 3array ] dip sub-primitives get set-at ;
-: define-sub-primitive* ( quot non-tail-quot tail-quot word -- )
+: define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
[
- [ make-jit ]
- [ make-jit 2nip ]
- [ make-jit 2nip ]
- tri* 5 narray
+ [
+ [ make-jit ]
+ [ make-jit-no-params ]
+ [ make-jit-no-params ]
+ tri*
+ ] output>array
] dip
sub-primitives get set-at ;
RESET
! Boot quotation, set in stage1.factor
-USERENV: bootstrap-startup-quot 20
+SPECIAL-OBJECT: bootstrap-startup-quot 20
! Bootstrap global namesapce
-USERENV: bootstrap-global 21
+SPECIAL-OBJECT: bootstrap-global 21
! JIT parameters
-USERENV: jit-prolog 23
-USERENV: jit-primitive-word 24
-USERENV: jit-primitive 25
-USERENV: jit-word-jump 26
-USERENV: jit-word-call 27
-USERENV: jit-if-word 28
-USERENV: jit-if 29
-USERENV: jit-epilog 30
-USERENV: jit-return 31
-USERENV: jit-profiling 32
-USERENV: jit-push 33
-USERENV: jit-dip-word 34
-USERENV: jit-dip 35
-USERENV: jit-2dip-word 36
-USERENV: jit-2dip 37
-USERENV: jit-3dip-word 38
-USERENV: jit-3dip 39
-USERENV: jit-execute 40
-USERENV: jit-declare-word 41
-
-USERENV: callback-stub 48
+SPECIAL-OBJECT: jit-prolog 23
+SPECIAL-OBJECT: jit-primitive-word 24
+SPECIAL-OBJECT: jit-primitive 25
+SPECIAL-OBJECT: jit-word-jump 26
+SPECIAL-OBJECT: jit-word-call 27
+SPECIAL-OBJECT: jit-if-word 28
+SPECIAL-OBJECT: jit-if 29
+SPECIAL-OBJECT: jit-safepoint 30
+SPECIAL-OBJECT: jit-epilog 31
+SPECIAL-OBJECT: jit-return 32
+SPECIAL-OBJECT: jit-profiling 33
+SPECIAL-OBJECT: jit-push 34
+SPECIAL-OBJECT: jit-dip-word 35
+SPECIAL-OBJECT: jit-dip 36
+SPECIAL-OBJECT: jit-2dip-word 37
+SPECIAL-OBJECT: jit-2dip 38
+SPECIAL-OBJECT: jit-3dip-word 39
+SPECIAL-OBJECT: jit-3dip 40
+SPECIAL-OBJECT: jit-execute 41
+SPECIAL-OBJECT: jit-declare-word 42
+
+SPECIAL-OBJECT: c-to-factor-word 43
+SPECIAL-OBJECT: lazy-jit-compile-word 44
+SPECIAL-OBJECT: unwind-native-frames-word 45
+SPECIAL-OBJECT: fpu-state-word 46
+SPECIAL-OBJECT: set-fpu-state-word 47
+SPECIAL-OBJECT: signal-handler-word 48
+SPECIAL-OBJECT: leaf-signal-handler-word 49
+SPECIAL-OBJECT: ffi-signal-handler-word 50
+SPECIAL-OBJECT: ffi-leaf-signal-handler-word 51
+
+SPECIAL-OBJECT: callback-stub 53
! PIC stubs
-USERENV: pic-load 49
-USERENV: pic-tag 50
-USERENV: pic-tuple 51
-USERENV: pic-check-tag 52
-USERENV: pic-check-tuple 53
-USERENV: pic-hit 54
-USERENV: pic-miss-word 55
-USERENV: pic-miss-tail-word 56
+SPECIAL-OBJECT: pic-load 54
+SPECIAL-OBJECT: pic-tag 55
+SPECIAL-OBJECT: pic-tuple 56
+SPECIAL-OBJECT: pic-check-tag 57
+SPECIAL-OBJECT: pic-check-tuple 58
+SPECIAL-OBJECT: pic-hit 59
+SPECIAL-OBJECT: pic-miss-word 60
+SPECIAL-OBJECT: pic-miss-tail-word 61
! Megamorphic dispatch
-USERENV: mega-lookup 57
-USERENV: mega-lookup-word 58
-USERENV: mega-miss-word 59
+SPECIAL-OBJECT: mega-lookup 62
+SPECIAL-OBJECT: mega-lookup-word 63
+SPECIAL-OBJECT: mega-miss-word 64
! Default definition for undefined words
-USERENV: undefined-quot 60
+SPECIAL-OBJECT: undefined-quot 65
-: userenv-offset ( symbol -- n )
- userenvs get at header-size + ;
+: special-object-offset ( symbol -- n )
+ special-objects get at header-size + ;
: emit ( cell -- ) image get push ;
: fixup ( value offset -- ) image get set-nth ;
: heap-size ( -- size )
- image get length header-size - userenv-size -
+ image get length header-size - special-objects-size -
bootstrap-cells ;
: here ( -- size ) heap-size data-base + ;
0 emit ! pointer to bignum 0
0 emit ! pointer to bignum 1
0 emit ! pointer to bignum -1
- userenv-size [ f ' emit ] times ;
+ special-objects-size [ f ' emit ] times ;
-: emit-userenv ( symbol -- )
- [ get ' ] [ userenv-offset ] bi fixup ;
+: emit-special-object ( symbol -- )
+ [ get ' ] [ special-object-offset ] bi fixup ;
! Bignums
: t, ( -- ) t t-offset fixup ;
-M: f '
- #! f is #define F RETAG(0,F_TYPE)
- drop \ f type-number ;
+M: f ' drop \ f type-number ;
: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
! Words
: word-sub-primitive ( word -- obj )
- global [ target-word ] bind sub-primitives get at ;
+ [ target-word ] with-global sub-primitives get at ;
: emit-word ( word -- )
[
[ props>> , ]
[ pic-def>> , ]
[ pic-tail-def>> , ]
- [ drop 0 , ] ! count
[ word-sub-primitive , ]
- [ drop 0 , ] ! xt
- [ drop 0 , ] ! code
- [ drop 0 , ] ! profiling
+ [ drop 0 , ] ! entry point
} cleave
] { } make [ ' ] map
] bi
: (emit-tuple) ( tuple -- pointer )
[ tuple-slots ]
- [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
+ [ class-of transfer-word require-tuple-layout ] bi prefix [ ' ] map
tuple [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer )
- dup class name>> "tombstone" =
+ dup class-of name>> "tombstone" =
[ [ (emit-tuple) ] cache-eql-object ]
[ [ (emit-tuple) ] cache-eq-object ]
if ;
M: tombstone '
state>> "((tombstone))" "((empty))" ?
- "hashtables.private" lookup def>> first
+ "hashtables.private" lookup-word def>> first
[ emit-tuple ] cache-eql-object ;
! Arrays
emit ! array
f ' emit ! cached-effect
f ' emit ! cache-counter
- 0 emit ! xt
- 0 emit ! code
+ 0 emit ! entry point
] emit-object
] cache-eql-object ;
\ dip jit-dip-word set
\ 2dip jit-2dip-word set
\ 3dip jit-3dip-word set
- \ inline-cache-miss \ pic-miss-word set
- \ inline-cache-miss-tail \ pic-miss-tail-word set
- \ mega-cache-lookup \ mega-lookup-word set
- \ mega-cache-miss \ mega-miss-word set
+ \ inline-cache-miss pic-miss-word set
+ \ inline-cache-miss-tail pic-miss-tail-word set
+ \ mega-cache-lookup mega-lookup-word set
+ \ mega-cache-miss mega-miss-word set
\ declare jit-declare-word set
- [ undefined ] undefined-quot set ;
-
-: emit-userenvs ( -- )
- userenvs get keys [ emit-userenv ] each ;
+ \ c-to-factor c-to-factor-word set
+ \ lazy-jit-compile lazy-jit-compile-word set
+ \ unwind-native-frames unwind-native-frames-word set
+ \ fpu-state fpu-state-word set
+ \ set-fpu-state set-fpu-state-word set
+ \ signal-handler signal-handler-word set
+ \ leaf-signal-handler leaf-signal-handler-word set
+ \ ffi-signal-handler ffi-signal-handler-word set
+ \ ffi-leaf-signal-handler ffi-leaf-signal-handler-word set
+ undefined-def undefined-quot set ;
+
+: emit-special-objects ( -- )
+ special-objects get keys [ emit-special-object ] each ;
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
+: build-generics ( -- )
+ [
+ all-words
+ [ generic? ] filter
+ [ make-generic ] each
+ ] with-compilation-unit ;
+
: build-image ( -- image )
800000 <vector> image set
20000 <hashtable> objects set
emit-image-header t, 0, 1, -1,
"Building generic words..." print flush
- remake-generics
+ build-generics
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush
emit-jit-data
"Serializing global namespace..." print flush
emit-global
- "Serializing user environment..." print flush
- emit-userenvs
+ "Serializing special object table..." print flush
+ emit-special-objects
"Performing word fixups..." print flush
fixup-words
"Performing header fixups..." print flush
: make-image ( arch -- )
[
+ parser-quiet? off
+ auto-use? off
architecture set
"resource:/core/bootstrap/stage1.factor" run-file
build-image
projects / factor.git / blobdiff