Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/pcl/src-16f.lha/compiler/bcgen.lisp

Text File | 1991-11-06 | 5.4 KB | 183 lines

;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or [e-mail].
;;;
(ext:file-comment
  "$Header: bcgen.lisp,v 1.2 91/02/20 14:56:40 ram Exp $")
;;;
;;; **********************************************************************
;;;
;;;    A back end for the compiler that generates an interpreted byte code
;;; instead of native code.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)

;;;; Data structures:

;;; The Continuation-Info is a representation of the number of values which
;;; should be pushed when something is evaluated with that continuation:
;;; -- A positive integer specifies a fixed number of values
;;; -- NIL specifies no values
;;; -- :Multiple specifies an arbitrary number of values, with a values count
;;;    on top.
;;;
;;; ### Also need an MV-call variant that increments the values count already
;;; on TOS (???)  I guess we could have a coalesce-values Xop that takes the
;;; top N values globs, squeezes out the values counts and pushes the total
;;; count.

;;; The Leaf-Loc has various interpretations depending on the kind of leaf:
;;; -- In a lambda-var, it is something or other that specifies the argument or
;;;    local that the value is found in for non-closure variables in their home
;;;    environment.
;;; -- In a functional, it is the closure that represents that functional. (???)

;;; The Environment-Info is the number of local variables allocated in the
;;; environment.

;;; The BC-Block structure is used to annotate blocks with information that we
;;; need to generate byte code.  This structure is stored in the Block-Info.
;;;
(defstruct bc-block
  ;;
  ;; The label for the start of this block.
  label
  ;;
  ;; Lists of continuations representing the values on the stack at the
  ;; beginning and end of this block.  The first continuation is on top, second
  ;; underneath, etc.
  (start-conts () :type list)
  (end-conts () :type list))


;;; Generate-Byte-Code  --  Interface
;;;
;;;    Generate byte code to implement the functions in Component.
;;;
(proclaim '(function generate-byte-code (component) void))
(defun generate-byte-code (component)
  (allocate-variables component)
  (stack-analyze component))


;;; Default-Values  --  Internal
;;;
;;;    Push any extra values expected by Cont, given that Count values have
;;; already been pushed.
;;;
(proclaim '(function default-values (continuation (integer 1)) void))
(defun default-values (cont count)

  (when (eq for-value :multiple)
    (inst push-ic-0 1))
  )


;;; Call-Sys-Function  --  Internal
;;;
;;;    Call a system constant function.



(defun byte-code-generate-block (block)
  (let ((last (block-last block)))
    (do ((node (continuation-next (block-start block))
           (continuation-next (node-cont node))))
    (())
      (etypecase node
    (ref
     (when for-value
       (let* ((leaf (ref-leaf ref))
          (name (leaf-name leaf)))
         (etypecase leaf
           (constant
        (let ((value (constant-value leaf)))
          (cond ((or (not name) (numberp value) (characterp value)
                 (and (symbolp value) (symbol-package value)))
             (push-constant value))
            (t
             (push-constant name)
             (call-sys-function 'symbol-value)))))
           (global-var
        (push-constant name)
        (ecase (global-var-kind leaf)
          (:global-function
           (call-sys-function 'symbol-function))
          ((:constant :special :global)
           (call-sys-function 'symbol-value))))
           (lambda-var
        (let ((closure (lambda-var-closure leaf)))
          (cond (closure
             (push-closure closure current-env)
             (push-closure-slot leaf closure))
            ((eq (lambda-environment (lambda-var-home leaf))
                 current-env)
             (push-al (leaf-loc leaf)))
            (t
             (push-closure-slot leaf (environment-closure current-env))))))
           (functional
        (push-closure (leaf-loc leaf) current-env))))

       (default-values cont 1)))
    (if
     (let* ((next-block (block-next block))
        (consequent (continuation-block (if-consequent node)))
        (c-label (bc-block-label (block-info consequent)))
        (alternative (continuation-block (if-alternative node)))
        (a-label (bc-block-label (block-info alternative))))
       (cond ((eq consequent next-block)
          (inst branch-false a-label))
         ((eq alternative next-block)
          (inst branch-true c-label))
         (t
          (inst branch-true c-label)
          (inst branch a-label)))))
    (set
     ;;
     ;; Similar to Ref:
     ;;    Local lexical
     ;;    Special
     ;;    Closure
     )
    (combination
     ;;
     ;; Cases:
     ;;    Funny function:
     ;;        Catch, UWP, Specbind.  Use Xop.
     ;;    If a Let, just pop the args into the appropriate locals and jump.
     ;;    System constant function.
     ;;    Other...
     )
    (mv-combination
     ;;
     ;; Cases:
     ;;    Funny function: Throw.
     ;;    Local call:
     ;;        MV-Bind
     ;;    Full call
     )
    (bind
     ;;
     ;; Allocate closure stuff that is allocated at this node.  Allocate
     ;; locals.  Move any set arguments into the local we keep them in.
     )
    (return
     (inst return)))

      (when (eq node last) (return)))))

#| Need to inhibit generation of:
Controlled by setting of Continuation-Info (a.k.a. for-value).

Arguments to funny functions

Functions for calls where we don't want the value to be pushed because it is a
local call or a call to a system constant function.
|#