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 (define-special %asm* (args &rest cdr)
 100   ;; (%asm* (arg list) (op1 args) (op2 ...) ... )
 101   (append
 102    (loop for arg in args
 103       append (scompile arg))
 104     (copy-list cdr)))
 105
 106
 107 (define-special %label (target)
 108   ;; (%label name) ;; for reverse jumps only
 109   `((:%label ,target)
 110     ;; hack since we always pop after each statement in a progn, gets
 111     ;; removed later by peephole pass
 112     (:push-null)))
 113
 114 (define-special %dlabel (target)
 115   ;; (%dlabel name) ;; for forward jumps only
 116   `((:%dlabel ,target)
 117     (:push-null)))
 118
 119 (define-special %go (target)
 120   ;; (go asm-label)
 121   `((:jump ,target)
 122     (:push-null)))
 123
 124 (define-special* tagbody (body)
 125   (let ((tags (loop for tag-or-form in body
 126                  when (atom tag-or-form)
 127                  collect (cons tag-or-form
 128                                (gensym (format nil "TAGBODY-~a-" tag-or-form))))))
 129     (with-nested-lambda-tags (tags)
 130       ;; fixme: use dlabel for forward jumps
 131       `(,@(loop for tag-or-form in body
 132              if (atom tag-or-form)
 133              collect `(:%label ,(get-lambda-tag tag-or-form))
 134              else
 135              append (scompile tag-or-form)
 136              and collect `(:pop))
 137           (:push-null)))))
 138
 139 (define-special go (tag)
 140   (scompile-cons '%go (list (get-lambda-tag tag))))
 141
 142 (define-special %go-when (cond tag)
 143   (scompile-cons '%when (list cond (get-lambda-tag tag))))
 144
 145 ;; (with-lambda-context () (scompile '(tagbody foo (go baz) bar 1 baz 2)))
 146
 147 (define-special %when (cond label)
 148   ;; (%when cond label)
 149   `(,@(scompile cond)
 150       (:if-true ,label)
 151       (:push-null)))
 152
 153 (define-special %if (cond false-test true-branch false-branch)
 154   (let ((false-label (gensym "%IF-FALSE-"))
 155         (end-label (gensym "%IF-END-")))
 156     `(,@(scompile cond)
 157         (,false-test ,false-label)
 158         ,@(scompile true-branch)
 159         (:jump ,end-label)
 160         (:%dlabel ,false-label)
 161         ,@(scompile false-branch)
 162         (:%dlabel ,end-label))))
 163
 164 (define-special if (cond true-branch false-branch)
 165   `(,@(scompile `(%if ,cond :if-false ,true-branch ,false-branch))))
 166
 167 ;; (avm2-asm::with-assembler-context (avm2-asm::code (avm2-asm:assemble-method-body (scompile '(when :true 1)) )))
 168
 169
 170 (define-special %inc-local-i (var)
 171   ;; (%inc-local-i var)
 172   `((:inc-local-i ,(get-lambda-local-index var))
 173     ;; hack since we always pop after each statement in a progn :/
 174     (:get-local ,(get-lambda-local-index var))))
 175
 176
 177 ;;(scompile '(and))
 178 ;;(scompile '(and 1))
 179 ;;(scompile '(and 1 2))
 180
 181
 182 (define-special* %array (args)
 183   ;; (%array ... ) -> array
 184   `(,@(loop for i in args
 185          append (scompile i)) ;; calculate args
 186       (:new-array ,(length args))))
 187
 188
 189 (define-special %error (value)
 190   `(,@(scompile value)
 191       (:throw)))
 192
 193 (define-special %typep (object type)
 194   `(,@(scompile object)
 195       (:get-lex ,(or (swf-name (find-swf-class type)) type))
 196       (:is-type-late )))
 197
 198
 199 (define-special %type-of (object)
 200   `(,@(scompile object)
 201       (:type-of)))
 202
 203
 204 ;;; block/return-from
 205 ;;;
 206 ;;; store list of blocks in context, each block has cleanup code and a jump target?
 207 ;;
 208 ;; return-from needs to be careful with stack, if it isn't just
 209 ;;   calling :Return-foo
 210 #||
 211 ;; simple case:
 212  (block foo (return-from foo 1))
 213  push block foo, label = (gensym block-foo)
 214    ,@body
 215       ,@compile return-value
 216       jump ,label
 217    dlabel ,label
 218  pop block
 219
 220 ;; simple uwp
 221  (block bleh (unwind-protect (return-from bleh 1) 2))
 222  push block bleh, label1 = gensym
 223    push block uwp, label2 = gensym, cleanup = gensym
 224      ,@compile return-value = 1
 225      set-local foo <index of goto to come back here>
 226      jump cleanup
 227      label %foo
 228      jump label1
 229      dlabel cleanup
 230      ,@compile cleanup = 2
 231      pop
 232      computed-goto back to %foo
 233      dlabel label2
 234    pop block uwp
 235    dlabel label1
 236  pop block bleh
 237
 238 ;; misc tests:
 239  (block bleh (unwind-protect (unwind-protect 1 2) 3))
 240
 241
 242 ||#
 243 (define-special block (name &body body)
 244   (let ((end (gensym "BLOCK-END-")))
 245     (with-nested-lambda-block ((cons name (make-lambda-block name end nil end))
 246                                end)
 247       `(,@(scompile `(progn ,@body))
 248           (:set-local ,(get-lambda-local-index end))
 249           (:%dlabel ,end)
 250           (:get-local ,(get-lambda-local-index end))))))
 251
 252 (define-special %flet ((fn-name (&rest fn-args) &body fn-body) &body body)
 253   "limited version of flet, only handles 1 function, can't manipulate
 254 the function directly, can only call it within the current function,
 255 only normal args (no &rest,&key,&optional,etc)
 256 call with %flet-call, which sets up hidden return label arg
 257 "
 258   ;; todo: handle multiple functions?
 259   ;; fixme:would be nicer to put these at the end with the continuation table,
 260   ;; but just compiling inline with a jump over it for now...
 261   (let* ((end-label (gensym "%FLET-END-"))
 262          (return-arg (gensym "%FLET-CONTINUATION-"))
 263          (locals (loop for arg in (cons return-arg fn-args)
 264                     for j from (last-local-index)
 265                     collect (cons arg j))))
 266     ;; locals for a flet are ugly, since they need to keep their
 267     ;; indices allocated during body, but names are only valid during
 268     ;; fn-body, so we wrap both in with-local-vars, but kill the names
 269     ;; after fn-body
 270     ;; we also add an implicit 'return' param to specify the continuation
 271     (with-local-vars (locals)
 272       ;;fixme: hack- write real code for this
 273       (push (cons fn-name locals) (%flets *current-lambda*))
 274       `((:jump ,end-label)
 275         (:%label ,fn-name)
 276         ;; load parameters into regs
 277         #+nil,@(loop for (nil . i) in locals
 278              collect `(:set-local ,i) into temp
 279              finally (return (nreverse temp)))
 280         ;; compile %flet body
 281         ,@(scompile `(progn ,@fn-body))
 282         ;; store return value
 283         (:set-local ,(get-lambda-local-index (local-return-var *current-lambda*)))
 284         ;; push return address index
 285         (:get-local ,(get-lambda-local-index return-arg))
 286         (:set-local ,(get-lambda-local-index (continuation-var *current-lambda*)))
 287         ;; kill locals
 288         ,@(loop for (nil . i) in locals
 289              collect `(:kill ,i))
 290         ;; return through continuation table
 291         (:jump ,(continuation-var *current-lambda*))
 292         ;; remove local variable names from current scope (keeping indices used)
 293         ,@(progn (kill-lambda-local-names fn-args)
 294                  nil)
 295         (:%dlabel ,end-label)
 296         ;; compile main body
 297         ,@(scompile `(progn ,@body))))))
 298
 299 (define-special call-%flet (name &rest args)
 300   (let* ((continuation-label (gensym "CALL-%FLET-CONTINUATION-"))
 301          (continuation-index (add-lambda-local-continuation continuation-label))
 302          (arg-indices (cdr (assoc name (%flets *current-lambda*)))))
 303     `((:push-int ,continuation-index)
 304       (:coerce-any)
 305       (:set-local ,(cdr (car arg-indices)))
 306       ,@(loop for arg in args
 307            for (nil . i) in (cdr arg-indices)
 308            append (scompile arg)
 309            collect `(:set-local ,i))
 310       (:comment "call-%flet" ,name ,(%flets *current-lambda*) ,(unless name (break)))
 311       (:jump ,name)
 312       ;; need real label instead of dlabel, since we jump backwards
 313       ;; from lookupswitch at end
 314       (:%label ,continuation-label)
 315       ;; get return value
 316       (:get-local ,(get-lambda-local-index (local-return-var *current-lambda*))))))
 317
 318 (define-special return-from (name &optional value)
 319   (let ((block (get-lambda-block name))
 320         (cleanups (get-lambda-cleanups name)))
 321     `(,@(scompile value)
 322         (:set-local ,(get-lambda-local-index (return-var block)))
 323         ,@(loop for i in cleanups
 324              collect `(:comment "return-from cleanup" ,i ,cleanups ,(blocks *current-lambda*))
 325              append (scompile i)
 326              collect `(:comment "return-from cleanup done")
 327              collect '(:pop))
 328        (:jump ,(end-label block)))))
 329
 330 (define-special prog1 (value-form &body body)
 331   (let ((temp (gensym "PROG1-VALUE-")))
 332         (scompile
 333          `(let ((,temp ,value-form))
 334                            (progn
 335                              ,@body
 336                              ,temp)))))
 337
 338 (define-special %with-cleanup ((name code) form)
 339   (with-cleanup (name code)
 340     (scompile form)))
 341
 342 (define-special unwind-protect (protected &body cleanup)
 343   (let ((cleanup-name (gensym "UWP-CLEANUP-")))
 344       (scompile
 345        `(%flet (,cleanup-name () ,@cleanup)
 346                (%with-cleanup (,cleanup-name (call-%flet ,cleanup-name))
 347                               (prog1
 348                                   ,protected
 349                                 (call-%flet ,cleanup-name)))))))
 350
 351 (define-special* list (rest)
 352   (labels ((expand-rest (rest)
 353              (if (consp rest)
 354                  (list 'cons (car rest) (expand-rest (cdr rest)))
 355                  rest)))
 356     (scompile (expand-rest rest))))
 357 ;;(scompile '(list (list 1) (list 2)))
 358 ;;(scompile '(list 1))
 359 ;;(scompile '(quote (1 2 3)))
 360 ;;(scompile '(list '(list 1 2 3)))
 361
 362 (define-special* list* (rest)
 363   (labels ((expand-rest (rest)
 364              (if (consp (cdr rest))
 365                  (list 'cons (car rest) (expand-rest (cdr rest)))
 366                  (car rest))))
 367     (when (endp rest)
 368       (error "not enough arguments to LIST*"))
 369     (scompile (expand-rest rest))))
 370
 371 ;;; internal aref, handles single dimensional flash::Array
 372 (define-special %aref-1 (array index)
 373   `(,@(scompile array)
 374     ,@(scompile index)
 375       (:get-property (:multiname-l "" ""))))
 376
 377
 378 (define-special %set-aref-1 (array index value)
 379   `(,@(scompile array)
 380     ,@(scompile index)
 381     ,@(scompile value)
 382       (:set-property (:multiname-l "" ""))))
 383
 384 ;;; temporary hack to get inlined cons/car/cdr, speeds up tests noticeably
 385 ;;;  types and better compilation should give a few orders of magnitude though
 386 (define-special cons (a b)
 387   `((:find-property-strict cons-type)
 388     ,@(scompile a)
 389     ,@(scompile b)
 390     (:construct-prop cons-type 2)
 391     (:coerce-any)))
 392
 393 ;;; coercing to cons-type before accessing slots is ~2x faster
 394 ;;; using get-slot instead of get-property is maybe a few % faster
 395 ;;; checking type explicitly is slow, so just using built-in check for now
 396 ;;;   (which works, but doesn't throw the CL specified error type)
 397 ;;; :get-lex might be the slow part, so putting cons-type in a global
 398 ;;;  might help speed of proper type check
 399 (define-special car (a) ;;; FIXME: handle non-cons properly
 400   (let ((temp (gensym "CAR-TEMP-")))
 401     `(,@(scompile
 402          `(let ((,temp ,a))
 403             (if (eq ,temp :null)
 404                 :null
 405                 (%asm* (,temp)
 406                        (:coerce cons-type)
 407                        #+nil(:get-property %car)
 408                        (:get-slot 1))))))))
 409
 410 (define-special cdr (a) ;;; FIXME: handle non-cons properly
 411   (let ((temp (gensym "CDR-TEMP-")))
 412     `(,@(scompile
 413          `(let ((,temp ,a))
 414             (if (eq ,temp :null)
 415                 :null
 416                 (%asm (:@ ,temp)
 417                       (:coerce cons-type)
 418                       #+nil(:get-property %cdr)
 419                       (:get-slot 2))))))))
 420
 421
 422
 423 ;;(scompile '(list* 1  2 3 4 5))
 424 ;;(scompile '(list* 1))
 425
 426 (define-special function (arg &optional object)
 427   ;; fixme: not all branches tested yet...
 428   (let ((tmp))
 429     (cond
 430       ;; if OPERATOR is a known method, call with %call-property
 431       ;;  (prop obj args...) === obj.prop(args)
 432       ((setf tmp (find-swf-method arg *symbol-table*))
 433        (break "f-s-m ~s" tmp)
 434        (scompile `(%get-property ,(swf-name tmp) ,object )))
 435
 436       ;; if OPERATOR is a known static method, call with %call-lex-prop
 437       ;;  (prop obj args...) === obj.prop(args)
 438       ((setf tmp (find-swf-static-method arg *symbol-table*))
 439        (scompile `(%get-lex-prop ,(first tmp) ,(second tmp))))
 440
 441       ;; todo: decide if we should do something for the pretend accessors?
 442
 443       ;; normal function call, find-prop-strict + call-property
 444       ((setf tmp (find-swf-function arg *symbol-table*))
 445        (break "f-s-f ~s" tmp)
 446        (scompile `(%get-property-without-object ,tmp)))
 447
 448       ;; default = normal call?
 449       ;; fixme: might be nicer if we could detect unknown functions
 450       (t
 451        (scompile `(%get-property-without-object ,arg))))))
 452
 453 (define-special quote (object)
 454   (%quote object))
 455
 456 #+nil(dump-defun-asm (&arest rest) 'a)
 457 #+nil(dump-defun-asm (&arest rest) '1)
 458
 459
 460 #+nil(with-lambda-context ()
 461   (scompile '(block foo 2 (if nil (return-from foo 4) 5) 3)))
 462
 463
 464 #+nil
 465 (avm2-asm::avm2-disassemble
 466  (avm2-asm::code
 467   (avm2-asm::with-assembler-context
 468     (avm2-asm::assemble-method-body
 469      (with-simple-lambda-context ()
 470        (append
 471         '((:%label foo))
 472         (scompile '(%flet (bleh (a b c) (+ a b c))
 473                     (+ (call-%flet bleh 1 2 3)
 474                      (call-%flet bleh 5 6 7))))
 475         (compile-lambda-context-cleanup 'foo)))))))
 476
 477
 478 #+nil
 479 (avm2-asm::avm2-disassemble
 480  (avm2-asm::code
 481   (avm2-asm::with-assembler-context
 482     (avm2-asm::assemble-method-body
 483 (dump-defun-asm () (let ((s2 "<"))
 484                           (block foo
 485                             (unwind-protect
 486                                  (progn
 487                                    (return-from foo "-ret-")
 488                                    "bleh")
 489                               "baz"))
 490                           (+ s2 ">"))) ) ) ))