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