library/platform/native/image.factor

   1 ! :folding=none:collapseFolds=1:
   2
   3 ! $Id$
   4 !
   5 ! Copyright (C) 2004 Slava Pestov.
   6 !
   7 ! Redistribution and use in source and binary forms, with or without
   8 ! modification, are permitted provided that the following conditions are met:
   9 !
  10 ! 1. Redistributions of source code must retain the above copyright notice,
  11 !    this list of conditions and the following disclaimer.
  12 !
  13 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  14 !    this list of conditions and the following disclaimer in the documentation
  15 !    and/or other materials provided with the distribution.
  16 !
  17 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  18 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  19 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  20 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  21 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  22 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  23 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  25 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  26 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27
  28 IN: cross-compiler
  29 USE: arithmetic
  30 USE: combinators
  31 USE: errors
  32 USE: format
  33 USE: hashtables
  34 USE: kernel
  35 USE: lists
  36 USE: logic
  37 USE: namespaces
  38 USE: prettyprint
  39 USE: stack
  40 USE: stdio
  41 USE: streams
  42 USE: strings
  43 USE: test
  44 USE: vectors
  45 USE: vocabularies
  46 USE: unparser
  47 USE: words
  48
  49 : image "image" get ;
  50 : emit ( cell -- ) image vector-push ;
  51 : fixup ( value offset -- ) image set-vector-nth ;
  52
  53 ( Object memory )
  54
  55 : image-magic HEX: 0f0e0d0c ;
  56 : image-version 0 ;
  57
  58 : cell ( we're compiling for a 32-bit system ) 4 ;
  59
  60 : tag-mask BIN: 111 ;
  61 : tag-bits 3 ;
  62
  63 : untag ( cell tag -- ) tag-mask bitnot bitand ;
  64 : tag ( cell -- tag ) tag-mask bitand ;
  65
  66 : fixnum-tag BIN: 000 ;
  67 : word-tag   BIN: 001 ;
  68 : cons-tag   BIN: 010 ;
  69 : object-tag BIN: 011 ;
  70 : header-tag BIN: 100 ;
  71
  72 : immediate ( x tag -- tagged ) swap tag-bits shift< bitor ;
  73 : >header ( id -- tagged ) header-tag immediate ;
  74
  75 ( Image header )
  76
  77 : header ( -- )
  78     image-magic emit
  79     image-version emit
  80     ( relocation base at end of header ) 0 emit
  81     ( bootstrap quotation set later ) 0 emit
  82     ( global namespace set later ) 0 emit
  83     ( size of heap set later ) 0 emit ;
  84
  85 : boot-quot-offset 3 ;
  86 : global-offset    4 ;
  87 : heap-size-offset 5 ;
  88 : header-size      6 ;
  89
  90 ( Top of heap pointer )
  91
  92 : here ( -- size ) image vector-length header-size - cell * ;
  93 : here-as ( tag -- pointer ) here swap bitor ;
  94 : pad ( -- ) here 8 mod 4 = [ 0 emit ] when ;
  95
  96 ( Remember what objects we've compiled )
  97
  98 : pooled-object ( object -- pointer )
  99     "objects" get hash ;
 100
 101 : pool-object ( object pointer -- )
 102     swap "objects" get set-hash ;
 103
 104 ( Fixnums )
 105
 106 : 'fixnum ( n -- tagged ) fixnum-tag immediate ;
 107
 108 ( Special objects )
 109
 110 ! Padded with fixnums for 8-byte alignment
 111
 112 : f, object-tag here-as "f" set 6 >header emit 0 'fixnum emit ;
 113 : t, object-tag here-as "t" set 7 >header emit 0 'fixnum emit ;
 114 : empty, 8 >header emit 0 'fixnum emit ;
 115
 116 ( Beginning of the image )
 117 ! The image proper begins with the header, then EMPTY, F, T
 118
 119 : begin ( -- ) header empty, f, t, ;
 120
 121 ( Words )
 122
 123 : word, ( -- pointer )
 124     word-tag here-as word-tag >header emit 0 emit ;
 125
 126 ! This is to handle mutually recursive words
 127 ! It is a hack. A recursive word in the cdr of a
 128 ! cons doesn't work! This never happends though.
 129 !
 130 ! Eg : foo [ 5 | foo ] ;
 131
 132 : fixup-word-later ( word -- )
 133     image vector-length cons "word-fixups" cons@ ;
 134
 135 : fixup-word ( where word -- )
 136     dup pooled-object dup [
 137         nip swap fixup
 138     ] [
 139         drop "Not in image: " swap cat2 throw
 140     ] ifte ;
 141
 142 : fixup-words ( -- )
 143     "word-fixups" get [ unswons fixup-word ] each ;
 144
 145 : 'word ( word -- pointer )
 146     dup pooled-object dup [
 147         nip
 148     ] [
 149         drop
 150         ! Remember where we are, and add the reference later
 151         fixup-word-later f
 152     ] ifte ;
 153
 154 ( Conses )
 155
 156 DEFER: '
 157
 158 : cons, ( -- pointer ) cons-tag here-as ;
 159 : 'cons ( c -- tagged ) uncons ' swap ' cons, -rot emit emit ;
 160
 161 ( Strings )
 162
 163 : pack ( n n -- ) 16 shift< bitor emit ;
 164
 165 : pack-at ( n str -- )
 166     2dup str-nth rot succ rot str-nth pack ;
 167
 168 : (pack-string) ( n str -- )
 169     2dup str-length >= [
 170         2drop
 171     ] [
 172         2dup str-length pred = [
 173             2dup str-nth 0 pack
 174         ] [
 175             2dup pack-at
 176         ] ifte >r 2 + r> (pack-string)
 177     ] ifte ;
 178
 179 : pack-string ( str -- ) 0 swap (pack-string) ;
 180
 181 : string, ( string -- )
 182     object-tag here-as swap
 183     11 >header emit
 184     dup str-length emit
 185     dup hashcode emit
 186     pack-string
 187     pad ;
 188
 189 : 'string ( string -- pointer )
 190     #! We pool strings so that each string is only written once
 191     #! to the image
 192     dup pooled-object dup [
 193         nip
 194     ] [
 195         drop dup string, dup >r pool-object r>
 196     ] ifte ;
 197
 198 ( Word definitions )
 199
 200 IN: namespaces
 201
 202 : namespace-buckets 23 ;
 203
 204 IN: cross-compiler
 205
 206 : (vocabulary) ( name -- vocab )
 207     #! Vocabulary for target image.
 208     dup "vocabularies" get hash dup [
 209         nip
 210     ] [
 211         drop >r namespace-buckets <hashtable> dup r>
 212         "vocabularies" get set-hash
 213     ] ifte ;
 214
 215 : (word+) ( word -- )
 216     #! Add the word to a vocabulary in the target image.
 217     dup word-name over word-vocabulary
 218     (vocabulary) set-hash ;
 219
 220 : 'plist ( word -- plist )
 221     [,
 222
 223     dup word-name "name" swons ,
 224     dup word-vocabulary "vocabulary" swons ,
 225     [ "parsing" get >boolean ] bind "parsing" swons ,
 226
 227     ,] ' ;
 228
 229 : (worddef,) ( word primitive parameter -- )
 230     ' >r >r dup (word+) dup 'plist >r
 231     word, pool-object
 232     r> ( -- plist )
 233     r> ( primitive -- ) emit
 234     r> ( parameter -- ) emit
 235     ( plist -- ) emit
 236     0 emit ( padding ) ;
 237
 238 : primitive, ( word primitive -- ) f (worddef,) ;
 239 : compound, ( word definition -- ) 1 swap (worddef,) ;
 240
 241 ( Arrays and vectors )
 242
 243 : 'array ( list -- untagged )
 244     [ ' ] inject
 245     here >r
 246     9 >header emit
 247     dup length emit
 248     ( elements -- ) [ emit ] each
 249     pad r> ;
 250
 251 : 'vector ( vector -- pointer )
 252     dup vector>list 'array swap vector-length
 253     object-tag here-as >r
 254     10 >header emit
 255     emit ( length )
 256     emit ( array ptr )
 257     pad r> ;
 258
 259 ( Cross-compile a reference to an object )
 260
 261 : ' ( obj -- pointer )
 262     [
 263         [ fixnum? ] [ 'fixnum      ]
 264         [ word?   ] [ 'word        ]
 265         [ cons?   ] [ 'cons        ]
 266         [ char?   ] [ 'fixnum      ]
 267         [ string? ] [ 'string      ]
 268         [ vector? ] [ 'vector      ]
 269         [ t =     ] [ drop "t" get ]
 270         [ f =     ] [ drop "f" get ]
 271         [ drop t  ] [ "Cannot cross-compile: " swap cat2 throw ]
 272     ] cond ;
 273
 274 ( End of the image )
 275
 276 : (set-boot) ( quot -- ) ' boot-quot-offset fixup ;
 277 : (set-global) ( namespace -- ) ' global-offset fixup ;
 278
 279 : global, ( -- )
 280     "vocabularies" get "vocabularies"
 281     namespace-buckets <hashtable>
 282     dup >r set-hash r> (set-global) ;
 283
 284 : end ( -- ) global, fixup-words here heap-size-offset fixup ;
 285
 286 ( Image output )
 287
 288 : byte0 ( num -- byte ) 24 shift> HEX: ff bitand ;
 289 : byte1 ( num -- byte ) 16 shift> HEX: ff bitand ;
 290 : byte2 ( num -- byte )  8 shift> HEX: ff bitand ;
 291 : byte3 ( num -- byte )           HEX: ff bitand ;
 292
 293 : write-little-endian ( word -- )
 294     dup byte3 >char write
 295     dup byte2 >char write
 296     dup byte1 >char write
 297         byte0 >char write ;
 298
 299 : write-big-endian ( word -- )
 300     dup byte0 >char write
 301     dup byte1 >char write
 302     dup byte2 >char write
 303         byte3 >char write ;
 304
 305 : write-word ( word -- )
 306     "big-endian" get [
 307         write-big-endian
 308     ] [
 309         write-little-endian
 310     ] ifte ;
 311
 312 : write-image ( image file -- )
 313     <filebw> [ [ write-word ] vector-each ] with-stream ;
 314
 315 : with-image ( quot -- image )
 316     <namespace> [
 317         300000 <vector> "image" set
 318         521 <hashtable> "objects" set
 319         namespace-buckets <hashtable> "vocabularies" set
 320         begin call end
 321         "image" get
 322     ] bind ;
 323
 324 : test-image ( quot -- ) with-image vector>list . ;