compile/special-forms.lisp

   1 (in-package :avm2-compiler)
   2
   3 ;;;; special forms (and probably some things that are techically
   4 ;;;; macros/functions according to CL, but implemented directly here
   5 ;;;; for now...)
   6
   7 ;; official list of special operators:
   8 ;; http://www.lispworks.com/documentation/HyperSpec/Body/03_ababa.htm#clspecialops
   9
  10
  11 ;;+ let*
  12 ;;+ if
  13 ;;+ progn
  14 ;;+ let
  15 ;;
  16 ;;+ go
  17 ;;+ tagbody
  18 ;;
  19 ;;~ quote
  20 ;;
  21 ;;~ function
  22 ;;~ setq
  23 ;;
  24 ;; symbol-macrolet
  25 ;; flet
  26 ;; macrolet
  27 ;; labels
  28 ;;
  29 ;;~ block
  30 ;; catch
  31 ;;~ return-from
  32 ;; throw
  33 ;;~ unwind-protect
  34 ;;
  35 ;; progv
  36 ;;
  37 ;; multiple-value-call
  38 ;; multiple-value-prog1
  39 ;;
  40 ;; the
  41 ;;
  42 ;; load-time-value
  43 ;; eval-when
  44 ;; locally
  45
  46
  47 (define-special* progn (cdr)
  48   (loop for rest on cdr
  49      for form = (car rest)
  50      for next = (cdr rest)
  51      append (scompile form)
  52      ;; ignore return values from intermediate steps
  53      when (or next (and (consp form) (eql (car form) 'return)))
  54      append '((:pop))))
  55
  56 ;; (scompile '(progn "foo" "bar" :true))
  57
  58
  59 (define-special let (bindings &rest body)
  60   (let ((bindings-indices
  61          (loop for binding in bindings
  62             for j from (last-local-index)
  63             for init = (if (listp binding) (second binding) nil)
  64             for name = (if (listp binding) (first binding) binding)
  65             collect `(,init ,name . ,j))))
  66     (with-cleanup ((gensym "LET-CLEANUP")
  67                      `(%asm (:comment "let-kill")
  68                            ,@(loop for (nil nil . index) in bindings-indices
  69                                 collect `(:kill ,index))
  70                            (:push-null)))
  71      (append
  72       ;; set up bindings
  73       (loop for (init nil . index) in bindings-indices
  74          append (scompile init)
  75          collect `(:set-local ,index ))
  76       (with-local-vars ((mapcar 'cdr bindings-indices))
  77         ;; compile the body as a progn, and kill the locals on exit
  78         `(,@(scompile
  79              `(progn ,@body))
  80             ,@(loop for (nil nil . index) in bindings-indices
  81                  collect `(:kill ,index))))))))
  82 ;; (with-lambda-context (:args '(foo)) (scompile '(let ((foo 1.23) (bar foo)) foo)))
  83
  84 (define-special %set-local (local value)
  85   ;; (%set-local var value) -> value
  86   `(,@(scompile value) ;; calculate value
  87       (:dup)                   ;; copy value so we can reurn it
  88       (:set-local ,(or (get-lambda-local-index local) (break)))))
  89 ;; (with-lambda-context (foo) (scompile '(%set-local foo 2.3)))
  90
  91 (define-special %asm (&rest cdr)
  92   ;; (%asm (op1 args) (op2 ...) ... )
  93   (mapcar (lambda (x)
  94             (case (first x)
  95               (:@ `(:get-local ,(get-lambda-local-index (second x))))
  96               (:@kill `(:kill ,(get-lambda-local-index (second x))))
  97               (otherwise x)))
  98           cdr))
  99
 100 (define-special %label (target)
 101   ;; (%label name) ;; for reverse jumps only
 102   `((:%label ,target)
 103     ;; hack since we always pop after each statement in a progn, gets
 104     ;; removed later by peephole pass
 105     (:push-null)))
 106
 107 (define-special %dlabel (target)
 108   ;; (%dlabel name) ;; for forward jumps only
 109   `((:%dlabel ,target)
 110     (:push-null)))
 111
 112 (define-special %go (target)
 113   ;; (go asm-label)
 114   `((:jump ,target)
 115     (:push-null)))
 116
 117 (define-special* tagbody (body)
 118   (let ((tags (loop for tag-or-form in body
 119                  when (atom tag-or-form)
 120                  collect (cons tag-or-form
 121                                (gensym (format nil "TAGBODY-~a-" tag-or-form))))))
 122     (with-nested-lambda-tags (tags)
 123       ;; fixme: use dlabel for forward jumps
 124       `(,@(loop for tag-or-form in body
 125              if (atom tag-or-form)
 126              collect `(:%label ,(get-lambda-tag tag-or-form))
 127              else
 128              append (scompile tag-or-form)
 129              and collect `(:pop))
 130           (:push-null)))))
 131
 132 (define-special go (tag)
 133   (scompile-cons '%go (list (get-lambda-tag tag))))
 134
 135 ;; (with-lambda-context () (scompile '(tagbody foo (go baz) bar 1 baz 2)))
 136
 137 (define-special %if (cond false-test true-branch false-branch)
 138   (let ((false-label (gensym "%IF-FALSE-"))
 139         (end-label (gensym "%IF-END-")))
 140     `(,@(scompile cond)
 141         (,false-test ,false-label)
 142         ,@(scompile true-branch)
 143         (:jump ,end-label)
 144         (:%dlabel ,false-label)
 145         ,@(scompile false-branch)
 146         (:%dlabel ,end-label))))
 147
 148 (define-special if (cond true-branch false-branch)
 149   `(,@(scompile `(%if ,cond :if-false ,true-branch ,false-branch))))
 150
 151 ;; (avm2-asm::with-assembler-context (avm2-asm::code (avm2-asm:assemble-method-body (scompile '(when :true 1)) )))
 152
 153
 154 (define-special %inc-local-i (var)
 155   ;; (%inc-local-i var)
 156   `((:inc-local-i ,(get-lambda-local-index var))
 157     ;; hack since we always pop after each statement in a progn :/
 158     (:get-local ,(get-lambda-local-index var))))
 159
 160
 161 ;;(scompile '(and))
 162 ;;(scompile '(and 1))
 163 ;;(scompile '(and 1 2))
 164
 165
 166 (define-special* %array (args)
 167   ;; (%array ... ) -> array
 168   `(,@(loop for i in args
 169          append (scompile i)) ;; calculate args
 170       (:new-array ,(length args))))
 171
 172
 173 (define-special %error (value)
 174   `(,@(scompile value)
 175       (:throw)))
 176
 177 (define-special %typep (object type)
 178   `(,@(scompile object)
 179       (:get-lex ,(or (swf-name (find-swf-class type)) type))
 180       (:is-type-late )))
 181
 182
 183 (define-special %type-of (object)
 184   `(,@(scompile object)
 185       (:type-of)))
 186
 187
 188 ;;; block/return-from
 189 ;;;
 190 ;;; store list of blocks in context, each block has cleanup code and a jump target?
 191 ;;
 192 ;; return-from needs to be careful with stack, if it isn't just
 193 ;;   calling :Return-foo
 194 #||
 195 ;; simple case:
 196  (block foo (return-from foo 1))
 197  push block foo, label = (gensym block-foo)
 198    ,@body
 199       ,@compile return-value
 200       jump ,label
 201    dlabel ,label
 202  pop block
 203
 204 ;; simple uwp
 205  (block bleh (unwind-protect (return-from bleh 1) 2))
 206  push block bleh, label1 = gensym
 207    push block uwp, label2 = gensym, cleanup = gensym
 208      ,@compile return-value = 1
 209      set-local foo <index of goto to come back here>
 210      jump cleanup
 211      label %foo
 212      jump label1
 213      dlabel cleanup
 214      ,@compile cleanup = 2
 215      pop
 216      computed-goto back to %foo
 217      dlabel label2
 218    pop block uwp
 219    dlabel label1
 220  pop block bleh
 221
 222 ;; misc tests:
 223  (block bleh (unwind-protect (unwind-protect 1 2) 3))
 224
 225
 226 ||#
 227 (define-special block (name &body body)
 228   (let ((end (gensym "BLOCK-END-")))
 229     (with-nested-lambda-block ((cons name (make-lambda-block name end nil end))
 230                                end)
 231       `(,@(scompile `(progn ,@body))
 232           (:set-local ,(get-lambda-local-index end))
 233           (:%dlabel ,end)
 234           (:get-local ,(get-lambda-local-index end))))))
 235
 236 (define-special %flet ((fn-name (&rest fn-args) &body fn-body) &body body)
 237   "limited version of flet, only handles 1 function, can't manipulate
 238 the function directly, can only call it within the current function,
 239 only normal args (no &rest,&key,&optional,etc)
 240 call with %flet-call, which sets up hidden return label arg
 241 "
 242   ;; todo: handle multiple functions?
 243   ;; fixme:would be nicer to put these at the end with the continuation table,
 244   ;; but just compiling inline with a jump over it for now...
 245   (let* ((end-label (gensym "%FLET-END-"))
 246          (return-arg (gensym "%FLET-CONTINUATION-"))
 247          (locals (loop for arg in (cons return-arg fn-args)
 248                     for j from (last-local-index)
 249                     collect (cons arg j))))
 250     ;; locals for a flet are ugly, since they need to keep their
 251     ;; indices allocated during body, but names are only valid during
 252     ;; fn-body, so we wrap both in with-local-vars, but kill the names
 253     ;; after fn-body
 254     ;; we also add an implicit 'return' param to specify the continuation
 255     (with-local-vars (locals)
 256       ;;fixme: hack- write real code for this
 257       (push (cons fn-name locals) (%flets *current-lambda*))
 258       `((:jump ,end-label)
 259         (:%label ,fn-name)
 260         ;; load parameters into regs
 261         #+nil,@(loop for (nil . i) in locals
 262              collect `(:set-local ,i) into temp
 263              finally (return (nreverse temp)))
 264         ;; compile %flet body
 265         ,@(scompile `(progn ,@fn-body))
 266         ;; store return value
 267         (:set-local ,(get-lambda-local-index (local-return-var *current-lambda*)))
 268         ;; push return address index
 269         (:get-local ,(get-lambda-local-index return-arg))
 270         (:set-local ,(get-lambda-local-index (continuation-var *current-lambda*)))
 271         ;; kill locals
 272         ,@(loop for (nil . i) in locals
 273              collect `(:kill ,i))
 274         ;; return through continuation table
 275         (:jump ,(continuation-var *current-lambda*))
 276         ;; remove local variable names from current scope (keeping indices used)
 277         ,@(progn (kill-lambda-local-names fn-args)
 278                  nil)
 279         (:%dlabel ,end-label)
 280         ;; compile main body
 281         ,@(scompile `(progn ,@body))))))
 282
 283 (define-special call-%flet (name &rest args)
 284   (let* ((continuation-label (gensym "CALL-%FLET-CONTINUATION-"))
 285          (continuation-index (add-lambda-local-continuation continuation-label))
 286          (arg-indices (cdr (assoc name (%flets *current-lambda*)))))
 287     `((:push-int ,continuation-index)
 288       (:coerce-any)
 289       (:set-local ,(cdr (car arg-indices)))
 290       ,@(loop for arg in args
 291            for (nil . i) in (cdr arg-indices)
 292            append (scompile arg)
 293            collect `(:set-local ,i))
 294       (:comment "call-%flet" ,name ,(%flets *current-lambda*) ,(unless name (break)))
 295       (:jump ,name)
 296       ;; need real label instead of dlabel, since we jump backwards
 297       ;; from lookupswitch at end
 298       (:%label ,continuation-label)
 299       ;; get return value
 300       (:get-local ,(get-lambda-local-index (local-return-var *current-lambda*))))))
 301
 302 (define-special return-from (name &optional value)
 303   (let ((block (get-lambda-block name))
 304         (cleanups (get-lambda-cleanups name)))
 305     `(,@(scompile value)
 306         (:set-local ,(get-lambda-local-index (return-var block)))
 307         ,@(loop for i in cleanups
 308              collect `(:comment "return-from cleanup" ,i ,cleanups ,(blocks *current-lambda*))
 309              append (scompile i)
 310              collect `(:comment "return-from cleanup done")
 311              collect '(:pop))
 312        (:jump ,(end-label block)))))
 313
 314 (define-special %with-cleanup ((name code) form)
 315   (with-cleanup (name code)
 316     (scompile form)))
 317
 318 (define-special unwind-protect (protected &body cleanup)
 319   (let ((cleanup-name (gensym "UWP-CLEANUP-")))
 320       (scompile
 321        `(%flet (,cleanup-name () ,@cleanup)
 322                (%with-cleanup (,cleanup-name (call-%flet ,cleanup-name))
 323                               (prog1
 324                                   ,protected
 325                                 (call-%flet ,cleanup-name)))))))
 326
 327 ;;(scompile '(list (list 1) (list 2)))
 328 ;;(scompile '(list 1))
 329 ;;(scompile '(quote (1 2 3)))
 330 ;;(scompile '(list '(list 1 2 3)))
 331
 332 ;;; internal aref, handles single dimensional flash::Array
 333 (define-special %aref-1 (array index)
 334   `(,@(scompile array)
 335     ,@(scompile index)
 336       (:get-property (:multiname-l "" ""))))
 337
 338
 339 (define-special %set-aref-1 (array index value)
 340   `(,@(scompile array)
 341     ,@(scompile index)
 342     ,@(scompile value)
 343       (:set-property (:multiname-l "" ""))))
 344
 345
 346 ;;(scompile '(list* 1  2 3 4 5))
 347 ;;(scompile '(list* 1))
 348
 349 (define-special function (arg &optional object)
 350   ;; fixme: not all branches tested yet...
 351   (let ((tmp))
 352     (cond
 353       ;; if OPERATOR is a known method, call with %call-property
 354       ;;  (prop obj args...) === obj.prop(args)
 355       ((setf tmp (find-swf-method arg *symbol-table*))
 356        (break "f-s-m ~s" tmp)
 357        (scompile `(%get-property ,(swf-name tmp) ,object )))
 358
 359       ;; if OPERATOR is a known static method, call with %call-lex-prop
 360       ;;  (prop obj args...) === obj.prop(args)
 361       ((setf tmp (find-swf-static-method arg *symbol-table*))
 362        (scompile `(%get-lex-prop ,(first tmp) ,(second tmp))))
 363
 364       ;; todo: decide if we should do something for the pretend accessors?
 365
 366       ;; normal function call, find-prop-strict + call-property
 367       ((setf tmp (find-swf-function arg *symbol-table*))
 368        (break "f-s-f ~s" tmp)
 369        (scompile `(%get-property-without-object ,tmp)))
 370
 371       ;; default = normal call?
 372       ;; fixme: might be nicer if we could detect unknown functions
 373       (t
 374        (scompile `(%get-property-without-object ,arg))))))
 375
 376 (define-special quote (object)
 377   (%quote object))
 378
 379 #+nil(dump-defun-asm (&arest rest) 'a)
 380 #+nil(dump-defun-asm (&arest rest) '1)
 381
 382
 383 #+nil(with-lambda-context ()
 384   (scompile '(block foo 2 (if nil (return-from foo 4) 5) 3)))
 385
 386
 387 #+nil
 388 (avm2-asm::avm2-disassemble
 389  (avm2-asm::code
 390   (avm2-asm::with-assembler-context
 391     (avm2-asm::assemble-method-body
 392      (with-simple-lambda-context ()
 393        (append
 394         '((:%label foo))
 395         (scompile '(%flet (bleh (a b c) (+ a b c))
 396                     (+ (call-%flet bleh 1 2 3)
 397                      (call-%flet bleh 5 6 7))))
 398         (compile-lambda-context-cleanup 'foo)))))))
 399
 400
 401 #+nil
 402 (avm2-asm::avm2-disassemble
 403  (avm2-asm::code
 404   (avm2-asm::with-assembler-context
 405     (avm2-asm::assemble-method-body
 406 (dump-defun-asm () (let ((s2 "<"))
 407                           (block foo
 408                             (unwind-protect
 409                                  (progn
 410                                    (return-from foo "-ret-")
 411                                    "bleh")
 412                               "baz"))
 413                           (+ s2 ">"))) ) ) ))