compile/compiler.lisp

   1 (in-package :avm2-compiler)
   2
   3 ;;;
   4 (defclass compiler-context ()
   5   ((class-names :initform () :accessor class-names)
   6    (function-names :initform () :accessor function-names)))
   7
   8 (defparameter *compiler-context* (make-instance 'compiler-context))
   9
  10 ;;; track data about a function level scope
  11 ;;;   (including lambda/flet/labels/defun)
  12 ;;; nested scopes should use with-nested-foo macros to temporarily expand
  13 ;;;  the namespaces
  14 (defclass lambda-context ()
  15   ;; using an alist for local name-index mapping, so we can push/pop
  16   ;; state a bit more easily than with hash tables...
  17   ((locals :initform () :initarg locals :accessor locals)
  18    (tags :initform () :initarg tags :accessor tags)
  19    (blocks :initform () :initarg blocks :accessor blocks)
  20    ;; for local functions, and stuff like unwind protect that needs to
  21    ;; call a block of code from multiple places, we store a list of
  22    ;; those places, and implement the local return as setting a
  23    ;; specific register (allocated on first use) and a jump to a
  24    ;; :lookup-switch with all the possible continuations
  25    ;; ---- possibly this should be at assembler level? or defun or something?
  26    (continuations :initform () :initarg continuations :accessor continuations)
  27    (continuation-var :initform (gensym "CONTINUATION-VAR-") :accessor continuation-var)
  28    (local-return-var :initform (gensym "LOCAL-RETURN-VAR-") :accessor local-return-var)
  29    (%flets :initform nil :accessor %flets)
  30    (parent :initform nil :initarg parent :accessor parent)
  31    (name :initform nil :initarg name :accessor name)))
  32
  33 (defparameter *current-lambda* nil)
  34
  35 (defun make-lambda-context (&key args blocks tags (parent *current-lambda*)
  36                             name)
  37   (let* ((locals (cons (cons 'this 0)
  38                        (loop for i in args
  39                           for j from 1
  40                           collect (cons i j))))
  41          (lc (make-instance 'lambda-context
  42                             'locals locals
  43                             'blocks (copy-list blocks)
  44                             'tags (copy-list tags)
  45                             'parent parent
  46                             'name (or name "<unnamed lambda>"))))
  47     ;; bind a variable for storing local return continuation label stuff,
  48     ;; would be nicer to avoid allocating a local index unless needed,
  49     ;; but that would require tracking # of used indices separately from
  50     ;; length of locals list, so skipping for now
  51     (push (cons (continuation-var lc) (length (locals lc)))
  52           (locals lc))
  53     ;; flash is picky about stack being balanced around jumps, so
  54     ;; return in register too
  55     (push (cons (local-return-var lc) (length (locals lc)))
  56           (locals lc))
  57     lc))
  58
  59 (defun get-lambda-local-index (name)
  60   (let ((i (cdr (assoc name (locals *current-lambda*)))))
  61     #+nil(or i (break "missing local index in g-l-l-i: ~a" name))
  62     i))
  63
  64 ;;; %flet needs to remove variable names form scope without removing
  65 ;;;  the index, so we hide the names here...
  66 ;;; possibly would be better to track used indices separately from names
  67 ;;;  but still a bit of work to handle keeping indices used while
  68 ;;;  releasing names
  69 (defun kill-lambda-local-names (names)
  70   (loop for n in (if (listp names) names (list names))
  71      do (setf (car (assoc n (locals *current-lambda*)))
  72               (gensym)))
  73   nil)
  74
  75 (defun get-lambda-block (name)
  76   (cdr (assoc name (blocks *current-lambda*))))
  77
  78 (defun get-lambda-tag (name)
  79   (cdr (assoc name (tags *current-lambda*))))
  80
  81 (defun get-lambda-local-continuation (label)
  82   (cdr (assoc label (continuations *current-lambda*))))
  83
  84 (defun add-lambda-local-continuation (label)
  85   (pushnew (cons label (length (continuations *current-lambda*)))
  86            (continuations *current-lambda*))
  87   (get-lambda-local-continuation label))
  88
  89 (defun get-lambda-cleanups (name)
  90   (loop for (n . block) in (blocks *current-lambda*)
  91      when (cleanup-label block)
  92      collect it
  93      until (eql n name)))
  94
  95 (defmacro with-lambda-context ((&key args blocks tags name (parent *current-lambda*)) &body body)
  96   `(let* ((*current-lambda* (make-lambda-context
  97                              :args ,args
  98                              :blocks ,blocks
  99                              :tags ,tags
 100                              :name ,name
 101                              :parent ,parent)))
 102      ,@body))
 103
 104
 105 (defmacro with-simple-lambda-context ((&rest args) &body body)
 106   `(let* ((*current-lambda* (make-lambda-context
 107                              :args ',args
 108                              :name "<unnamed lambda.>"
 109                              :parent *current-lambda*)))
 110      ,@body))
 111
 112 ;;; not sure if this should be automatic or not, so putting here for now...
 113 (defun compile-lambda-context-cleanup ()
 114   "compile any code that should be after the body of the current
 115   lambda, (local functions, continuation table, etc)"
 116   (let ((bad-cont-label (gensym "BAD-CONTINUATION-")))
 117     (when (continuations *current-lambda*)
 118       `((:%label ,bad-cont-label)
 119         (:push-string "broken")
 120         (:throw)
 121         (:%dlabel ,(continuation-var *current-lambda*))
 122         (:get-local ,(get-lambda-local-index (continuation-var *current-lambda*)))
 123         (:convert-integer)
 124         (:lookup-switch ,bad-cont-label
 125                         ,(mapcar 'car (sort (copy-list (continuations *current-lambda*))
 126                                             #'< :key #'cdr)))
 127         ))))
 128
 129 #+nil(defmacro with-nested-lambda-context (&body body)
 130   ;;; fixme: add a param to specify new bindings, so caller doesn't need to
 131   ;;; know as much about *lambda-context* to add them by hand
 132   `(let ((*current-lambda* (make-nested-lambda-context *current-lambda*)))
 133      ,@body))
 134
 135 (defun last-local-index ()
 136   (length (locals *current-lambda*)))
 137
 138
 139 (defclass lambda-block ()
 140   ((name :initarg :name :accessor name)
 141    (end-label :initarg :end-label :accessor end-label)
 142    (cleanup-label :initarg :cleanup-label :accessor cleanup-label)
 143    (return-var :initarg :return-var :accessor return-var)))
 144
 145 (defun make-lambda-block (name end cleanup var)
 146   (make-instance 'lambda-block :name name
 147                  :end-label end :cleanup-label cleanup
 148                  :return-var var))
 149
 150 ;; fixme: generate these with a macro instead of copy-paste
 151 (defmacro with-local-vars ((bindings) &body body)
 152   (let ((old (gensym "OLD-VARS-")))
 153     `(let ((,old (locals *current-lambda*)))
 154        (setf (locals *current-lambda*)
 155              (append ,bindings (locals *current-lambda*)))
 156        (unwind-protect
 157             (progn
 158               ,@body)
 159          (setf (locals *current-lambda*) ,old)))))
 160
 161 (defmacro with-nested-lambda-block ((block var) &body body)
 162   (let ((old (gensym "OLD-BLOCKS-")))
 163     `(with-local-vars ((list (cons ,var (last-local-index))))
 164       (let ((,old (blocks *current-lambda*)))
 165         (push ,block (blocks *current-lambda*))
 166         (unwind-protect
 167              (progn
 168                ,@body)
 169           (setf (blocks *current-lambda*) ,old))))))
 170
 171
 172 (defmacro with-cleanup ((name cleanup) &body body)
 173   (let* ((var (gensym "WITH-CLEANUP-END-"))
 174          (old (gensym "OLD-BLOCKS-"))
 175          (name-var (gensym "NAME-VAR-"))
 176          (block `(cons ,name-var (make-lambda-block ,name-var ',var
 177                                                 ,cleanup
 178                                                 ',var))))
 179     `(let ((,name-var ,name))
 180        (with-local-vars ((list (cons ',var (last-local-index))))
 181          (let ((,old (blocks *current-lambda*)))
 182            (push ,block (blocks *current-lambda*))
 183            (unwind-protect
 184                 (progn
 185                   ,@body)
 186              (setf (blocks *current-lambda*) ,old)))))))
 187
 188 (defmacro with-nested-lambda-tags ((tags) &body body)
 189   (let ((old (gensym "OLD-TAGS-")))
 190     `(let ((,old (tags *current-lambda*)))
 191        (setf (tags *current-lambda*)
 192              (append ,tags (tags *current-lambda*)))
 193        (unwind-protect
 194             (progn
 195               ,@body)
 196          (setf (tags *current-lambda*) ,old)))))
 197
 198 ;;; top level (internal?) compiler interface
 199 ;;; returns assembly corresponding to FORM
 200 (defgeneric  scompile (form))
 201
 202 (defmethod scompile ((form string))
 203   `((:push-string ,form)
 204     (:coerce-any)))
 205
 206 (defmethod scompile ((form integer))
 207   ;; possibly should have more control than just assuming anything < 2^31
 208   ;; is int (as well as range checking, etc)
 209   (if (> form (expt 2 31))
 210       `((:push-uint ,form)
 211         (:coerce-any))
 212       `((:push-int ,form)
 213         (:coerce-any))))
 214
 215 (defmethod scompile ((form real))
 216   `((:push-double ,form)
 217     (:coerce-any)))
 218
 219
 220 (defmethod scompile ((form simple-vector))
 221   `(,@(loop for i across form
 222          append (scompile i))
 223       (:new-array ,(length form))))
 224
 225
 226 (defmethod %quote (object)
 227   ;; assuming anything without a special handler is self-evaluating for now
 228   (scompile object))
 229
 230 (defmethod %quote ((object cons))
 231   (scompile `(list ,@(loop for i in object
 232                         collect `(quote ,i)))))
 233
 234 (defmethod scompile ((form symbol))
 235   (let* ((i (get-lambda-local-index form))
 236         (constant (unless i (find-swf-constant form))))
 237     (cond
 238       (i `((:get-local ,i)))
 239       (constant `((:get-lex ,(first constant))
 240                   (:get-property ,(second constant))))
 241       ((keywordp form)
 242        (%quote form))
 243       (t (error "unknown local ~s?" form)))))
 244
 245 (defmacro define-constants (&body constants)
 246   `(progn
 247      ,@(loop for i in constants
 248           collect `(defmethod scompile ((form (eql ,(car i))))
 249                      '((,(second i))
 250                        (:coerce-any))))))
 251 (define-constants
 252   (:true :push-true)
 253   (t :push-true)
 254   (:false :push-false)
 255   (:nan :push-nan)
 256   (:undefined :push-undefined)
 257   (:null :push-null)
 258   (nil :push-null))
 259
 260 ;;; interface for implementing special forms
 261
 262 (defgeneric scompile-cons (car cdr))
 263
 264 (defmethod scompile ((form cons))
 265   (let* ((cmacro (find-swf-cmacro-function (car form)))
 266          (macro (find-swf-macro-function (car form)))
 267          (new-form (if cmacro (funcall cmacro form nil) form)))
 268     (if (eq form new-form)
 269         (if macro
 270             (scompile  (funcall macro form nil))
 271             (scompile-cons (car form) (cdr form)))
 272         (scompile new-form))))
 273
 274 (defmacro define-special (name (&rest args) &body body)
 275   "define a special operator, destructuring form into ARGS"
 276   (let ((car (gensym "CAR"))
 277         (cdr (gensym "CDR")))
 278     `(defmethod scompile-cons ((,car (eql ',name)) ,cdr)
 279        (destructuring-bind ,args ,cdr
 280          ,@body))))
 281
 282
 283 (defmacro define-special* (name (cdr) &body body)
 284   "define a special operator without any destructuring"
 285   (let ((car (gensym "CAR")))
 286     `(defmethod scompile-cons ((,car (eql ',name)) ,cdr)
 287        ,@body)))
 288
 289 #||
 290 (scompile "foo")
 291 (scompile :true)
 292 (scompile 123.45)
 293 ||#