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 (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                                 collect `(: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   ;; (%asm (op1 args) (op2 ...) ... )
 126   (copy-list cdr))
 127
 128
 129 (define-special %label (target)
 130   ;; (%label name) ;; for reverse jumps only
 131   `((:%label ,target)
 132     ;; hack since we always pop after each statement in a progn, gets
 133     ;; removed later by peephole pass
 134     (:push-null)))
 135
 136 (define-special %dlabel (target)
 137   ;; (%dlabel name) ;; for forward jumps only
 138   `((:%dlabel ,target)
 139     (:push-null)))
 140
 141 (define-special %go (target)
 142   ;; (go asm-label)
 143   `((:jump ,target)
 144     (:push-null)))
 145
 146 (define-special* tagbody (body)
 147   (let ((tags (loop for tag-or-form in body
 148                  when (atom tag-or-form)
 149                  collect (cons tag-or-form
 150                                (gensym (format nil "TAGBODY-~a-" tag-or-form))))))
 151     (with-nested-lambda-tags (tags)
 152       ;; fixme: use dlabel for forward jumps
 153       `(,@(loop for tag-or-form in body
 154              if (atom tag-or-form)
 155              collect `(:%label ,(get-lambda-tag tag-or-form))
 156              else
 157              append (scompile tag-or-form)
 158              and collect `(:pop))
 159           (:push-null)))))
 160
 161 (define-special go (tag)
 162   (scompile-cons '%go (list (get-lambda-tag tag))))
 163
 164 ;; (with-lambda-context () (scompile '(tagbody foo (go baz) bar 1 baz 2)))
 165
 166 (define-special %when (cond label)
 167   ;; (%when cond label)
 168   `(,@(scompile cond)
 169       (:if-true ,label)
 170       (:push-null)))
 171
 172 #+nil(define-special when (cond &rest body)
 173   ;; (when cond body)
 174     (let ((label (gensym "WHEN1-"))
 175           (label2 (gensym "WHEN2-")))
 176       `(,@(scompile cond)
 177           (:if-false ,label)
 178           ,@(scompile `(progn ,@body))
 179           (:jump ,label2)
 180           (:%dlabel ,label)
 181           (:push-null)
 182           (:coerce-any)
 183           (:%dlabel ,label2))))
 184
 185 (define-special %if (cond false-test true-branch false-branch)
 186   (let (#+nil(true-label (gensym "%IF-TRUE-"))
 187         (false-label (gensym "%IF-FALSE-"))
 188         (end-label (gensym "%IF-END-")))
 189     `(,@(scompile cond)
 190         (,false-test ,false-label)
 191         ,@(scompile true-branch)
 192         (:jump ,end-label)
 193         (:%dlabel ,false-label)
 194         ,@(scompile false-branch)
 195         (:%dlabel ,end-label))))
 196
 197 (define-special if (cond true-branch false-branch)
 198   `(,@(scompile `(%if ,cond :if-false ,true-branch ,false-branch))))
 199
 200 ;; (avm2-asm::with-assembler-context (avm2-asm::code (avm2-asm:assemble-method-body (scompile '(when :true 1)) )))
 201
 202
 203 (define-special %inc-local-i (var)
 204   ;; (%inc-local-i var)
 205   `((:inc-local-i ,(get-lambda-local-index var))
 206     ;; hack since we always pop after each statement in a progn :/
 207     (:get-local ,(get-lambda-local-index var))))
 208
 209 #+nil(define-special dotimes ((var count &optional result) &rest body)
 210   ;; (dotimes (var count &optional result) body)
 211
 212   ;; set local for counter
 213   ;; set local for limit
 214     ;;(format t "dotimes : var=~s count=~s result=~s~%body=~s~%" var count result body)
 215     (let ((label (gensym "LABEL-"))
 216           (label2 (gensym "LABEL2-"))
 217           (max (gensym "MAX-")))
 218       (scompile                         ; format t "~s"
 219        `(let ((,max ,count)
 220               ;; var should not be valid while evaluating max
 221               (,var 0))
 222           (%go ,label2)
 223           (%label ,label)
 224           ,@body
 225                                         ;(%set-local ,var (+ ,var 1))
 226           (%inc-local-i ,var)
 227           (%dlabel ,label2)
 228           (%when (%2< ,var ,max) ,label)
 229           ;; fixme: make sure var is still valid, and = max while evaluating result
 230           ,@(if result
 231                 '(result)
 232                 '((%asm
 233                    (:push-null)
 234                    (:coerce-any))))))))
 235
 236
 237
 238 #+nil(defmethod scompile-cons ((car (eql 'and)) cdr)
 239   (case (length cdr)
 240     (0 `((:push-true)))
 241     (1 (scompile (first cdr)))
 242     (t
 243      (let ((true-label (gensym "true-"))
 244            (false-label (gensym "false-")))
 245        (append
 246         (loop for first = t then nil
 247            for i in cdr
 248            unless first collect `(:pop)
 249            append (scompile i)
 250            collect `(:dup)
 251            collect `(:if-false ,false-label))
 252         `((:jump ,true-label)
 253           (:%dlabel ,false-label)
 254           (:pop)
 255           (:push-false)
 256           (:%dlabel ,true-label)))))))
 257
 258 ;;(scompile '(and))
 259 ;;(scompile '(and 1))
 260 ;;(scompile '(and 1 2))
 261
 262
 263 (define-special* %array (args)
 264   ;; (%array ... ) -> array
 265   `(,@(loop for i in args
 266          append (scompile i)) ;; calculate args
 267       (:new-array ,(length args))))
 268
 269
 270 (define-special %error (value)
 271   `(,@(scompile value)
 272       (:throw)))
 273
 274 #+nil(define-special %typep (object type)
 275   `(,@(scompile object)
 276       (:is-type ,type)))
 277
 278 (define-special %typep (object type)
 279   `(,@(scompile object)
 280       (:get-lex ,type)
 281       (:is-type-late )))
 282
 283 (define-special %type-of (object)
 284   `(,@(scompile object)
 285       (:type-of)))
 286
 287
 288 ;;; block/return-from
 289 ;;;
 290 ;;; store list of blocks in context, each block has cleanup code and a jump target?
 291 ;;
 292 ;; return-from needs to be careful with stack, if it isn't just
 293 ;;   calling :Return-foo
 294 #||
 295 ;; simple case:
 296  (block foo (return-from foo 1))
 297  push block foo, label = (gensym block-foo)
 298    ,@body
 299       ,@compile return-value
 300       jump ,label
 301    dlabel ,label
 302  pop block
 303
 304 ;; simple uwp
 305  (block bleh (unwind-protect (return-from bleh 1) 2))
 306  push block bleh, label1 = gensym
 307    push block uwp, label2 = gensym, cleanup = gensym
 308      ,@compile return-value = 1
 309      set-local foo <index of goto to come back here>
 310      jump cleanup
 311      label %foo
 312      jump label1
 313      dlabel cleanup
 314      ,@compile cleanup = 2
 315      pop
 316      computed-goto back to %foo
 317      dlabel label2
 318    pop block uwp
 319    dlabel label1
 320  pop block bleh
 321
 322 ;; misc tests:
 323  (block bleh (unwind-protect (unwind-protect 1 2) 3))
 324
 325
 326 ||#
 327 (define-special block (name &body body)
 328   (let ((end (gensym "BLOCK-END-")))
 329     (with-nested-lambda-block ((cons name (make-lambda-block name end nil end))
 330                                end)
 331       `(,@(scompile `(progn ,@body))
 332           (:set-local ,(get-lambda-local-index end))
 333           (:%dlabel ,end)
 334           (:get-local ,(get-lambda-local-index end))))))
 335
 336 (define-special %flet ((fn-name (&rest fn-args) &body fn-body) &body body)
 337   "limited version of flet, only handles 1 function, can't manipulate
 338 the function directly, can only call it within the current function,
 339 only normal args (no &rest,&key,&optional,etc)
 340 call with %flet-call, which sets up hidden return label arg
 341 "
 342   ;; todo: handle multiple functions?
 343   ;; fixme:would be nicer to put these at the end with the continuation table,
 344   ;; but just compiling inline with a jump over it for now...
 345   (let* ((end-label (gensym "%FLET-END-"))
 346          (return-arg (gensym "%FLET-CONTINUATION-"))
 347          (locals (loop for arg in (cons return-arg fn-args)
 348                     for j from (last-local-index)
 349                     collect (cons arg j))))
 350     ;; locals for a flet are ugly, since they need to keep their
 351     ;; indices allocated during body, but names are only valid during
 352     ;; fn-body, so we wrap both in with-local-vars, but kill the names
 353     ;; after fn-body
 354     ;; we also add an implicit 'return' param to specify the continuation
 355     (with-local-vars (locals)
 356       ;;fixme: hack- write real code for this
 357       (push (cons fn-name locals) (%flets *current-lambda*))
 358       `((:jump ,end-label)
 359         (:%label ,fn-name)
 360         ;; load parameters into regs
 361         #+nil,@(loop for (nil . i) in locals
 362              collect `(:set-local ,i) into temp
 363              finally (return (nreverse temp)))
 364         ;; compile %flet body
 365         ,@(scompile `(progn ,@fn-body))
 366         ;; store return value
 367         (:set-local ,(get-lambda-local-index (local-return-var *current-lambda*)))
 368         ;; push return address index
 369         (:get-local ,(get-lambda-local-index return-arg))
 370         (:set-local ,(get-lambda-local-index (continuation-var *current-lambda*)))
 371         ;; kill locals
 372         ,@(loop for (nil . i) in locals
 373              collect `(:kill ,i))
 374         ;; return through continuation table
 375         (:jump ,(continuation-var *current-lambda*))
 376         ;; remove local variable names from current scope (keeping indices used)
 377         ,@(progn (kill-lambda-local-names fn-args)
 378                  nil)
 379         (:%dlabel ,end-label)
 380         ;; compile main body
 381         ,@(scompile `(progn ,@body))))))
 382
 383 (define-special call-%flet (name &rest args)
 384   (let* ((continuation-label (gensym "CALL-%FLET-CONTINUATION-"))
 385          (continuation-index (add-lambda-local-continuation continuation-label))
 386          (arg-indices (cdr (assoc name (%flets *current-lambda*)))))
 387     `((:push-int ,continuation-index)
 388       (:coerce-any)
 389       (:set-local ,(cdr (car arg-indices)))
 390       ,@(loop for arg in args
 391            for (nil . i) in (cdr arg-indices)
 392            append (scompile arg)
 393            collect `(:set-local ,i))
 394       (:comment "call-%flet" ,name ,(%flets *current-lambda*) ,(unless name (break)))
 395       (:jump ,name)
 396       ;; need real label instead of dlabel, since we jump backwards
 397       ;; from lookupswitch at end
 398       (:%label ,continuation-label)
 399       ;; get return value
 400       (:get-local ,(get-lambda-local-index (local-return-var *current-lambda*))))))
 401
 402 (define-special return-from (name &optional value)
 403   (let ((block (get-lambda-block name))
 404         (cleanups (get-lambda-cleanups name)))
 405     `(,@(scompile value)
 406         (:set-local ,(get-lambda-local-index (return-var block)))
 407         ,@(loop for i in cleanups
 408              collect `(:comment "return-from cleanup" ,i ,cleanups ,(blocks *current-lambda*))
 409              append (scompile i)
 410              collect `(:comment "return-from cleanup done")
 411              collect '(:pop))
 412        (:jump ,(end-label block)))))
 413
 414 (define-special prog1 (value-form &body body)
 415   (let ((temp (gensym "PROG1-VALUE-")))
 416         (scompile
 417          `(let ((,temp ,value-form))
 418                            (progn
 419                              ,@body
 420                              ,temp)))))
 421
 422 (define-special %with-cleanup ((name code) form)
 423   (with-cleanup (name code)
 424     (scompile form)))
 425
 426 (define-special unwind-protect (protected &body cleanup)
 427   (let ((cleanup-name (gensym "UWP-CLEANUP-")))
 428       (scompile
 429        `(%flet (,cleanup-name () ,@cleanup)
 430                (%with-cleanup (,cleanup-name (call-%flet ,cleanup-name))
 431                               (prog1
 432                                   ,protected
 433                                 (call-%flet ,cleanup-name)))))))
 434
 435
 436
 437 #+nil(with-lambda-context ()
 438   (scompile '(block foo 2 (if nil (return-from foo 4) 5) 3)))
 439
 440
 441 #+nil
 442 (avm2-asm::avm2-disassemble
 443  (avm2-asm::code
 444   (avm2-asm::with-assembler-context
 445     (avm2-asm::assemble-method-body
 446      (with-simple-lambda-context ()
 447        (append
 448         '((:%label foo))
 449         (scompile '(%flet (bleh (a b c) (+ a b c))
 450                     (+ (call-%flet bleh 1 2 3)
 451                      (call-%flet bleh 5 6 7))))
 452         (compile-lambda-context-cleanup 'foo)))))))
 453
 454
 455 #+nil
 456 (avm2-asm::avm2-disassemble
 457  (avm2-asm::code
 458   (avm2-asm::with-assembler-context
 459     (avm2-asm::assemble-method-body
 460 (dump-defun-asm () (let ((s2 "<"))
 461                           (block foo
 462                             (unwind-protect
 463                                  (progn
 464                                    (return-from foo "-ret-")
 465                                    "bleh")
 466                               "baz"))
 467                           (+ s2 ">"))) ) ) ))