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     (or i (break "missing local index in g-l-l-i: ~a" name))))
  62
  63 ;;; %flet needs to remove variable names form scope without removing
  64 ;;;  the index, so we hide the names here...
  65 ;;; possibly would be better to track used indices separately from names
  66 ;;;  but still a bit of work to handle keeping indices used while
  67 ;;;  releasing names
  68 (defun kill-lambda-local-names (names)
  69   (loop for n in (if (listp names) names (list names))
  70      do (setf (car (assoc n (locals *current-lambda*)))
  71               (gensym)))
  72   nil)
  73
  74 (defun get-lambda-block (name)
  75   (cdr (assoc name (blocks *current-lambda*))))
  76
  77 (defun get-lambda-tag (name)
  78   (cdr (assoc name (tags *current-lambda*))))
  79
  80 (defun get-lambda-local-continuation (label)
  81   (cdr (assoc label (continuations *current-lambda*))))
  82
  83 (defun add-lambda-local-continuation (label)
  84   (pushnew (cons label (length (continuations *current-lambda*)))
  85            (continuations *current-lambda*))
  86   (get-lambda-local-continuation label))
  87
  88 (defun get-lambda-cleanups (name)
  89   (loop for (n . block) in (blocks *current-lambda*)
  90      when (cleanup-label block)
  91      collect it
  92      until (eql n name)))
  93
  94 (defmacro with-lambda-context ((&key args blocks tags name (parent *current-lambda*)) &body body)
  95   `(let* ((*current-lambda* (make-lambda-context
  96                              :args ,args
  97                              :blocks ,blocks
  98                              :tags ,tags
  99                              :name ,name
 100                              :parent ,parent)))
 101      ,@body))
 102
 103
 104 (defmacro with-simple-lambda-context ((&rest args) &body body)
 105   `(let* ((*current-lambda* (make-lambda-context
 106                              :args ',args
 107                              :name "<unnamed lambda.>"
 108                              :parent *current-lambda*)))
 109      ,@body))
 110
 111 ;;; not sure if this should be automatic or not, so putting here for now...
 112 (defun compile-lambda-context-cleanup ()
 113   "compile any code that should be after the body of the current
 114   lambda, (local functions, continuation table, etc)"
 115   (let ((bad-cont-label (gensym "BAD-CONTINUATION-")))
 116     (when (continuations *current-lambda*)
 117       `((:%label ,bad-cont-label)
 118         (:push-string "broken")
 119         (:throw)
 120         (:%dlabel ,(continuation-var *current-lambda*))
 121         (:get-local ,(get-lambda-local-index (continuation-var *current-lambda*)))
 122         (:convert-integer)
 123         (:lookup-switch ,bad-cont-label
 124                         ,(mapcar 'car (sort (copy-list (continuations *current-lambda*))
 125                                             #'< :key #'cdr)))
 126         ))))
 127
 128 #+nil(defmacro with-nested-lambda-context (&body body)
 129   ;;; fixme: add a param to specify new bindings, so caller doesn't need to
 130   ;;; know as much about *lambda-context* to add them by hand
 131   `(let ((*current-lambda* (make-nested-lambda-context *current-lambda*)))
 132      ,@body))
 133
 134 (defun last-local-index ()
 135   (length (locals *current-lambda*)))
 136
 137
 138 (defclass lambda-block ()
 139   ((name :initarg :name :accessor name)
 140    (end-label :initarg :end-label :accessor end-label)
 141    (cleanup-label :initarg :cleanup-label :accessor cleanup-label)
 142    (return-var :initarg :return-var :accessor return-var)))
 143
 144 (defun make-lambda-block (name end cleanup var)
 145   (make-instance 'lambda-block :name name
 146                  :end-label end :cleanup-label cleanup
 147                  :return-var var))
 148
 149 ;; fixme: generate these with a macro instead of copy-paste
 150 (defmacro with-local-vars ((bindings) &body body)
 151   (let ((old (gensym "OLD-VARS-")))
 152     `(let ((,old (locals *current-lambda*)))
 153        (setf (locals *current-lambda*)
 154              (append ,bindings (locals *current-lambda*)))
 155        (unwind-protect
 156             (progn
 157               ,@body)
 158          (setf (locals *current-lambda*) ,old)))))
 159
 160 (defmacro with-nested-lambda-block ((block var) &body body)
 161   (let ((old (gensym "OLD-BLOCKS-")))
 162     `(with-local-vars ((list (cons ,var (last-local-index))))
 163       (let ((,old (blocks *current-lambda*)))
 164         (push ,block (blocks *current-lambda*))
 165         (unwind-protect
 166              (progn
 167                ,@body)
 168           (setf (blocks *current-lambda*) ,old))))))
 169
 170
 171 (defmacro with-cleanup ((name cleanup) &body body)
 172   (let* ((var (gensym "WITH-CLEANUP-END-"))
 173          (old (gensym "OLD-BLOCKS-"))
 174          (name-var (gensym "NAME-VAR-"))
 175          (block `(cons ,name-var (make-lambda-block ,name-var ',var
 176                                                 ,cleanup
 177                                                 ',var))))
 178     `(let ((,name-var ,name))
 179        (with-local-vars ((list (cons ',var (last-local-index))))
 180          (let ((,old (blocks *current-lambda*)))
 181            (push ,block (blocks *current-lambda*))
 182            (unwind-protect
 183                 (progn
 184                   ,@body)
 185              (setf (blocks *current-lambda*) ,old)))))))
 186
 187 (defmacro with-nested-lambda-tags ((tags) &body body)
 188   (let ((old (gensym "OLD-TAGS-")))
 189     `(let ((,old (tags *current-lambda*)))
 190        (setf (tags *current-lambda*)
 191              (append ,tags (tags *current-lambda*)))
 192        (unwind-protect
 193             (progn
 194               ,@body)
 195          (setf (tags *current-lambda*) ,old)))))
 196
 197 ;;; top level (internal?) compiler interface
 198 ;;; returns assembly corresponding to FORM
 199 (defgeneric  scompile (form))
 200
 201 (defmethod scompile ((form string))
 202   `((:push-string ,form)
 203     (:coerce-any)))
 204
 205 (defmethod scompile ((form integer))
 206   ;; possibly should have more control than just assuming anything < 2^31
 207   ;; is int (as well as range checking, etc)
 208   (if (> form (expt 2 31))
 209       `((:push-uint ,form)
 210         (:coerce-any))
 211       `((:push-int ,form)
 212         (:coerce-any))))
 213
 214 (defmethod scompile ((form real))
 215   `((:push-double ,form)
 216     (:coerce-any)))
 217
 218 (defmethod scompile ((form symbol))
 219   (let ((i (get-lambda-local-index form)))
 220     (if i
 221         `((:get-local ,i))
 222         (error "unknown local ~s?" form))))
 223
 224 (defmacro define-constants (&body constants)
 225   `(progn
 226      ,@(loop for i in constants
 227           collect `(defmethod scompile ((form (eql ,(car i))))
 228                      '((,(second i))
 229                        (:coerce-any))))))
 230 (define-constants
 231   (:true :push-true)
 232   (t :push-true)
 233   (:false :push-false)
 234   (:nan :push-nan)
 235   (:undefined :push-undefined)
 236   (:null :push-null)
 237   (nil :push-null))
 238
 239 ;;; interface for implementing special forms
 240
 241 (defgeneric scompile-cons (car cdr))
 242
 243 (defmethod scompile ((form cons))
 244   (scompile-cons (car form) (cdr form)))
 245
 246 (defmacro define-special (name (&rest args) &body body)
 247   "define a special operator, destructuring form into ARGS"
 248   (let ((car (gensym "CAR"))
 249         (cdr (gensym "CDR")))
 250     `(defmethod scompile-cons ((,car (eql ',name)) ,cdr)
 251        (destructuring-bind ,args ,cdr
 252          ,@body))))
 253
 254
 255 (defmacro define-special* (name (cdr) &body body)
 256   "define a special operator without any destructuring"
 257   (let ((car (gensym "CAR")))
 258     `(defmethod scompile-cons ((,car (eql ',name)) ,cdr)
 259        ,@body)))
 260
 261 #||
 262 (scompile "foo")
 263 (scompile :true)
 264 (scompile 123.45)
 265 ||#