library/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
  52 : emit64 ( bignum -- )
  53     #! Little endian byte order
  54     dup HEX: ffffffff bitand emit
  55     32 shift> HEX: ffffffff bitand emit ;
  56
  57 : fixup ( value offset -- ) image set-vector-nth ;
  58
  59 ( Object memory )
  60
  61 : image-magic HEX: 0f0e0d0c ;
  62 : image-version 0 ;
  63
  64 : cell ( we're compiling for a 32-bit system ) 4 ;
  65
  66 : tag-mask BIN: 111 ;
  67 : tag-bits 3 ;
  68
  69 : untag ( cell tag -- ) tag-mask bitnot bitand ;
  70 : tag ( cell -- tag ) tag-mask bitand ;
  71
  72 : fixnum-tag   BIN: 000 ;
  73 : word-tag     BIN: 001 ;
  74 : cons-tag     BIN: 010 ;
  75 : object-tag   BIN: 011 ;
  76 : rational-tag BIN: 100 ;
  77 : complex-tag  BIN: 101 ;
  78 : header-tag   BIN: 110 ;
  79 : gc-fwd-ptr   BIN: 111 ; ( we don't output these )
  80
  81 : f-type      6 ;
  82 : t-type      7 ;
  83 : empty-type  8 ;
  84 : array-type  9 ;
  85 : vector-type 10 ;
  86 : string-type 11 ;
  87 : sbuf-type   12 ;
  88 : handle-type 13 ;
  89 : bignum-type 14 ;
  90 : float-type  15 ;
  91
  92 : immediate ( x tag -- tagged ) swap tag-bits shift< bitor ;
  93 : >header ( id -- tagged ) header-tag immediate ;
  94
  95 ( Image header )
  96
  97 : header ( -- )
  98     image-magic emit
  99     image-version emit
 100     ( relocation base at end of header ) 0 emit
 101     ( bootstrap quotation set later ) 0 emit
 102     ( global namespace set later ) 0 emit
 103     ( size of heap set later ) 0 emit ;
 104
 105 : boot-quot-offset 3 ;
 106 : global-offset    4 ;
 107 : heap-size-offset 5 ;
 108 : header-size      6 ;
 109
 110 ( Top of heap pointer )
 111
 112 : here ( -- size ) image vector-length header-size - cell * ;
 113 : here-as ( tag -- pointer ) here swap bitor ;
 114 : pad ( -- ) here 8 mod 4 = [ 0 emit ] when ;
 115
 116 ( Remember what objects we've compiled )
 117
 118 : pooled-object ( object -- pointer )
 119     "objects" get hash ;
 120
 121 : pool-object ( object pointer -- )
 122     swap "objects" get set-hash ;
 123
 124 ( Fixnums )
 125
 126 : 'fixnum ( n -- tagged ) fixnum-tag immediate ;
 127
 128 ( Floats )
 129
 130 : 'float ( f -- tagged )
 131     object-tag here-as
 132     float-type >header emit
 133     0 emit ( alignment -- FIXME 64-bit arch )
 134     float>bits emit64 ;
 135
 136 ( Bignums )
 137
 138 : 'bignum ( bignum -- tagged )
 139     dup .
 140     #! Very bad!
 141     object-tag here-as
 142     bignum-type >header emit
 143     0 emit ( alignment -- FIXME 64-bit arch )
 144     ( bignum -- ) emit64 ;
 145
 146 ( Special objects )
 147
 148 ! Padded with fixnums for 8-byte alignment
 149
 150 : f, object-tag here-as "f" set f-type >header emit 0 'fixnum emit ;
 151 : t, object-tag here-as "t" set t-type >header emit 0 'fixnum emit ;
 152 : empty, empty-type >header emit 0 'fixnum emit ;
 153
 154 ( Beginning of the image )
 155 ! The image proper begins with the header, then EMPTY, F, T
 156
 157 : begin ( -- ) header empty, f, t, ;
 158
 159 ( Words )
 160
 161 : word, ( -- pointer )
 162     word-tag here-as word-tag >header emit 0 emit ;
 163
 164 ! This is to handle mutually recursive words
 165 ! It is a hack. A recursive word in the cdr of a
 166 ! cons doesn't work! This never happends though.
 167 !
 168 ! Eg : foo [ 5 | foo ] ;
 169
 170 : fixup-word-later ( word -- )
 171     image vector-length cons "word-fixups" get vector-push ;
 172
 173 : fixup-word ( where word -- )
 174     dup pooled-object dup [
 175         nip swap fixup
 176     ] [
 177         drop "Not in image: " swap word-name cat2 throw
 178     ] ifte ;
 179
 180 : fixup-words ( -- )
 181     "word-fixups" get [ unswons fixup-word ] vector-each ;
 182
 183 : 'word ( word -- pointer )
 184     dup pooled-object dup [
 185         nip
 186     ] [
 187         drop
 188         ! Remember where we are, and add the reference later
 189         dup fixup-word-later
 190     ] ifte ;
 191
 192 ( Conses )
 193
 194 DEFER: '
 195
 196 : cons, ( -- pointer ) cons-tag here-as ;
 197 : 'cons ( c -- tagged ) uncons ' swap ' cons, -rot emit emit ;
 198
 199 ( Strings )
 200
 201 : pack ( n n -- )
 202     "big-endian" get [ swap ] when 16 shift< bitor emit ;
 203
 204 : pack-at ( n str -- )
 205     2dup str-nth rot succ rot str-nth pack ;
 206
 207 : (pack-string) ( n str -- )
 208     2dup str-length >= [
 209         2drop
 210     ] [
 211         2dup str-length pred = [
 212             2dup str-nth 0 pack
 213         ] [
 214             2dup pack-at
 215         ] ifte >r 2 + r> (pack-string)
 216     ] ifte ;
 217
 218 : pack-string ( str -- ) 0 swap (pack-string) ;
 219
 220 : string, ( string -- )
 221     object-tag here-as swap
 222     string-type >header emit
 223     dup str-length emit
 224     dup hashcode emit
 225     pack-string
 226     pad ;
 227
 228 : 'string ( string -- pointer )
 229     #! We pool strings so that each string is only written once
 230     #! to the image
 231     dup pooled-object dup [
 232         nip
 233     ] [
 234         drop dup string, dup >r pool-object r>
 235     ] ifte ;
 236
 237 ( Word definitions )
 238
 239 IN: namespaces
 240
 241 : namespace-buckets 23 ;
 242
 243 IN: cross-compiler
 244
 245 : (vocabulary) ( name -- vocab )
 246     #! Vocabulary for target image.
 247     dup "vocabularies" get hash dup [
 248         nip
 249     ] [
 250         drop >r namespace-buckets <hashtable> dup r>
 251         "vocabularies" get set-hash
 252     ] ifte ;
 253
 254 : (word+) ( word -- )
 255     #! Add the word to a vocabulary in the target image.
 256     dup word-name over word-vocabulary
 257     (vocabulary) set-hash ;
 258
 259 : 'plist ( word -- plist )
 260     [,
 261
 262     dup word-name "name" swons ,
 263     dup word-vocabulary "vocabulary" swons ,
 264     "parsing" swap word-property >boolean "parsing" swons ,
 265
 266     ,] ' ;
 267
 268 : (worddef,) ( word primitive parameter -- )
 269     ' >r >r dup (word+) dup 'plist >r
 270     word, pool-object
 271     r> ( -- plist )
 272     r> ( primitive -- ) emit
 273     r> ( parameter -- ) emit
 274     ( plist -- ) emit
 275     0 emit ( padding ) ;
 276
 277 : primitive, ( word primitive -- ) f (worddef,) ;
 278 : compound, ( word definition -- ) 1 swap (worddef,) ;
 279
 280 ( Arrays and vectors )
 281
 282 : 'array ( list -- untagged )
 283     [ ' ] inject
 284     here >r
 285     array-type >header emit
 286     dup length emit
 287     ( elements -- ) [ emit ] each
 288     pad r> ;
 289
 290 : 'vector ( vector -- pointer )
 291     dup vector>list 'array swap vector-length
 292     object-tag here-as >r
 293     vector-type >header emit
 294     emit ( length )
 295     emit ( array ptr )
 296     pad r> ;
 297
 298 ( Cross-compile a reference to an object )
 299
 300 : ' ( obj -- pointer )
 301     [
 302         [ fixnum? ] [ 'fixnum      ]
 303         [ bignum? ] [ 'bignum      ]
 304         [ float?  ] [ 'float       ]
 305         [ word?   ] [ 'word        ]
 306         [ cons?   ] [ 'cons        ]
 307         [ char?   ] [ 'fixnum      ]
 308         [ string? ] [ 'string      ]
 309         [ vector? ] [ 'vector      ]
 310         [ t =     ] [ drop "t" get ]
 311         [ f =     ] [ drop "f" get ]
 312         [ drop t  ] [ "Cannot cross-compile: " swap cat2 throw ]
 313     ] cond ;
 314
 315 ( End of the image )
 316
 317 : (set-boot) ( quot -- ) ' boot-quot-offset fixup ;
 318 : (set-global) ( namespace -- ) ' global-offset fixup ;
 319
 320 : global, ( -- )
 321     "vocabularies" get "vocabularies"
 322     namespace-buckets <hashtable>
 323     dup >r set-hash r> (set-global) ;
 324
 325 : end ( -- ) global, fixup-words here heap-size-offset fixup ;
 326
 327 ( Image output )
 328
 329 : byte0 ( num -- byte ) 24 shift> HEX: ff bitand ;
 330 : byte1 ( num -- byte ) 16 shift> HEX: ff bitand ;
 331 : byte2 ( num -- byte )  8 shift> HEX: ff bitand ;
 332 : byte3 ( num -- byte )           HEX: ff bitand ;
 333
 334 : write-little-endian ( word -- )
 335     dup byte3 >char write
 336     dup byte2 >char write
 337     dup byte1 >char write
 338         byte0 >char write ;
 339
 340 : write-big-endian ( word -- )
 341     dup byte0 >char write
 342     dup byte1 >char write
 343     dup byte2 >char write
 344         byte3 >char write ;
 345
 346 : write-word ( word -- )
 347     "big-endian" get [
 348         write-big-endian
 349     ] [
 350         write-little-endian
 351     ] ifte ;
 352
 353 : write-image ( image file -- )
 354     <filebw> [ [ write-word ] vector-each ] with-stream ;
 355
 356 : with-image ( quot -- image )
 357     <namespace> [
 358         300000 <vector> "image" set
 359         521 <hashtable> "objects" set
 360         namespace-buckets <hashtable> "vocabularies" set
 361         ! Note that this is a vector that we can side-effect,
 362         ! since ; ends up using this variable from nested
 363         ! parser namespaces.
 364         1000 <vector> "word-fixups" set
 365         begin call end
 366         "image" get
 367     ] bind ;
 368
 369 : test-image ( quot -- ) with-image vector>list . ;