environment.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2000-2005
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      environment.lisp
   7 ;;;; Description:   Compiler environment.
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Fri Nov  3 11:40:15 2000
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: environment.lisp,v 1.22 2007/03/21 19:57:54 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16 (in-package movitz)
  17
  18 (defun setf-name (name)
  19   "If NAME is on the form (setf <x>), return <x>. Otherwise return NIL."
  20   (and (listp name)
  21        (= 2 (length name))
  22        (eq 'muerte.cl:setf (first name))
  23        (second name)))
  24
  25 ;;;;;;;
  26
  27 (defclass movitz-macro ()
  28   ((expander-function
  29     :initarg expander-function
  30     :reader movitz-macro-expander-function)))
  31
  32 (defclass movitz-special-operator (movitz-macro)
  33   ((expander-function
  34     :initform nil)
  35    (compiler-function
  36     :initarg compiler
  37     :reader movitz-special-operator-compiler-function)))
  38
  39 (defclass movitz-environment ()
  40   ((uplink
  41     :initarg :uplink
  42     :initform nil
  43     :reader movitz-environment-uplink)
  44    (extent-uplink
  45     :initarg :extent-uplink
  46     :accessor movitz-environment-extent-uplink)
  47    (funobj
  48     :initarg :funobj
  49     :reader movitz-environment-funobj)))
  50
  51 (defmethod initialize-instance :after ((instance movitz-environment) &rest x)
  52   (declare (ignore x))
  53   (unless (slot-boundp instance 'extent-uplink)
  54     (setf (movitz-environment-extent-uplink instance)
  55       (movitz-environment-uplink instance))))
  56
  57 (defmethod movitz-environment-compiler-macros ((env movitz-environment)) nil)
  58 (defmethod movitz-environment-function-cells ((env movitz-environment))
  59   (load-time-value (make-hash-table :test #'eq)))
  60 (defmethod movitz-environment-modifies-stack ((env movitz-environment))
  61   "nil: no stack modification.
  62 t: some (unknown amount) stack modified.
  63 integer: that many words pushed on stack."
  64   nil)
  65 (defmethod movitz-environment-bindings ((env movitz-environment))
  66   nil)
  67 (defmethod movitz-environment-plists ((env movitz-environment))
  68   nil)
  69 (defmethod stack-used ((env movitz-environment)) 0)
  70 (defmethod num-specials ((x movitz-environment)) 0)
  71 (defmethod num-dynamic-slots ((x movitz-environment)) 0)
  72
  73 (defclass global-env (movitz-environment)
  74   ((properties
  75     :initform nil
  76     :accessor movitz-environment-properties)
  77    (function-cells
  78     :initarg :function-cells
  79     :initform (make-hash-table :test #'eq :size 11)
  80     :reader movitz-environment-function-cells)
  81    (setf-function-names
  82     :initform (make-hash-table :test #'eq :size 11)
  83     :accessor movitz-environment-setf-function-names)
  84    (plists                              ; this is a plist of plists
  85     :initform nil
  86     :accessor movitz-environment-plists)
  87    (bindings
  88     :initform nil
  89     :accessor movitz-environment-bindings)
  90    (compiler-macros
  91     :initform nil
  92     :accessor movitz-environment-compiler-macros)))
  93
  94 (defclass with-things-on-stack-env (movitz-environment)
  95   ((stack-used
  96     :accessor stack-used
  97     :initarg :stack-used
  98     :initform 0)
  99    (num-specials
 100     :initform 0
 101     :initarg :num-specials
 102     :accessor num-specials)))
 103
 104 (defclass progv-env (with-things-on-stack-env)
 105   ((stack-used
 106     :initform t)
 107    (num-specials
 108     :initform t)))
 109
 110 (defun make-stack-use-env (stack-used)
 111   (make-instance 'with-things-on-stack-env
 112     :stack-used stack-used))
 113
 114 (defclass let-env (with-things-on-stack-env)
 115   ((bindings
 116     :initform nil
 117     :accessor movitz-environment-bindings)
 118    (plists                              ; this is a plist of plists
 119     :initform nil
 120     :accessor movitz-environment-plists)
 121    (num-specials
 122     :initform 0
 123     :initarg :num-specials
 124     :accessor num-specials)
 125    (special-variable-shadows
 126     :initform nil
 127     :accessor special-variable-shadows)))
 128
 129 (defclass with-dynamic-extent-scope-env (let-env)
 130   ((save-esp-binding
 131     :initarg :save-esp-binding
 132     :accessor save-esp-binding)
 133    (base-binding
 134     :initarg :base-binding
 135     :accessor base-binding)
 136    (scope-tag
 137     :initarg :scope-tag
 138     :reader dynamic-extent-scope-tag)
 139    (stack-used
 140     :initform t)
 141    (members
 142     :initform nil
 143     :accessor dynamic-extent-scope-members)))
 144
 145 (defun find-dynamic-extent-scope (env)
 146   (loop for e = env then (movitz-environment-uplink e)
 147       while (and e (not (typep e 'funobj-env)))
 148       do (when (typep e 'with-dynamic-extent-allocation-env)
 149            (return (allocation-env-scope e)))))
 150
 151 (defun dynamic-extent-object-offset (scope-env object)
 152   (loop with offset = 0
 153       for x in (dynamic-extent-scope-members scope-env)
 154       do (if (eq x object)
 155              (return (* 8 offset))
 156            (incf offset (truncate (+ (sizeof x) 4) 8)))))
 157
 158 (defmethod print-object ((env with-dynamic-extent-scope-env) stream)
 159   (print-unreadable-object (env stream :type t)
 160     (princ (dynamic-extent-scope-tag env) stream))
 161   env)
 162
 163 (defclass with-dynamic-extent-allocation-env (movitz-environment)
 164   ((scope
 165     :initarg :scope
 166     :reader allocation-env-scope)))
 167
 168 (defclass funobj-env (let-env)
 169   ()
 170   (:documentation "A funobj-env represents the (possibly null)
 171 lexical environment that a closure funobj captures."))
 172
 173 (defclass function-env (let-env)
 174   ((without-check-stack-limit-p
 175     :accessor without-check-stack-limit-p
 176     :initform nil)
 177    (without-function-prelude-p
 178     :accessor without-function-prelude-p
 179     :initform nil)
 180    (forward-2op
 181     :accessor forward-2op
 182     :initform nil)
 183    (min-args
 184     :initform 0
 185     :accessor min-args)
 186    (max-args
 187     :initform nil
 188     :accessor max-args)
 189    (oddeven-args
 190     :initform nil
 191     :accessor oddeven-args)
 192    (allow-other-keys-p
 193     :accessor allow-other-keys-p)
 194    (rest-args-position
 195     :initform nil
 196     :accessor rest-args-position)
 197    (edx-var
 198     :initform nil
 199     :accessor edx-var)
 200    (required-vars
 201     :initform nil
 202     :accessor required-vars)
 203    (optional-vars
 204     :initform nil
 205     :accessor optional-vars)
 206    (rest-var
 207     :initform nil
 208     :accessor rest-var)
 209    (key-vars-p
 210     :initform nil
 211     :accessor key-vars-p)
 212    (key-vars
 213     :initform nil
 214     :accessor key-vars)
 215    (key-decode-map
 216     :initform nil
 217     :accessor key-decode-map)
 218    (key-decode-shift
 219     :accessor key-decode-shift)
 220    (aux-vars
 221     :initform nil
 222     :accessor aux-vars)
 223    (need-normalized-ecx-p
 224     :initarg :need-normalized-ecx-p
 225     :accessor need-normalized-ecx-p)
 226    (frame-map
 227     :accessor frame-map)
 228    (extended-code
 229     :accessor extended-code)
 230    (potentially-lended-bindings
 231     :initform nil
 232     :accessor potentially-lended-bindings))
 233   (:documentation "A function-env represents the initial env. that
 234 the function sets up itself. Its parent env. must be a funobj-env."))
 235
 236 (defun find-function-env (env funobj)
 237   "Starting from <env>, search for the parent environment that is <funobj>'s top env."
 238   (assert env () "funobj-env not found!")
 239   (or (and (typep env 'function-env)
 240            (eq funobj (movitz-environment-funobj env))
 241            env)
 242       (find-function-env (movitz-environment-uplink env) funobj)))
 243
 244 (defun sub-env-p (sub-env env)
 245   "Check if sub-env is a sub-environment (or eq) of env."
 246   (cond
 247    ((not sub-env)
 248     nil)
 249    ((eq env sub-env)
 250     t)
 251    (t (sub-env-p (movitz-environment-uplink sub-env) env))))
 252
 253 (defmethod num-dynamic-slots ((x with-things-on-stack-env))
 254   (num-specials x))
 255
 256 (defmethod print-object ((object let-env) stream)
 257   (cond
 258    ((not *print-pretty*)
 259     (call-next-method))
 260    (t (print-unreadable-object (object stream :type t :identity t)
 261         (format stream "of ~A binding~?"
 262                 (movitz-funobj-name (movitz-environment-funobj object))
 263                 "~#[ nothing~; ~S~; ~S and ~S~:;~@{~#[~; and~] ~S~^,~}~]"
 264                 (mapcar #'binding-name (mapcar #'cdr (movitz-environment-bindings object)))))
 265       object)))
 266
 267
 268 (defclass operator-env (movitz-environment)
 269   ((bindings
 270     :initform nil
 271     :accessor movitz-environment-bindings)
 272    (plists                              ; this is a plist of plists
 273     :initform nil
 274     :accessor movitz-environment-plists)))
 275
 276 (defclass lexical-exit-point-env (let-env)
 277   ((save-esp-variable
 278     :initarg :save-esp-variable
 279     :reader save-esp-variable)
 280    (exit-label
 281     :initarg :exit-label
 282     :reader exit-label)
 283    (exit-result-mode
 284     :initarg :exit-result-mode
 285     :reader exit-result-mode)
 286    (lexical-catch-tag-variable
 287     :initarg :lexical-catch-tag-variable
 288     :reader movitz-env-lexical-catch-tag-variable)))
 289
 290 (defclass tagbody-env (lexical-exit-point-env) ())
 291
 292 (defclass unwind-protect-env (movitz-environment)
 293   ((cleanup-form
 294     :initarg :cleanup-form
 295     :reader unwind-protect-env-cleanup-form)))
 296
 297 (defmethod num-dynamic-slots ((x unwind-protect-env)) 1)
 298
 299 (defclass simple-dynamic-env (with-things-on-stack-env)
 300   ((stack-used
 301     :initform 4))
 302   (:documentation "An environment that installs one dynamic-env."))
 303
 304 (defmethod num-dynamic-slots ((x simple-dynamic-env)) 1)
 305
 306 (defparameter *movitz-macroexpand-hook*
 307     #'(lambda (macro-function form environment)
 308 ;;;     (warn "Expanding form ~W" form)
 309 ;;;     (warn "..with body ~W" macro-function)
 310         (let ((expansion (funcall macro-function form environment)))
 311           (cond
 312            #+ignore ((member (if (atom form) form (car form))
 313                              '(setf pcnet-reg) :test #'string=)
 314                      (warn "Expanded ~S to ~S" form expansion)
 315                      expansion)
 316            (t
 317             #+ignore (warn "Expanded ~A:~%~S."
 318                            (if (atom form) form (car form))
 319                            expansion)
 320             expansion)))))
 321
 322 (defun movitz-macroexpand-1 (form &optional env)
 323   (let ((movitz-form (translate-program form :cl :muerte.cl)))
 324     (typecase movitz-form
 325       (cons
 326        (let ((expander (movitz-macro-function (car movitz-form) env)))
 327          (if (not expander)
 328              (values movitz-form nil)
 329            (values (translate-program (funcall *movitz-macroexpand-hook* expander movitz-form env)
 330                                       :muerte.cl :cl)
 331                    t))))
 332       (symbol
 333        (let ((binding (movitz-binding movitz-form env)))
 334          (if (not (typep binding 'symbol-macro-binding))
 335              (values movitz-form nil)
 336            (values (translate-program (funcall *movitz-macroexpand-hook*
 337                                                (macro-binding-expander binding)
 338                                                movitz-form env)
 339                                       :muerte.cl :cl)
 340                    t))))
 341       (t (values movitz-form nil)))))
 342
 343 (defun movitz-macroexpand (form &optional env)
 344   (let ((global-expanded-p nil))
 345     (loop while
 346           (multiple-value-bind (expansion expanded-p)
 347               (movitz-macroexpand-1 form env)
 348             (when expanded-p
 349               (setf form expansion)
 350               (setf global-expanded-p expanded-p))))
 351     (values form global-expanded-p)))
 352
 353 (define-symbol-macro *movitz-global-environment*
 354     (image-global-environment *image*))
 355
 356 (defun movitz-env-add-binding (env binding &optional (variable (binding-name binding)))
 357   "Returns the binding."
 358   (check-type binding binding)
 359   (check-type variable symbol "a variable name")
 360   (let ((env (or env *movitz-global-environment*)))
 361     (assert (not (slot-boundp binding 'env)) (binding)
 362       "Binding ~S is already associated with ~S, can't also be associated with ~S."
 363       binding (binding-env binding) env)
 364     (unless (eq env *movitz-global-environment*)
 365       (assert (not (assoc variable (movitz-environment-bindings env))) ()
 366         "Variable ~S is being multiple bound in ~S." variable env))
 367     (pushnew (cons variable binding)
 368              (movitz-environment-bindings env)
 369              :key #'car)
 370     (setf (binding-env binding) env)
 371     binding))
 372
 373 (defun movitz-env-load-declarations (declarations environment context)
 374   (loop for (declaration-identifier . data) in declarations
 375       do (case declaration-identifier
 376            ((muerte.cl::ftype muerte.cl::optimize)
 377             nil)                        ; ignore for now
 378            (muerte.cl::ignore
 379             (dolist (var data)
 380               (check-type var symbol)
 381               (setf (movitz-env-get var 'ignore nil environment) t)))
 382            (muerte.cl::ignorable
 383             (dolist (var data)
 384               (check-type var symbol)
 385               (setf (movitz-env-get var 'ignorable nil environment) t)))
 386            (muerte::constant-variable
 387             (dolist (var data)
 388               (check-type var symbol)
 389               (when (eq :declaim context)
 390                 (pushnew :constant-variable (movitz-symbol-flags (movitz-read var))))
 391               (setf (movitz-env-get var 'constantp nil environment) t)))
 392            (muerte.cl:special
 393             (dolist (var data)
 394               (check-type var symbol)
 395               (when (eq :declaim context)
 396                 (pushnew :special-variable (movitz-symbol-flags (movitz-read var))))
 397               (setf (movitz-env-get var 'special nil environment) t)))
 398            (muerte.cl:dynamic-extent
 399             (dolist (var data)
 400               (setf (movitz-env-get var 'dynamic-extent nil environment) t)))
 401            (muerte.cl:notinline
 402             (dolist (var data)
 403               (setf (movitz-env-get var 'notinline nil environment) t)))
 404            (muerte.cl:type
 405             (destructuring-bind (typespec . vars)
 406                 data
 407               (dolist (var vars)
 408                 (setf (movitz-env-get var :variable-type nil environment) typespec))))
 409            (muerte::primitive-function
 410             (unless (eq :funobj context)
 411               (warn "Declaration ~S appeared in context ~S but is only allowed in funobj context."
 412                     declaration-identifier context))
 413             (setf (getf (movitz-environment-properties environment) 'primitive-function) t))
 414            (muerte::without-function-prelude
 415             (unless (eq :funobj context)
 416               (warn "Declaration ~S appeared in context ~S but is only allowed in funobj context."
 417                     declaration-identifier context))
 418             (setf (without-function-prelude-p environment) t))
 419            (muerte::without-check-stack-limit
 420             (unless (eq :funobj context)
 421               (warn "Declaration ~S appeared in context ~S but is only allowed in funobj context."
 422                     declaration-identifier context))
 423             (setf (without-check-stack-limit-p environment) t))
 424            (muerte::forward-2op
 425             (unless (eq :funobj context)
 426               (warn "Declaration ~S appeared in context ~S but is only allowed in funobj context."
 427                     declaration-identifier context))
 428             (let ((symbol (car data)))
 429               (check-type symbol symbol "a function name")
 430               (setf (forward-2op environment) (movitz-read symbol))))
 431            ((muerte::loop-tag)
 432             (dolist (var data)
 433               (setf (movitz-env-get var declaration-identifier nil environment) t)))
 434            (t (let ((typespec declaration-identifier)
 435                     (vars data))
 436                 (dolist (var vars)
 437                   (setf (movitz-env-get var :variable-type nil environment) typespec))))))
 438   environment)
 439
 440 (defun make-local-movitz-environment (uplink funobj
 441                                    &rest init-args
 442                                    &key (type 'global-env)
 443                                         declarations declaration-context bindings
 444                                    &allow-other-keys)
 445   (dolist (p '(:type :declarations :declaration-context :bindings))
 446     (remf init-args p))
 447   (let ((env (apply #'make-instance type
 448                     :uplink (or uplink *movitz-global-environment*)
 449                     :funobj funobj
 450                     init-args)))
 451     (movitz-env-load-declarations declarations env declaration-context)
 452     (loop for (nil . val) in bindings
 453         do (movitz-env-add-binding env val))
 454     env))
 455
 456 (defun make-global-movitz-environment ()
 457   (let ((env (make-instance 'global-env :uplink nil)))
 458     (setf (movitz-env-get 'nil 'constantp nil env) t
 459           (movitz-env-get 'muerte.cl:t 'constantp nil env) t
 460           (symbol-value 'muerte.cl:t) 'muerte.cl:t)
 461     env))
 462
 463 ;;; Bindings
 464
 465 (defun movitz-binding (symbol environment &optional (recurse t))
 466   (check-type symbol symbol)
 467   (if (not environment)
 468       nil
 469     (let ((local-binding (cdr (assoc symbol (movitz-environment-bindings environment)))))
 470       (if (typep local-binding '(and binding (not operator-binding)))
 471           (values local-binding environment)
 472         (and recurse (movitz-binding symbol (movitz-environment-uplink environment)))))))
 473
 474 (defun movitz-operator-binding (symbol environment &optional (recurse t))
 475   (labels ((operator-binding-p (b)
 476              (or (typep b 'operator-binding)
 477                  (and (typep b 'borrowed-binding)
 478                       (operator-binding-p (borrowed-binding-target b))))))
 479     (if (not environment)
 480         nil
 481       (let ((local-binding (cdr (assoc symbol (movitz-environment-bindings environment)))))
 482         (if (operator-binding-p local-binding)
 483             (values local-binding environment)
 484           (and recurse (movitz-operator-binding symbol (movitz-environment-uplink environment))))))))
 485
 486 ;;; Accessor: movitz-env-get (symbol property)
 487
 488 (defun movitz-env-get (symbol indicator &optional (default nil)
 489                                                (environment nil)
 490                                                (recurse-p t))
 491   (loop for env = (or environment *movitz-global-environment*)
 492       then (when recurse-p (movitz-environment-uplink env))
 493       for plist = (and env (getf (movitz-environment-plists env) symbol))
 494       while env
 495       do (let ((val (getf plist indicator '#0=#:not-found)))
 496            (unless (eq val '#0#)
 497              (return (values val env))))
 498       finally (return default)))
 499
 500 (defun (setf movitz-env-get) (val symbol indicator
 501                            &optional default environment)
 502   (declare (ignore default))
 503   (setf (getf (getf (movitz-environment-plists (or environment
 504                                                 *movitz-global-environment*))
 505                     symbol)
 506               indicator)
 507     val))
 508
 509 ;;; Accessor: movitz-env-symbol-function
 510
 511 (defun movitz-env-symbol-function (symbol &optional env)
 512   (values (gethash symbol (movitz-environment-function-cells (or env *movitz-global-environment*)))))
 513
 514 (defun (setf movitz-env-symbol-function) (value symbol &optional env)
 515   (setf (gethash symbol (movitz-environment-function-cells (or env *movitz-global-environment*)))
 516     value))
 517
 518 (defun movitz-env-setf-operator-name (name &optional env)
 519   "Map an setf operator name like from (setf operator) to a symbol."
 520   (assert (null env))
 521   (or #0=(gethash name (movitz-environment-setf-function-names *movitz-global-environment*))
 522       (let ((setf-symbol (make-symbol
 523                           (symbol-name name))))
 524         (setf (symbol-plist setf-symbol) (list :setf-placeholder name)
 525               #0# setf-symbol))))
 526
 527 (defun movitz-env-named-function (name &optional env)
 528   (cond
 529     ((setf-name name)
 530      (movitz-env-symbol-function (movitz-env-setf-operator-name
 531                                   (setf-name name) env)))
 532     ((symbolp name)
 533      (movitz-env-symbol-function name env))
 534     (t (error "Not a function name: ~S" name))))
 535
 536 (defun (setf movitz-env-named-function) (value name &optional env)
 537   (check-type value movitz-funobj)
 538   (let ((effective-env (or env *movitz-global-environment*)))
 539     (cond
 540      ((setf-name name)
 541       (let* ((sn (setf-name name))
 542              (function-name (movitz-env-setf-operator-name sn env)))
 543         (setf (movitz-env-named-function function-name env) value)))
 544      ((symbolp name)
 545       (setf (gethash name (movitz-environment-function-cells effective-env))
 546         value))
 547      (t (error "Not a function name: ~S" name)))))
 548
 549 (defun movitz-macro-function (symbol &optional environment)
 550   (or (let ((binding (movitz-operator-binding symbol (or environment *movitz-global-environment*))))
 551         (and (typep binding 'macro-binding)
 552              (macro-binding-expander binding)))
 553       (loop for env = (or environment *movitz-global-environment*)
 554           then (movitz-environment-uplink env)
 555           for val = (and env (gethash symbol (movitz-environment-function-cells env)))
 556           while env
 557           when val
 558           do (return (and (typep val 'movitz-macro)
 559                           (movitz-macro-expander-function val))))))
 560
 561 (defun (setf movitz-macro-function) (fun symbol &optional environment)
 562   (let ((obj (or (gethash symbol (movitz-environment-function-cells (or environment
 563                                                                      *movitz-global-environment*)))
 564                  (make-instance 'movitz-macro))))
 565     (setf (slot-value obj 'expander-function) fun)
 566     (setf (gethash symbol (movitz-environment-function-cells (or environment
 567                                                               *movitz-global-environment*)))
 568       obj))
 569   fun)
 570
 571 ;;; Accessor: COMPILER-MACRO-FUNCTION
 572
 573 (defun movitz-compiler-macro-function (name &optional environment)
 574   (loop for env = (or environment *movitz-global-environment*)
 575       then (movitz-environment-uplink env)
 576       for val = (and env (getf (movitz-environment-compiler-macros env) name))
 577       while env
 578       when val do (return val)))
 579
 580 (defun (setf movitz-compiler-macro-function) (fun name &optional environment)
 581   (setf (getf (movitz-environment-compiler-macros (or environment
 582                                                    *movitz-global-environment*))
 583               name)
 584     fun))
 585
 586 ;;; Special operators
 587
 588 (defparameter *persistent-movitz-environment* (make-global-movitz-environment))
 589
 590 (defun movitz-special-operator-p (symbol)
 591   (let ((val (gethash symbol (movitz-environment-function-cells *persistent-movitz-environment*))))
 592     (typep val 'movitz-special-operator)))
 593
 594 (defun movitz-special-operator-compiler (symbol)
 595   (movitz-special-operator-compiler-function
 596    (gethash symbol (movitz-environment-function-cells *persistent-movitz-environment*))))