330 lines
8.1 KiB
Factor
330 lines
8.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.
|
|
|
|
IN: cross-compiler
|
|
USE: arithmetic
|
|
USE: combinators
|
|
USE: errors
|
|
USE: format
|
|
USE: hashtables
|
|
USE: kernel
|
|
USE: lists
|
|
USE: logic
|
|
USE: namespaces
|
|
USE: prettyprint
|
|
USE: stack
|
|
USE: stdio
|
|
USE: streams
|
|
USE: strings
|
|
USE: test
|
|
USE: vectors
|
|
USE: vocabularies
|
|
USE: unparser
|
|
USE: words
|
|
|
|
: image "image" get ;
|
|
: emit ( cell -- ) image vector-push ;
|
|
: fixup ( value offset -- ) image set-vector-nth ;
|
|
|
|
( Object memory )
|
|
|
|
: image-magic HEX: 0f0e0d0c ;
|
|
: image-version 0 ;
|
|
|
|
: cell ( we're compiling for a 32-bit system ) 4 ;
|
|
|
|
: tag-mask BIN: 111 ;
|
|
: tag-bits 3 ;
|
|
|
|
: untag ( cell tag -- ) tag-mask bitnot bitand ;
|
|
: tag ( cell -- tag ) tag-mask bitand ;
|
|
|
|
: fixnum-tag BIN: 000 ;
|
|
: word-tag BIN: 001 ;
|
|
: cons-tag BIN: 010 ;
|
|
: object-tag BIN: 011 ;
|
|
: header-tag BIN: 100 ;
|
|
|
|
: immediate ( x tag -- tagged ) swap tag-bits shift< bitor ;
|
|
: >header ( id -- tagged ) header-tag immediate ;
|
|
|
|
( Image header )
|
|
|
|
: header ( -- )
|
|
image-magic emit
|
|
image-version emit
|
|
( relocation base at end of header ) 0 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 ;
|
|
|
|
( Top of heap pointer )
|
|
|
|
: here ( -- size ) image vector-length header-size - cell * ;
|
|
: here-as ( tag -- pointer ) here swap bitor ;
|
|
: pad ( -- ) 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 )
|
|
|
|
: 'fixnum ( n -- tagged ) fixnum-tag immediate ;
|
|
|
|
( Special objects )
|
|
|
|
! Padded with fixnums for 8-byte alignment
|
|
|
|
: f, object-tag here-as "f" set 6 >header emit 0 'fixnum emit ;
|
|
: t, object-tag here-as "t" set 7 >header emit 0 'fixnum emit ;
|
|
: empty, 8 >header emit 0 'fixnum emit ;
|
|
|
|
( Beginning of the image )
|
|
! The image proper begins with the header, then EMPTY, F, T
|
|
|
|
: begin ( -- ) header empty, f, t, ;
|
|
|
|
( Words )
|
|
|
|
: word, ( -- pointer )
|
|
word-tag here-as word-tag >header emit 0 emit ;
|
|
|
|
! This is to handle mutually recursive words
|
|
! It is a hack. A recursive word in the cdr of a
|
|
! cons doesn't work! This never happends though.
|
|
!
|
|
! Eg : foo [ 5 | foo ] ;
|
|
|
|
: fixup-word-later ( word -- )
|
|
image vector-length cons "word-fixups" get vector-push ;
|
|
|
|
: fixup-word ( where word -- )
|
|
dup pooled-object dup [
|
|
nip swap fixup
|
|
] [
|
|
drop "Not in image: " swap word-name cat2 throw
|
|
] ifte ;
|
|
|
|
: fixup-words ( -- )
|
|
"word-fixups" get [ unswons fixup-word ] vector-each ;
|
|
|
|
: 'word ( word -- pointer )
|
|
dup pooled-object dup [
|
|
nip
|
|
] [
|
|
drop
|
|
! Remember where we are, and add the reference later
|
|
dup fixup-word-later
|
|
] ifte ;
|
|
|
|
( Conses )
|
|
|
|
DEFER: '
|
|
|
|
: cons, ( -- pointer ) cons-tag here-as ;
|
|
: 'cons ( c -- tagged ) uncons ' swap ' cons, -rot emit emit ;
|
|
|
|
( Strings )
|
|
|
|
: pack ( n n -- )
|
|
"big-endian" get [ swap ] when 16 shift< bitor emit ;
|
|
|
|
: pack-at ( n str -- )
|
|
2dup str-nth rot succ rot str-nth pack ;
|
|
|
|
: (pack-string) ( n str -- )
|
|
2dup str-length >= [
|
|
2drop
|
|
] [
|
|
2dup str-length pred = [
|
|
2dup str-nth 0 pack
|
|
] [
|
|
2dup pack-at
|
|
] ifte >r 2 + r> (pack-string)
|
|
] ifte ;
|
|
|
|
: pack-string ( str -- ) 0 swap (pack-string) ;
|
|
|
|
: string, ( string -- )
|
|
object-tag here-as swap
|
|
11 >header emit
|
|
dup str-length emit
|
|
dup hashcode emit
|
|
pack-string
|
|
pad ;
|
|
|
|
: 'string ( string -- pointer )
|
|
#! We pool strings so that each string is only written once
|
|
#! to the image
|
|
dup pooled-object dup [
|
|
nip
|
|
] [
|
|
drop dup string, dup >r pool-object r>
|
|
] ifte ;
|
|
|
|
( Word definitions )
|
|
|
|
IN: namespaces
|
|
|
|
: namespace-buckets 23 ;
|
|
|
|
IN: cross-compiler
|
|
|
|
: (vocabulary) ( name -- vocab )
|
|
#! Vocabulary for target image.
|
|
dup "vocabularies" get hash dup [
|
|
nip
|
|
] [
|
|
drop >r namespace-buckets <hashtable> dup r>
|
|
"vocabularies" get set-hash
|
|
] ifte ;
|
|
|
|
: (word+) ( word -- )
|
|
#! Add the word to a vocabulary in the target image.
|
|
dup word-name over word-vocabulary
|
|
(vocabulary) set-hash ;
|
|
|
|
: 'plist ( word -- plist )
|
|
[,
|
|
|
|
dup word-name "name" swons ,
|
|
dup word-vocabulary "vocabulary" swons ,
|
|
"parsing" swap word-property >boolean "parsing" swons ,
|
|
|
|
,] ' ;
|
|
|
|
: (worddef,) ( word primitive parameter -- )
|
|
' >r >r dup (word+) dup 'plist >r
|
|
word, pool-object
|
|
r> ( -- plist )
|
|
r> ( primitive -- ) emit
|
|
r> ( parameter -- ) emit
|
|
( plist -- ) emit
|
|
0 emit ( padding ) ;
|
|
|
|
: primitive, ( word primitive -- ) f (worddef,) ;
|
|
: compound, ( word definition -- ) 1 swap (worddef,) ;
|
|
|
|
( Arrays and vectors )
|
|
|
|
: 'array ( list -- untagged )
|
|
[ ' ] inject
|
|
here >r
|
|
9 >header emit
|
|
dup length emit
|
|
( elements -- ) [ emit ] each
|
|
pad r> ;
|
|
|
|
: 'vector ( vector -- pointer )
|
|
dup vector>list 'array swap vector-length
|
|
object-tag here-as >r
|
|
10 >header emit
|
|
emit ( length )
|
|
emit ( array ptr )
|
|
pad r> ;
|
|
|
|
( Cross-compile a reference to an object )
|
|
|
|
: ' ( obj -- pointer )
|
|
[
|
|
[ fixnum? ] [ 'fixnum ]
|
|
[ word? ] [ 'word ]
|
|
[ cons? ] [ 'cons ]
|
|
[ char? ] [ 'fixnum ]
|
|
[ string? ] [ 'string ]
|
|
[ vector? ] [ 'vector ]
|
|
[ t = ] [ drop "t" get ]
|
|
[ f = ] [ drop "f" get ]
|
|
[ drop t ] [ "Cannot cross-compile: " swap cat2 throw ]
|
|
] cond ;
|
|
|
|
( End of the image )
|
|
|
|
: (set-boot) ( quot -- ) ' boot-quot-offset fixup ;
|
|
: (set-global) ( namespace -- ) ' global-offset fixup ;
|
|
|
|
: global, ( -- )
|
|
"vocabularies" get "vocabularies"
|
|
namespace-buckets <hashtable>
|
|
dup >r set-hash r> (set-global) ;
|
|
|
|
: end ( -- ) global, fixup-words here heap-size-offset fixup ;
|
|
|
|
( Image output )
|
|
|
|
: byte0 ( num -- byte ) 24 shift> HEX: ff bitand ;
|
|
: byte1 ( num -- byte ) 16 shift> HEX: ff bitand ;
|
|
: byte2 ( num -- byte ) 8 shift> HEX: ff bitand ;
|
|
: byte3 ( num -- byte ) HEX: ff bitand ;
|
|
|
|
: write-little-endian ( word -- )
|
|
dup byte3 >char write
|
|
dup byte2 >char write
|
|
dup byte1 >char write
|
|
byte0 >char write ;
|
|
|
|
: write-big-endian ( word -- )
|
|
dup byte0 >char write
|
|
dup byte1 >char write
|
|
dup byte2 >char write
|
|
byte3 >char write ;
|
|
|
|
: write-word ( word -- )
|
|
"big-endian" get [
|
|
write-big-endian
|
|
] [
|
|
write-little-endian
|
|
] ifte ;
|
|
|
|
: write-image ( image file -- )
|
|
<filebw> [ [ write-word ] vector-each ] with-stream ;
|
|
|
|
: with-image ( quot -- image )
|
|
<namespace> [
|
|
300000 <vector> "image" set
|
|
521 <hashtable> "objects" set
|
|
namespace-buckets <hashtable> "vocabularies" 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
|
|
begin call end
|
|
"image" get
|
|
] bind ;
|
|
|
|
: test-image ( quot -- ) with-image vector>list . ;
|