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 ,(get-lambda-local-index local))))
 122 ;; (with-lambda-context (foo) (scompile '(%set-local foo 2.3)))
 123
 124 (define-special %asm (&rest cdr)
 125   ;; todo: add a version (or option?) to compile args, so we don't need to guess local indices, or compile them by hand
 126   ;; (%asm (op1 args) (op2 ...) ... )
 127   (copy-list cdr))
 128
 129
 130 (define-special %label (target)
 131   ;; (%label name) ;; for reverse jumps only
 132   `((:%label ,target)
 133     ;; hack since we always pop after each statement in a progn, gets
 134     ;; removed later by peephole pass
 135     (:push-null)))
 136
 137 (define-special %dlabel (target)
 138   ;; (%dlabel name) ;; for forward jumps only
 139   `((:%dlabel ,target)
 140     (:push-null)))
 141
 142 (define-special %go (target)
 143   ;; (go asm-label)
 144   `((:jump ,target)
 145     (:push-null)))
 146
 147 (define-special* tagbody (body)
 148   (let ((tags (loop for tag-or-form in body
 149                  when (atom tag-or-form)
 150                  collect (cons tag-or-form
 151                                (gensym (format nil "TAGBODY-~a-" tag-or-form))))))
 152     (with-nested-lambda-tags (tags)
 153       ;; fixme: use dlabel for forward jumps
 154       `(,@(loop for tag-or-form in body
 155              if (atom tag-or-form)
 156              collect `(:%label ,(get-lambda-tag tag-or-form))
 157              else
 158              append (scompile tag-or-form)
 159              and collect `(:pop))
 160           (:push-null)))))
 161
 162 (define-special go (tag)
 163   (scompile-cons '%go (list (get-lambda-tag tag))))
 164
 165 ;; (with-lambda-context () (scompile '(tagbody foo (go baz) bar 1 baz 2)))
 166
 167 (define-special %when (cond label)
 168   ;; (%when cond label)
 169   `(,@(scompile cond)
 170       (:if-true ,label)
 171       (:push-null)))
 172
 173 #+nil(define-special when (cond &rest body)
 174   ;; (when cond body)
 175     (let ((label (gensym "WHEN1-"))
 176           (label2 (gensym "WHEN2-")))
 177       `(,@(scompile cond)
 178           (:if-false ,label)
 179           ,@(scompile `(progn ,@body))
 180           (:jump ,label2)
 181           (:%dlabel ,label)
 182           (:push-null)
 183           (:coerce-any)
 184           (:%dlabel ,label2))))
 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 ,type)
 282       (:is-type-late )))
 283
 284 (define-special %type-of (object)
 285   `(,@(scompile object)
 286       (:type-of)))
 287
 288
 289 ;;; block/return-from
 290 ;;;
 291 ;;; store list of blocks in context, each block has cleanup code and a jump target?
 292 ;;
 293 ;; return-from needs to be careful with stack, if it isn't just
 294 ;;   calling :Return-foo
 295 #||
 296 ;; simple case:
 297  (block foo (return-from foo 1))
 298  push block foo, label = (gensym block-foo)
 299    ,@body
 300       ,@compile return-value
 301       jump ,label
 302    dlabel ,label
 303  pop block
 304
 305 ;; simple uwp
 306  (block bleh (unwind-protect (return-from bleh 1) 2))
 307  push block bleh, label1 = gensym
 308    push block uwp, label2 = gensym, cleanup = gensym
 309      ,@compile return-value = 1
 310      set-local foo <index of goto to come back here>
 311      jump cleanup
 312      label %foo
 313      jump label1
 314      dlabel cleanup
 315      ,@compile cleanup = 2
 316      pop
 317      computed-goto back to %foo
 318      dlabel label2
 319    pop block uwp
 320    dlabel label1
 321  pop block bleh
 322
 323 ;; misc tests:
 324  (block bleh (unwind-protect (unwind-protect 1 2) 3))
 325
 326
 327 ||#
 328 (define-special block (name &body body)
 329   (let ((end (gensym "BLOCK-END-")))
 330     (with-nested-lambda-block ((cons name (make-lambda-block name end nil end))
 331                                end)
 332       `(,@(scompile `(progn ,@body))
 333           (:set-local ,(get-lambda-local-index end))
 334           (:%dlabel ,end)
 335           (:get-local ,(get-lambda-local-index end))))))
 336
 337 (define-special %flet ((fn-name (&rest fn-args) &body fn-body) &body body)
 338   "limited version of flet, only handles 1 function, can't manipulate
 339 the function directly, can only call it within the current function,
 340 only normal args (no &rest,&key,&optional,etc)
 341 call with %flet-call, which sets up hidden return label arg
 342 "
 343   ;; todo: handle multiple functions?
 344   ;; fixme:would be nicer to put these at the end with the continuation table,
 345   ;; but just compiling inline with a jump over it for now...
 346   (let* ((end-label (gensym "%FLET-END-"))
 347          (return-arg (gensym "%FLET-CONTINUATION-"))
 348          (locals (loop for arg in (cons return-arg fn-args)
 349                     for j from (last-local-index)
 350                     collect (cons arg j))))
 351     ;; locals for a flet are ugly, since they need to keep their
 352     ;; indices allocated during body, but names are only valid during
 353     ;; fn-body, so we wrap both in with-local-vars, but kill the names
 354     ;; after fn-body
 355     ;; we also add an implicit 'return' param to specify the continuation
 356     (with-local-vars (locals)
 357       ;;fixme: hack- write real code for this
 358       (push (cons fn-name locals) (%flets *current-lambda*))
 359       `((:jump ,end-label)
 360         (:%label ,fn-name)
 361         ;; load parameters into regs
 362         #+nil,@(loop for (nil . i) in locals
 363              collect `(:set-local ,i) into temp
 364              finally (return (nreverse temp)))
 365         ;; compile %flet body
 366         ,@(scompile `(progn ,@fn-body))
 367         ;; store return value
 368         (:set-local ,(get-lambda-local-index (local-return-var *current-lambda*)))
 369         ;; push return address index
 370         (:get-local ,(get-lambda-local-index return-arg))
 371         (:set-local ,(get-lambda-local-index (continuation-var *current-lambda*)))
 372         ;; kill locals
 373         ,@(loop for (nil . i) in locals
 374              collect `(:kill ,i))
 375         ;; return through continuation table
 376         (:jump ,(continuation-var *current-lambda*))
 377         ;; remove local variable names from current scope (keeping indices used)
 378         ,@(progn (kill-lambda-local-names fn-args)
 379                  nil)
 380         (:%dlabel ,end-label)
 381         ;; compile main body
 382         ,@(scompile `(progn ,@body))))))
 383
 384 (define-special call-%flet (name &rest args)
 385   (let* ((continuation-label (gensym "CALL-%FLET-CONTINUATION-"))
 386          (continuation-index (add-lambda-local-continuation continuation-label))
 387          (arg-indices (cdr (assoc name (%flets *current-lambda*)))))
 388     `((:push-int ,continuation-index)
 389       (:coerce-any)
 390       (:set-local ,(cdr (car arg-indices)))
 391       ,@(loop for arg in args
 392            for (nil . i) in (cdr arg-indices)
 393            append (scompile arg)
 394            collect `(:set-local ,i))
 395       (:comment "call-%flet" ,name ,(%flets *current-lambda*) ,(unless name (break)))
 396       (:jump ,name)
 397       ;; need real label instead of dlabel, since we jump backwards
 398       ;; from lookupswitch at end
 399       (:%label ,continuation-label)
 400       ;; get return value
 401       (:get-local ,(get-lambda-local-index (local-return-var *current-lambda*))))))
 402
 403 (define-special return-from (name &optional value)
 404   (let ((block (get-lambda-block name))
 405         (cleanups (get-lambda-cleanups name)))
 406     `(,@(scompile value)
 407         (:set-local ,(get-lambda-local-index (return-var block)))
 408         ,@(loop for i in cleanups
 409              collect `(:comment "return-from cleanup" ,i ,cleanups ,(blocks *current-lambda*))
 410              append (scompile i)
 411              collect `(:comment "return-from cleanup done")
 412              collect '(:pop))
 413        (:jump ,(end-label block)))))
 414
 415 (define-special prog1 (value-form &body body)
 416   (let ((temp (gensym "PROG1-VALUE-")))
 417         (scompile
 418          `(let ((,temp ,value-form))
 419                            (progn
 420                              ,@body
 421                              ,temp)))))
 422
 423 (define-special %with-cleanup ((name code) form)
 424   (with-cleanup (name code)
 425     (scompile form)))
 426
 427 (define-special unwind-protect (protected &body cleanup)
 428   (let ((cleanup-name (gensym "UWP-CLEANUP-")))
 429       (scompile
 430        `(%flet (,cleanup-name () ,@cleanup)
 431                (%with-cleanup (,cleanup-name (call-%flet ,cleanup-name))
 432                               (prog1
 433                                   ,protected
 434                                 (call-%flet ,cleanup-name)))))))
 435
 436 (define-special* list (rest)
 437   (labels ((expand-rest (rest)
 438              (if (consp rest)
 439                  (list 'cons (car rest) (expand-rest (cdr rest)))
 440                  rest)))
 441     (scompile (expand-rest rest))))
 442
 443 (define-special* list* (rest)
 444   (labels ((expand-rest (rest)
 445              (if (consp (cdr rest))
 446                  (list 'cons (car rest) (expand-rest (cdr rest)))
 447                  (car rest))))
 448     (when (endp rest)
 449       (error "not enough arguments to LIST*"))
 450     (scompile (expand-rest rest))))
 451
 452 ;;; partial implementation of aref, handles single dimensional flash::Array
 453 (define-special aref (array index)
 454   `(,@(scompile array)
 455     ,@(scompile index)
 456       (:get-property (:multiname-l "" ""))))
 457
 458
 459 ;;(scompile '(list* 1  2 3 4 5))
 460 ;;(scompile '(list* 1))
 461
 462 #+nil(with-lambda-context ()
 463   (scompile '(block foo 2 (if nil (return-from foo 4) 5) 3)))
 464
 465
 466 #+nil
 467 (avm2-asm::avm2-disassemble
 468  (avm2-asm::code
 469   (avm2-asm::with-assembler-context
 470     (avm2-asm::assemble-method-body
 471      (with-simple-lambda-context ()
 472        (append
 473         '((:%label foo))
 474         (scompile '(%flet (bleh (a b c) (+ a b c))
 475                     (+ (call-%flet bleh 1 2 3)
 476                      (call-%flet bleh 5 6 7))))
 477         (compile-lambda-context-cleanup 'foo)))))))
 478
 479
 480 #+nil
 481 (avm2-asm::avm2-disassemble
 482  (avm2-asm::code
 483   (avm2-asm::with-assembler-context
 484     (avm2-asm::assemble-method-body
 485 (dump-defun-asm () (let ((s2 "<"))
 486                           (block foo
 487                             (unwind-protect
 488                                  (progn
 489                                    (return-from foo "-ret-")
 490                                    "bleh")
 491                               "baz"))
 492                           (+ s2 ">"))) ) ) ))