381 lines
9.1 KiB
Factor
381 lines
9.1 KiB
Factor
! :folding=none:collapseFolds=1:
|
|
|
|
! $Id$
|
|
!
|
|
! Copyright (C) 2004 Slava Pestov.
|
|
!
|
|
! Redistribution and use in source and binary forms, with or without
|
|
! modification, are permitted provided that the following conditions are met:
|
|
!
|
|
! 1. Redistributions of source code must retain the above copyright notice,
|
|
! this list of conditions and the following disclaimer.
|
|
!
|
|
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
|
! this list of conditions and the following disclaimer in the documentation
|
|
! and/or other materials provided with the distribution.
|
|
!
|
|
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
|
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
|
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
|
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
|
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
|
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
|
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
|
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
|
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
! This library allows one to generate a new set of bootstrap
|
|
! images (boot.image.{le32,le64,be32,be64}.
|
|
!
|
|
! It does this by parsing the set of source files needed to
|
|
! generate the minimal image, and writing the cons cells, words,
|
|
! strings etc to the image file in the CFactor object memory
|
|
! format.
|
|
!
|
|
! What is a bootstrap image? It basically contains enough code
|
|
! to parse a source file. See platform/native/boot.factor --
|
|
! It initializes the core interpreter services, and proceeds to
|
|
! run platform/native/boot-stage2.factor.
|
|
|
|
IN: image
|
|
USE: errors
|
|
USE: generic
|
|
USE: hashtables
|
|
USE: kernel
|
|
USE: lists
|
|
USE: math
|
|
USE: namespaces
|
|
USE: prettyprint
|
|
USE: random
|
|
USE: stdio
|
|
USE: streams
|
|
USE: strings
|
|
USE: test
|
|
USE: vectors
|
|
USE: unparser
|
|
USE: words
|
|
USE: parser
|
|
|
|
! The image being constructed; a vector of word-size integers
|
|
SYMBOL: image
|
|
|
|
! Boot quotation, set by boot.factor
|
|
SYMBOL: boot-quot
|
|
|
|
: emit ( cell -- ) image get vector-push ;
|
|
|
|
: fixup ( value offset -- ) image get set-vector-nth ;
|
|
|
|
( Object memory )
|
|
|
|
: image-magic HEX: 0f0e0d0c ;
|
|
: image-version 0 ;
|
|
|
|
: cell "64-bits" get 8 4 ? ;
|
|
: char "64-bits" get 4 2 ? ;
|
|
|
|
: tag-mask BIN: 111 ; inline
|
|
: tag-bits 3 ; inline
|
|
|
|
: untag ( cell tag -- ) tag-mask bitnot bitand ;
|
|
: tag ( cell -- tag ) tag-mask bitand ;
|
|
|
|
: fixnum-tag BIN: 000 ; inline
|
|
: word-tag BIN: 001 ; inline
|
|
: cons-tag BIN: 010 ; inline
|
|
: object-tag BIN: 011 ; inline
|
|
: ratio-tag BIN: 100 ; inline
|
|
: complex-tag BIN: 101 ; inline
|
|
: header-tag BIN: 110 ; inline
|
|
|
|
: f-type 6 ; inline
|
|
: t-type 7 ; inline
|
|
: array-type 8 ; inline
|
|
: bignum-type 9 ; inline
|
|
: float-type 10 ; inline
|
|
: vector-type 11 ; inline
|
|
: string-type 12 ; inline
|
|
: sbuf-type 13 ; inline
|
|
: port-type 14 ; inline
|
|
: dll-type 15 ; inline
|
|
: alien-type 16 ; inline
|
|
|
|
: immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
|
|
: >header ( id -- tagged ) header-tag immediate ;
|
|
|
|
( Image header )
|
|
|
|
: base
|
|
#! We relocate the image to after the header, and leaving
|
|
#! two empty cells. This lets us differentiate an F pointer
|
|
#! (0/tag 3) from a pointer to the first object in the
|
|
#! image.
|
|
2 cell * ;
|
|
|
|
: header ( -- )
|
|
image-magic emit
|
|
image-version emit
|
|
( relocation base at end of header ) base emit
|
|
( bootstrap quotation set later ) 0 emit
|
|
( global namespace set later ) 0 emit
|
|
( size of heap set later ) 0 emit ;
|
|
|
|
: boot-quot-offset 3 ;
|
|
: global-offset 4 ;
|
|
: heap-size-offset 5 ;
|
|
: header-size 6 ;
|
|
|
|
GENERIC: ' ( obj -- ptr )
|
|
#! Write an object to the image.
|
|
|
|
( Allocator )
|
|
|
|
: here ( -- size )
|
|
image get vector-length header-size - cell * base + ;
|
|
|
|
: here-as ( tag -- pointer )
|
|
here swap bitor ;
|
|
|
|
: align-here ( -- )
|
|
here 8 mod 4 = [ 0 emit ] when ;
|
|
|
|
( Remember what objects we've compiled )
|
|
|
|
: pooled-object ( object -- pointer )
|
|
"objects" get hash ;
|
|
|
|
: pool-object ( object pointer -- )
|
|
swap "objects" get set-hash ;
|
|
|
|
( Fixnums )
|
|
|
|
M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
|
|
|
|
( Bignums )
|
|
|
|
M: bignum ' ( bignum -- tagged )
|
|
#! This can only emit 0, -1 and 1.
|
|
object-tag here-as >r
|
|
bignum-type >header emit
|
|
[
|
|
[ 0 | [ 1 0 ] ]
|
|
[ -1 | [ 2 1 1 ] ]
|
|
[ 1 | [ 2 0 1 ] ]
|
|
] assoc [ emit ] each align-here r> ;
|
|
|
|
( Special objects )
|
|
|
|
! Padded with fixnums for 8-byte alignment
|
|
|
|
: t,
|
|
object-tag here-as "t" set
|
|
t-type >header emit
|
|
0 ' emit ;
|
|
|
|
M: t ' ( obj -- ptr ) drop "t" get ;
|
|
M: f ' ( obj -- ptr )
|
|
#! f is #define F RETAG(0,OBJECT_TYPE)
|
|
drop object-tag ;
|
|
|
|
: 0, 0 >bignum ' drop ;
|
|
: 1, 1 >bignum ' drop ;
|
|
: -1, -1 >bignum ' drop ;
|
|
|
|
( Beginning of the image )
|
|
! The image proper begins with the header, then T,
|
|
! and the bignums 0, 1, and -1.
|
|
|
|
: begin ( -- ) header t, 0, 1, -1, ;
|
|
|
|
( Words )
|
|
|
|
: word, ( word -- )
|
|
[
|
|
word-tag >header ,
|
|
dup hashcode ,
|
|
0 ,
|
|
dup word-primitive ,
|
|
dup word-parameter ' ,
|
|
dup word-plist ' ,
|
|
0 ,
|
|
0 ,
|
|
] make-list
|
|
swap word-tag here-as pool-object
|
|
[ emit ] each ;
|
|
|
|
: word-error ( word msg -- )
|
|
[
|
|
,
|
|
dup word-vocabulary ,
|
|
" " ,
|
|
word-name ,
|
|
] make-string throw ;
|
|
|
|
: transfer-word ( word -- word )
|
|
#! This is a hack. See doc/bootstrap.txt.
|
|
dup dup word-name swap word-vocabulary unit search
|
|
dup [
|
|
nip
|
|
] [
|
|
drop "Missing DEFER: " word-error
|
|
] ifte ;
|
|
|
|
: fixup-word ( word -- offset )
|
|
dup pooled-object dup [
|
|
nip
|
|
] [
|
|
drop "Not in image: " word-error
|
|
] ifte ;
|
|
|
|
: fixup-words ( -- )
|
|
image get [
|
|
dup word? [ fixup-word ] when
|
|
] vector-map image set ;
|
|
|
|
M: word ' ( word -- pointer )
|
|
transfer-word dup pooled-object dup [ nip ] [ drop ] ifte ;
|
|
|
|
( Conses )
|
|
|
|
M: cons ' ( c -- tagged )
|
|
uncons ' swap '
|
|
cons-tag here-as
|
|
-rot emit emit ;
|
|
|
|
( Strings )
|
|
|
|
: align-string ( n str -- )
|
|
tuck str-length - CHAR: \0 fill cat2 ;
|
|
|
|
: emit-chars ( str -- )
|
|
"big-endian" get [ str-reverse ] unless
|
|
0 swap [ swap 16 shift + ] str-each emit ;
|
|
|
|
: (pack-string) ( n list -- )
|
|
#! Emit bytes for a string, with n characters per word.
|
|
[
|
|
2dup str-length > [ dupd align-string ] when emit-chars
|
|
] each drop ;
|
|
|
|
: pack-string ( string -- )
|
|
char tuck swap split-n (pack-string) ;
|
|
|
|
: emit-string ( string -- )
|
|
object-tag here-as swap
|
|
string-type >header emit
|
|
dup str-length emit
|
|
dup hashcode emit
|
|
pack-string
|
|
align-here ;
|
|
|
|
M: string ' ( string -- pointer )
|
|
#! We pool strings so that each string is only written once
|
|
#! to the image
|
|
dup pooled-object dup [
|
|
nip
|
|
] [
|
|
drop dup emit-string dup >r pool-object r>
|
|
] ifte ;
|
|
|
|
( Arrays and vectors )
|
|
|
|
: emit-array ( list -- pointer )
|
|
[ ' ] map
|
|
object-tag here-as >r
|
|
array-type >header emit
|
|
dup length emit
|
|
( elements -- ) [ emit ] each
|
|
align-here r> ;
|
|
|
|
M: vector ' ( vector -- pointer )
|
|
dup vector>list emit-array swap vector-length
|
|
object-tag here-as >r
|
|
vector-type >header emit
|
|
emit ( length )
|
|
emit ( array ptr )
|
|
align-here r> ;
|
|
|
|
( End of the image )
|
|
|
|
: vocabularies, ( vocabularies -- )
|
|
[
|
|
cdr dup vector? [
|
|
[
|
|
cdr dup word? [ word, ] [ drop ] ifte
|
|
] hash-each
|
|
] [
|
|
drop
|
|
] ifte
|
|
] hash-each ;
|
|
|
|
: global, ( -- )
|
|
vocabularies get
|
|
dup vocabularies,
|
|
<namespace> [ vocabularies set ] extend '
|
|
global-offset fixup ;
|
|
|
|
: boot, ( quot -- )
|
|
boot-quot get ' boot-quot-offset fixup ;
|
|
|
|
: end ( -- )
|
|
boot,
|
|
global,
|
|
fixup-words
|
|
here base - heap-size-offset fixup ;
|
|
|
|
( Image output )
|
|
|
|
: write-word ( word -- )
|
|
"64-bits" get [
|
|
"big-endian" get [
|
|
write-big-endian-64
|
|
] [
|
|
write-little-endian-64
|
|
] ifte
|
|
] [
|
|
"big-endian" get [
|
|
write-big-endian-32
|
|
] [
|
|
write-little-endian-32
|
|
] ifte
|
|
] ifte ;
|
|
|
|
: write-image ( image file -- )
|
|
<filebw> [ [ write-word ] vector-each ] with-stream ;
|
|
|
|
: with-minimal-image ( quot -- image )
|
|
[
|
|
300000 <vector> image set
|
|
521 <hashtable> "objects" set
|
|
! Note that this is a vector that we can side-effect,
|
|
! since ; ends up using this variable from nested
|
|
! parser namespaces.
|
|
1000 <vector> "word-fixups" set
|
|
call
|
|
image get
|
|
] with-scope ;
|
|
|
|
: with-image ( quot -- image )
|
|
[ begin call end ] with-minimal-image ;
|
|
|
|
: test-image ( quot -- ) with-image vector>list . ;
|
|
|
|
: make-image ( name -- )
|
|
#! Make an image for the C interpreter.
|
|
[
|
|
"/library/bootstrap/boot.factor" run-resource
|
|
boot-quot set
|
|
] with-image
|
|
|
|
swap write-image ;
|
|
|
|
: make-images ( -- )
|
|
"64-bits" off
|
|
"big-endian" off "boot.image.le32" make-image
|
|
"big-endian" on "boot.image.be32" make-image
|
|
"64-bits" on
|
|
"big-endian" off "boot.image.le64" make-image
|
|
"big-endian" on "boot.image.be64" make-image
|
|
"64-bits" off ;
|