file/write.lisp

   1 (in-package :avm2-compiler)
   2
   3 ;;; code to write out abc tag/hard coded simple .swf file to seekable
   4 ;;; stream or file
   5
   6
   7 ;; todo: range checks
   8
   9 ;;;;;;;;;;;;;;;;;;;;;
  10 ;;; low level writers
  11
  12 (defun write-u8 (byte &optional (stream *standard-output*))
  13   (write-byte byte stream))
  14
  15 (defun write-u16 (integer &optional (stream *standard-output*))
  16   (write-byte (ldb (byte 8 0) integer) stream)
  17   (write-byte (ldb (byte 8 8) integer) stream))
  18
  19 (defun write-u24 (integer &optional (stream *standard-output*))
  20   (write-byte (ldb (byte 8 0) integer) stream)
  21   (write-byte (ldb (byte 8 8) integer) stream)
  22   (write-byte (ldb (byte 8 16) integer) stream))
  23
  24 (defun write-u32-raw (integer &optional (stream *standard-output*))
  25   (write-byte (ldb (byte 8 0) integer) stream)
  26   (write-byte (ldb (byte 8 8) integer) stream)
  27   (write-byte (ldb (byte 8 16) integer) stream)
  28   (write-byte (ldb (byte 8 24) integer) stream))
  29
  30 (defun write-variable-length-encoded (integer &optional (stream *standard-output*))
  31   (loop
  32      for i = integer then i2
  33      for i2 = (ash i -7)
  34      for b = (ldb (byte 7 0) i)
  35      for done = (or (= i2 0) (= i2 -1))
  36      when (not done)
  37      do (setf b (logior #x80 b))
  38      do (write-byte b stream)
  39      until done))
  40
  41 (defun write-u30 (integer &optional (stream *standard-output*))
  42   (assert (<= 0 integer (expt 2 30)))
  43   (write-variable-length-encoded integer stream))
  44
  45 (defun write-u32 (integer &optional (stream *standard-output*))
  46   (assert (<= 0 integer (expt 2 32)))
  47   (write-variable-length-encoded integer stream))
  48
  49 (defun write-s32 (integer &optional (stream *standard-output*))
  50   ;; flash 9/mxmlc seems to want negative #s stored as if they were
  51   ;; casted to uints first :/
  52
  53   (assert (<= (abs integer) (expt 2 32)))
  54   (when (< integer 0) (setf integer (+ (expt 2 32) integer)))
  55   (write-variable-length-encoded integer stream))
  56
  57 (defun write-double (float &optional (stream *standard-output*))
  58   (loop with d = (ieee-floats::encode-float64 float)
  59      for i from 0 below 64 by 8
  60      do (write-byte (ldb (byte 8 i) d) stream)))
  61
  62 (defun write-counted-sequence (function seq &key (count-adjust 0) (start 0))
  63   (declare (ignorable start))
  64   ;;(format *error-output* "counted seq ~d (+ ~d ) entries ~a ~%" (length seq) count-adjust function)
  65   (if (<= (length seq) start)
  66       (write-u30 0)
  67       (progn
  68         (write-u30 (+ (length seq) count-adjust))
  69         (loop for i from start below (length seq)
  70            do (funcall function (elt seq i))))))
  71
  72 (defun write-string-info (string &optional (stream *standard-output*))
  73   (let ((utf8 (sb-ext:string-to-octets string :external-format :utf-8)))
  74     (write-u30 (length utf8))
  75     (write-sequence utf8 stream)))
  76
  77 (defun write-0-terminated-string (string &optional (stream *standard-output*))
  78   (let ((utf8 (sb-ext:string-to-octets string :external-format :utf-8)))
  79     (write-sequence utf8 stream)
  80     (write-u8 0 stream)))
  81
  82 ;;;;;;;;;;;;;;;;;;;;;
  83 ;;; writers for asm level data structures
  84
  85 (defgeneric write-generic (data &optional *standard-output*))
  86
  87 (defmethod write-generic ((trait avm2-asm::trait-info) &optional (*standard-output* *standard-output*))
  88   #+nil(format *trace-output* "trait-data : ~s ~s~%"
  89           (avm2-asm::name trait)
  90            (avm2-asm::trait-data trait))
  91   (write-u30 (avm2-asm::name trait))
  92   (write-generic (avm2-asm::trait-data trait))
  93   (when (not (zerop (logand #x40 (avm2-asm::kind (avm2-asm::trait-data trait)))))
  94     (write-counted-sequence 'write-u30 (avm2-asm::metadata trait))))
  95
  96 (defmethod write-generic ((td avm2-asm::trait-data-slot/const) &optional (*standard-output* *standard-output*))
  97   #+nil(format *trace-output* "trait-data-slot/const :~s ~s ~s ~s ~s~%"
  98           (avm2-asm::kind td)
  99           ( avm2-asm::slot-id td)
 100           ( avm2-asm::type-name td)
 101           (avm2-asm::vindex td)
 102           (avm2-asm::vkind td))
 103   (write-u8 (avm2-asm::kind td))
 104   (write-u30 (avm2-asm::slot-id td))
 105   (write-u30 (avm2-asm::type-name td))
 106   (write-u30 (avm2-asm::vindex td))
 107   (unless (zerop (avm2-asm::vindex td))
 108     (write-u8 (avm2-asm::vkind td))))
 109
 110 (defmethod write-generic ((td avm2-asm::trait-data-class) &optional (*standard-output* *standard-output*))
 111   (write-u8 (avm2-asm::kind td))
 112   (write-u30 (avm2-asm::slot-id td))
 113   (write-u30 (avm2-asm::classi td)))
 114
 115 (defmethod write-generic ((td avm2-asm::trait-data-function) &optional (*standard-output* *standard-output*))
 116   (write-u8 (avm2-asm::kind td))
 117   (write-u30 (avm2-asm::slot-id td))
 118   (write-u30 (avm2-asm::fn td)))
 119
 120 (defmethod write-generic ((td avm2-asm::trait-data-method/get/set) &optional (*standard-output* *standard-output*))
 121   (write-u8 (avm2-asm::kind td))
 122   (write-u30 (avm2-asm::slot-id td))
 123   (write-u30 (avm2-asm::method-id td)))
 124
 125
 126 (defun write-namespace (namespace &optional (stream *standard-output*))
 127   "storing namespace_info as (kind name_index) for now "
 128   (write-u8 (first namespace) stream)
 129   (write-u30 (second namespace) stream))
 130
 131 (defun write-namespace-set (namespace-set &optional (stream *standard-output*))
 132   "namespace-set (ns_set_info) = (ns1 ns2 ... nsN)"
 133   (write-u30 (length namespace-set) stream)
 134   (loop for i in namespace-set
 135      do (write-u30 i stream)))
 136
 137 (defun write-multiname (multiname &optional (stream *standard-output*))
 138   "multiname_info = (kind values*) for now, 0-2 values depending on kind"
 139   ;;; TODO: error checking
 140   (let ((kind (first multiname)))
 141     (write-u8 kind stream)
 142     (loop for i in (cdr multiname)
 143        do (write-u30 i stream))))
 144
 145
 146 (defun write-method-info (method-info &optional (*standard-output* *standard-output*))
 147   "u30 param-count, u30 return-type, u30 param-type[param-count], u30 name,
 148  u8 flags, option_info, param-info ==
 149   (name (param types = multinames) return-type flags (option) (param names)"
 150   (destructuring-bind (name param-types return-type flags &optional optional-params pnames)
 151       method-info
 152     (write-u30 (length param-types))
 153     (write-u30 return-type)
 154     (map 'nil 'write-u30 param-types)
 155     (write-u30 name)
 156     (write-u8 flags)
 157     (when optional-params
 158       (write-u30 (length optional-params))
 159       ;; optional-param = (( val . kind )
 160       (map 'nil (lambda (a)
 161                   (write-u30 (car a))
 162                   (write-u8 (cdr a))) optional-params))
 163     (when pnames
 164       (write-u30 (length pnames))
 165       (map 'nil 'write-u30 pnames))))
 166
 167 (defun write-metadata-info (metadata &optional (*standard-output* *standard-output*))
 168   "metadata = (name (item_info ... )), item_info = (key . value)"
 169   (write-u30 (car metadata))
 170   (write-u30 (length (second metadata)))
 171   (map 'nil (lambda (a) (write-u30 (car a))  (write-u30 (cdr a)))
 172        (second metadata)))
 173
 174 (defun write-instance (instance &optional (*standard-output* *standard-output*))
 175   (destructuring-bind
 176         (name super-name flags interfaces iinit traits
 177               &optional protected-ns) instance
 178     #+nil(format *trace-output* "write instance ~s~%  ~s ~s ~s ~s ~s ~s ~s~% ~s~%"
 179             instance
 180             name super-name flags interfaces iinit traits protected-ns
 181             (assoc iinit (function-names *compiler-context*) :test 'equal))
 182     (write-u30 name)
 183     (write-u30 super-name)
 184     (write-u8 flags)
 185     (when (not (zerop (logand flags avm2-asm::+class-protected-ns+)))
 186       (write-u30 protected-ns))
 187     (write-counted-sequence 'write-u30 interfaces)
 188     (write-u30 iinit)
 189     (write-counted-sequence 'write-generic traits)))
 190
 191 (defun write-class (class &optional (*standard-output* *standard-output*))
 192   " class = (cinit trait1 trait2 ... traitN)"
 193   #+nil(format *trace-output* "write class ~s~%  ~s~%  ~S~%"
 194           class
 195           (assoc (car class) (function-names *compiler-context*) :test 'equal)
 196           (cdr class))
 197   (write-u30 (car class))
 198   (write-counted-sequence 'write-generic (cdr class)))
 199
 200
 201
 202 (defun write-script (script &optional (*standard-output* *standard-output*))
 203   " script = (init trait1 trait2 ... traitN)"
 204   (write-u30 (car script))
 205   (write-counted-sequence 'write-generic (cdr script)))
 206
 207 (defun write-method-body (method-body &optional (*standard-output* *standard-output*))
 208   (write-u30 (avm2-asm::method-id method-body))
 209   (write-u30 (avm2-asm::max-stack method-body))
 210   (write-u30 (1+ (avm2-asm::local-count method-body)))
 211   (write-u30 (avm2-asm::init-scope-depth method-body))
 212   (write-u30 (avm2-asm::max-scope-depth method-body))
 213   (write-counted-sequence 'write-u8 (avm2-asm::code method-body))
 214   (write-counted-sequence 'write-generic (avm2-asm::exceptions method-body))
 215   (write-counted-sequence 'write-generic (avm2-asm::traits method-body)))
 216
 217 (defmethod write-generic ((ei avm2-asm::exception-info) &optional (*standard-output* *standard-output*))
 218   (write-u30 (avm2-asm::from ei))
 219   (write-u30 (avm2-asm::to ei))
 220   (write-u30 (avm2-asm::target ei))
 221   (write-u30 (avm2-asm::exc-type ei))
 222   (write-u30 (avm2-asm::var-name ei)))
 223
 224
 225
 226 (defun write-abc-file (&optional (data avm2-asm::*assembler-context*) (*standard-output* *standard-output*))
 227   (with-accessors
 228         ((ints avm2-asm::ints) (uints avm2-asm::uints) (doubles avm2-asm::doubles)
 229          (strings avm2-asm::strings) (namespaces avm2-asm::namespaces)
 230          (ns-sets avm2-asm::ns-sets) (multinames avm2-asm::multinames)
 231          (method-infos avm2-asm::method-infos) (metadata avm2-asm::metadata)
 232          (classes avm2-asm::classes) (instances avm2-asm::instances)
 233          (scripts avm2-asm::scripts) (method-bodies avm2-asm::method-bodies))
 234       data
 235
 236     (write-u16 16) ;minor version
 237     (write-u16 46) ;major version
 238     ;; constant pool
 239     (write-counted-sequence 'write-s32 ints :start 1)
 240     (write-counted-sequence 'write-u32 uints :start 1)
 241     (write-counted-sequence 'write-double doubles :start 1)
 242     (write-counted-sequence 'write-string-info strings :start 1)
 243     (write-counted-sequence 'write-namespace namespaces :start 1)
 244     (write-counted-sequence 'write-namespace-set ns-sets :start 1)
 245     (write-counted-sequence 'write-multiname multinames :start 1)
 246     ;; methods, etc
 247     (write-counted-sequence 'write-method-info method-infos)
 248     (write-counted-sequence 'write-metadata-info metadata)
 249     (write-counted-sequence 'write-instance instances)
 250     ;; classes and instances share the same length field
 251     (map 'nil 'write-class classes)
 252     (write-counted-sequence 'write-script scripts)
 253     (write-counted-sequence 'write-method-body method-bodies)))
 254
 255 (defun write-as3-tag (as3 tag-name &optional (*standard-output* *standard-output*))
 256   ;; always use the long form for size for now...
 257   (let ((size-pos (file-position *standard-output*)) start)
 258     ;; (write-u16 (logior (ash #x48 6) 63)) ;; was #x48, (x52?)
 259     ;; tag DoABC = 82
 260     (write-u16 (logior (ash #x52 6) 63))
 261     (setf size-pos (file-position *standard-output*))
 262     (write-u32-raw 0)    ;; size, to be filled in later
 263     (setf start (file-position *standard-output*))
 264     ;; flags 1 = lazy initialize
 265     (write-sequence '(01 00 00 00) *standard-output*)
 266     ;; tag name
 267     (write-0-terminated-string tag-name *standard-output*)
 268     ;; write the abc data
 269     (write-abc-file as3)
 270     ;; fill in the tag size
 271     (let* ((here (file-position *standard-output*))
 272            (length (- here start)))
 273       (file-position *standard-output* size-pos)
 274       (write-u32-raw (+ length  ))
 275       (file-position *standard-output* here))))
 276
 277 (defmacro write-tag ((tag stream) &body body)
 278   ;; fixme: handle short tags more efficiently
 279   (let ((start (gensym))
 280         (end (gensym)))
 281     `(let ((,start (file-position ,stream)))
 282        (write-u16 (logior (ash ,tag 6) 63) ,stream)
 283        (setf ,start (file-position ,stream))
 284        (write-u32-raw 0 ,stream)    ;; size, to be filled in later
 285        ,@body
 286     ;; fill in the tag size
 287     (let* ((,end (file-position ,stream)))
 288       (file-position ,stream ,start)
 289       (write-u32-raw  (- ,end ,start 4) ,stream)
 290       (file-position ,stream ,end)))))
 291
 292
 293 (defun write-swf (stream frame-label symbol-classes &optional (flash-version 9))
 294   ;;; write out a minimal .swf, based on the stuff hxasm writes
 295   (write-sequence `(#x46 #x57 #x53 ,flash-version) stream) ;;magic "FWS" + ver
 296   ;;  (write-u32-raw (+ #x17 6 (length as3) (if (>= (length as3) 63) 6 2)) stream)
 297   ;; file length (filled in later)
 298   (write-u32-raw 0 stream)
 299   ;; 8000x6000 twips = 400x300 pels
 300   (write-sequence '(#x78 #x00 #x03 #xe8 #x00 #x00 #x0b #xb8 #x00) stream)
 301   (write-u16 #x1e00 stream) ;; 30fps
 302   (write-u16 #x0001 stream) ;; 1 frame
 303
 304   ;; FileAttributes tag
 305   (write-u16 (logior (ash #x45 6) 4) stream) ;; type=69 + length=4
 306   (write-u8 #b00011001 stream) ;; flags: reserved=000, HasMetadata=1,AS3=1,res=00, UseNetwork=1
 307   (write-u8 0 stream) ;;reserved
 308   (write-u8 0 stream) ;;reserved
 309   (write-u8 0 stream) ;;reserved
 310
 311   ;; Script Limits tag type=65, length = 4
 312   (write-sequence '(#x44 #x10 #xe8 #x03 #x3c #x00) stream) ;; script limits? stack 1000, time 60
 313
 314   ;; SetBackgroundColor tag type=9, length=3 color=#x869ca7
 315   (write-sequence '(#x43 #x02      #x86 #x9c #xa7 ) stream) ;; bg color?
 316   ;; FrameLabel tag type=43, length=4
 317   ;; (write-sequence '(#xc4 #x0a #x66 #x6f #x6f 00) stream) ;; frame label
 318   (write-tag (43 stream)
 319     (write-0-terminated-string frame-label stream))
 320
 321   ;; AS3 tag
 322   (write-as3-tag avm2-asm::*assembler-context* "frame" stream)
 323   ;; SymbolClass tag, tag=76 length=8
 324   ;;(write-u16 #x1308 stream) ;;tag+length
 325   ;;   NumSymbols=#x0001 Tag[1] = #x0000 Name[1]="foo"#x0
 326   ;;  (write-sequence '(#x01 00 00 00 #x66 #x6f #x6f 00) stream)
 327   (write-tag (76 stream)
 328     (write-u16 (length symbol-classes) stream) ;; # of symbols
 329     (loop for i in symbol-classes
 330          do
 331          (write-u16 (first i) stream) ;; tag
 332          (write-0-terminated-string (second i) stream))) ;; name
 333
 334   ;; ShowFrame tag type=1, length=0
 335   (write-u16 (logior (ash #x01 6) 0) stream) ;; show frame tag
 336   ;; End tag type=1, length=0
 337   (write-u16 (logior (ash #x00 6) 0) stream) ;; end tag
 338   ;; fill in the file size
 339   (file-position stream 4)
 340   (write-u32-raw (file-length stream) stream)
 341 )
 342
 343
 344 ;;; fixme: deal with package stuff, possibly reorganize stuff between asm/compiler...
 345
 346 (defun super-names (name)
 347   (let ((c (when name (find-swf-class name))))
 348     (when c
 349       (cons (swf-name c) (super-names (extends c))))))
 350
 351 (defun push-lex-scope (mn-index)
 352   `((:get-lex ,(if (integerp mn-index) `(:id ,mn-index)mn-index))
 353     (:push-scope)))
 354
 355 (defun new-class+scopes (class)
 356   ;; fixme: allow class lookup instead of using class-id directly?
 357   (let ((supers (reverse (super-names (extends class)))))
 358     `((:get-scope-object 0)
 359       ,@(loop for i in supers
 360            append (push-lex-scope i))
 361       (:get-lex ,(swf-name (find-swf-class (extends class))))
 362       (:new-class ,(second (assoc (swf-name class) (class-names *compiler-context*))))
 363       ,@(loop repeat  (length supers)
 364            collect `(:pop-scope))
 365       (:init-property  ,(swf-name class)))))
 366
 367
 368 (defun assemble-function (name)
 369   #+nil(format t "--assemble-function ~s :~%" name)
 370   (destructuring-bind (n nid argtypes return-type flags asm)
 371       (find-swf-function name)
 372     (let ((mid (avm2-asm::avm2-method nid argtypes return-type flags
 373                                     :body (avm2-asm::assemble-method-body asm))))
 374       (push (list n mid) (function-names *compiler-context*)))))
 375
 376 (defun assemble-class (name ns super properties constructor)
 377   (let* ((constructor-mid (avm2-asm::avm2-method
 378                            0 ;; name
 379                            (loop for i in (first constructor)
 380                               collect 0) ;; constructor arg types
 381                            0 0
 382                            :body
 383                            (avm2-asm::assemble-method-body
 384                             (%compile-defun name (first constructor)
 385                                             (second constructor) t t))))
 386          ;; fixme: probably should make this configurable at some point
 387          (class-init (avm2-asm::avm2-method 0 nil 0 0 ;; meta-class init
 388                                           :body
 389                                           (avm2-asm::assemble-method-body
 390                                            `((:get-local-0)
 391                                              (:push-scope)
 392                                              (:return-void))
 393                                            :init-scope 0)))
 394          (junk (avm2-asm::avm2-ns-intern ns))
 395          (class (avm2-asm::avm2-class
 396                  (avm2-asm::asm-intern-multiname name)
 397                  (avm2-asm::asm-intern-multiname
 398                   (or (swf-name (find-swf-class super))
 399                       super))
 400                  ;; todo: add interfaces
 401                  09 nil ;; flags, interfaces
 402                  constructor-mid
 403                  (loop for i in properties
 404                     collect
 405                       (make-instance
 406                        'avm2-asm::trait-info
 407                        'avm2-asm::name (avm2-asm::asm-intern-multiname i)
 408                        'avm2-asm::trait-data
 409                        (make-instance 'avm2-asm::trait-data-slot/const
 410                                                     'avm2-asm::kind 0
 411                                                     'avm2-asm::slot-id 0 ;; auto-assign
 412                                                     'avm2-asm::type-name 0 ;; */t
 413                                                     'avm2-asm::vindex 0 ;; no value
 414                                                     'avm2-asm::vkind 0 ;; no value
 415                                                     )))
 416                  class-init
 417                  :protected-ns junk
 418                  ;; todo: class traits
 419                  ;; :class-traits nil
 420                  )))
 421     (push (list name class) (class-names *compiler-context*))))
 422
 423 (defparameter *break-compile* nil)
 424 ;;(setf *break-compile* t)
 425 ;;; quick hack for testing, need to write a proper API at some point, which
 426 ;;;  compiles functions from a list of packages or whatever
 427 (defmacro with-compilation-to-stream (s (frame-name exports &key (swf-version 9)) &body body)
 428   (let ((script-init (gensym))
 429         (script-init-scope-setup (gensym)))
 430
 431     `(let ((avm2-asm::*assembler-context* (make-instance 'avm2-asm::assembler-context))
 432            (*compiler-context* (make-instance 'compiler-context))
 433            (*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table*)))
 434            (,script-init-scope-setup nil))
 435        ;; fixme: add these to assembler-context constructor or something
 436        (avm2-asm::avm2-intern "")
 437        (avm2-asm::avm2-ns-intern "")
 438        #+nil(format t "==-== body~%")
 439        ;; compile the body code
 440        ,@body
 441        #+nil(format t "==-== classes~%")
 442        ;; assemble classes
 443        (loop for symbol-table in (list *cl-symbol-table* *symbol-table*)
 444           do (loop for k being the hash-keys of (classes symbol-table)
 445                 using (hash-value v)
 446                 do
 447                   (with-accessors ((swf-name swf-name) (ns ns)
 448                                    (extends extends) (properties properties)
 449                                    (constructor constructor)) v
 450                     (when (or properties constructor)
 451                       #+nil(format t "name=~s extends = ~s, find=~s sn=~s~%" swf-name
 452                               extends (find-swf-class extends)
 453                               (swf-name (find-swf-class extends))
 454                               )
 455                       (assemble-class swf-name ns
 456                                       extends
 457                                       properties constructor)))
 458                   (setf ,script-init-scope-setup
 459                         (append ,script-init-scope-setup (new-class+scopes v)))))
 460        #+nil(format t "==-== functions~%")
 461        ;; assemble functions
 462        (loop for k being the hash-keys of (functions *cl-symbol-table*)
 463           do (assemble-function k))
 464        (loop for k being the hash-keys of (functions *symbol-table*)
 465           do (assemble-function k))
 466        #+nil(format t "==-== boilerplate~%")
 467        ;; script boilerplate
 468        (let ((,script-init
 469               (avm2-asm::avm2-method
 470                0 () 0 0
 471                :body
 472                (avm2-asm::assemble-method-body
 473                 `((:get-local-0)
 474                   (:push-scope)
 475                   ,@,script-init-scope-setup
 476                   (:return-void))))))
 477          #+nil(format t "==-== boilerplate2~%")
 478          (vector-push-extend
 479           `(,,script-init
 480             ,@(loop for i in (class-names *compiler-context*)
 481                  ;;do (format t "-=c-~s~%" i)
 482                  collect (make-instance 'avm2-asm::trait-info
 483                                         'avm2-asm::name
 484                                         (avm2-asm::asm-intern-multiname (first i))
 485                                         'avm2-asm::trait-data
 486                                         (make-instance 'avm2-asm::trait-data-class
 487                                                        'avm2-asm::slot-id 0
 488                                                        'avm2-asm::classi (second i))))
 489             ,@(loop for i in (function-names *compiler-context*)
 490                  ;;do (format t "-=f-~s~%" i)
 491                  collect (make-instance 'avm2-asm::trait-info
 492                                         'avm2-asm::name
 493                                         (if (numberp (first i))
 494                                             (first i)
 495                                             (avm2-asm::asm-intern-multiname (first i)))
 496                                         'avm2-asm::trait-data (make-instance 'avm2-asm::trait-data-method/get/set
 497                                                                             'avm2-asm::slot-id 0
 498                                                                             'avm2-asm::method (second i)))))
 499           (avm2-asm::scripts avm2-asm::*assembler-context*)))
 500
 501        (when *break-compile* (break))
 502        #+nil(format t "==-== write~%")
 503        ;; write out the .swf
 504        (write-swf ,s ,frame-name ,exports ,swf-version))))