home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / module.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  16.4 KB  |  419 lines
  1. (herald (front_end module)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;;                    PROCESSING MODULES
  28. ;;;==========================================================================
  29.  
  30. ;;; Temporary debugging flag
  31. (lset *front-debug* nil)
  32.  
  33. ;;; The expression being compiled
  34. (lset *current-module-exp* nil)
  35.  
  36. ;;; The top level procedure.  EXPS is a list of expressions to be compiled
  37. ;;; using SYNTAX and EARLY-BINDING-ENV.  SHAPEs keep track of variable scoping.
  38. ;;; USES hold information about forward references to global variables so that
  39. ;;; they can checked against the definitions when the definitions are
  40. ;;; processed. 
  41.  
  42. (define (file-exps->nodes+shape exps syntax)
  43.   (let ((shape (create-shape *new-env*)))
  44.     (bind ((*variable-id* '0)
  45.            (*shape* shape)
  46.            (*syntax* (make-syntax-table syntax '*syntax*))
  47.            (*current-module-exp* nil)
  48.            (*value-table* (make-table '*value-table*))  ; simplify-call
  49.            (*definitions* nil)                          ; analyze
  50.            (*uses*        nil)                          ; analyze
  51.            (*child-vars* '())                           ; nodestuff
  52.            (*vector->lexical-var*                       ; nodestuff
  53.             (make-infinite-vector 0 false '*vector->lexical-var*)))
  54.       (if *cross-compiling?*
  55.           (install-system-constants *running-system-constants*))
  56.       (let ((exps (make-module-exps (expand-forms exps syntax) shape)))
  57.         (receive (uses plain integrated)
  58.                  (do-integrable-exps exps shape)
  59.           (exps->nodes plain uses shape)
  60.           (let ((nodes (finish-exps (append integrated plain))))
  61.             (remove-child-vars)
  62.             (new-print-variable-info (shape-new-env shape)
  63.                                      (shape-free shape)
  64.                                      (shape-borrowed shape)
  65.                                      *early-binding-env*)
  66.             (if *cross-compiling?*
  67.                 (install-system-constants *target-system-constants*))
  68.             (return nodes shape)))))))
  69.  
  70. ;;; A structure to hold all of the information about an expression.
  71.  
  72. (define-structure-type module-exp
  73.   source       ; source expression
  74.   form         ; expression
  75.   node         ; node
  76.   syntax       ; associated syntax table
  77.   index        ; index of this expression in the module
  78.   def          ; name or variable defined at top level
  79.   variant      ; type of definition
  80.   uses         ; global variables used
  81.   )
  82.  
  83. (define (create-module-exp form syntax index source)
  84.   (let ((new (make-module-exp)))
  85.     (receive (def variant)
  86.              (form-definition form)
  87.       (set (module-exp-source  new) source)
  88.       (set (module-exp-form    new) form)
  89.       (set (module-exp-node    new) nil)
  90.       (set (module-exp-syntax  new) syntax)
  91.       (set (module-exp-def     new) def)
  92.       (set (module-exp-variant new) variant)
  93.       (set (module-exp-uses    new) nil)
  94.       (set (module-exp-index   new) index)
  95.       new)))
  96.              
  97. ;;; If a form is a simple definition, return the variable being defined and
  98. ;;; the type of definition.  This also replaces the syntax with the 
  99. ;;; corresponding primop.  This prevents the alphatizer from seeing the
  100. ;;; definition.
  101.  
  102. (define (form-definition form)
  103.   (cond ((not (and (pair? form)
  104.                    (proper-list? form)
  105.                    (fx= 3 (length form))
  106.                    (symbol? (cadr form))))
  107.          (return nil nil))
  108.         ((eq? (car form) syntax/define-variable-value)
  109.          (set (car form) primop/*define)
  110.          (return (cadr form) 'define))
  111.         ((eq? (car form) syntax/lset-variable-value)
  112.          (set (car form) primop/*lset)
  113.          (return (cadr form) 'lset))
  114.         (else
  115.          (return nil nil))))
  116.  
  117. ;;; Turn a list of forms into a list of MODULE-EXP records.
  118.  
  119. (define (make-module-exps forms shape)
  120.   (iterate loop ((forms forms) (i 0) (exps '()))
  121.     (cond ((null? forms)
  122.            (process-global-declarations (reverse! exps) shape))
  123.           (else
  124.            (destructure ((((form syntax source) . forms) forms))
  125.              (let ((exp (create-module-exp form syntax i source)))
  126.                (add-def-to-shape exp shape)
  127.                (loop forms (fx+ i 1) (cons exp exps))))))))
  128.                      
  129. (define (process-global-declarations exps shape)
  130.   (filter! (lambda (exp)
  131.              (cond ((and (pair? (module-exp-form exp))
  132.                          (eq? syntax/declare (car (module-exp-form exp))))
  133.                     (process-global-declaration (module-exp-form exp) shape)
  134.                     nil)
  135.                    (else t)))
  136.            exps))
  137.  
  138. ;;;             MAKING THE NEW DEFINITION ENVIRONMENT
  139. ;;;===========================================================================
  140.  
  141. ;;; Put the definition from EXP into the new definition environment of SHAPE.
  142.  
  143. (define (add-def-to-shape exp shape)
  144.   (cond  ((module-exp-def exp)
  145.           (add-global-definition shape
  146.                                  (module-exp-def exp)
  147.                                  (module-exp-variant exp))
  148.           (let ((var (table-entry (shape-new-env shape)
  149.                                   (module-exp-def exp))))
  150.             (if var (set (module-exp-def exp) var))))))
  151.   
  152.  
  153. ;;;                    EXPRESSIONS->NODES
  154. ;;;===========================================================================
  155.  
  156. ;;; Transform EXPS into transmogrified nodes.
  157.  
  158. (define (exps->nodes exps uses shape)
  159.   (iterate loop ((exps exps) (uses uses))
  160.    (cond ((null? exps)
  161.           (return))
  162.          ((module-exp-node (car exps))
  163.           (loop (cdr exps) uses))
  164.          (else
  165.           (set *current-module-exp* (car exps))
  166.           (let* ((node (exp->node (car exps) shape))
  167.                  (uses (transmogrify-node node uses)))
  168.             (loop (cdr exps) uses))))))
  169.  
  170. (define (exp->node exp shape)
  171.   (if *front-debug*
  172.       (pretty-print exp (terminal-output)))
  173.   (let ((node (->value-node `(,syntax/lambda () ,(module-exp-form exp))
  174.                             (module-exp-syntax exp)
  175.                             shape)))
  176.     (set (module-exp-node exp) node)
  177.     (if *front-debug*
  178.         (pp-cps node (terminal-output)))
  179.     node))
  180.  
  181. ;;; Simplify NODE and check the types of its references to global variables.
  182.  
  183. (define (transmogrify-node node uses)
  184.   (simplify-call node)
  185.   (orbit-debug '"~&Simplified tree: ~%")
  186.   (if *debug-flag*
  187.       (pp-cps node (terminal-output)))
  188.   (receive (defs new-uses)
  189.            (def-and-use-analyze node)
  190.     (let ((forward-uses (check-uses new-uses uses)))
  191.       (walk (lambda (var)
  192.               (format *noise+terminal* '"~&~S~%" (variable-name var)))
  193.             defs)
  194.       forward-uses)))
  195.  
  196. ;;; The final pass over the expressions before they are turned over to the
  197. ;;; code generator.  This puts the expressions back into their original order.
  198.  
  199. (define (finish-exps exps)
  200.   (map! (lambda (exp)
  201.           (set *current-module-exp* exp)
  202.           (if (and (variable? (module-exp-def exp))
  203.                    (memq? 'type-safe-closed-form 
  204.                           (definition-data
  205.                            (variable-definition (module-exp-def exp)))))
  206.               (make-type-safe (module-exp-node exp)))
  207.           (fixup-node-tree (module-exp-node exp)))
  208.         (sort-list exps
  209.                    (lambda (x y)
  210.                      (fx< (module-exp-index x)
  211.                           (module-exp-index y))))))
  212.  
  213. ;;; This is used for converting subexpressions, usually the closed-compiled
  214. ;;; versions of primops, into nodes.
  215.  
  216. (define (subexpression->code-tree exp)
  217.   (if *front-debug*
  218.       (pretty-print exp (terminal-output)))
  219.   (let* ((node (->value-node `(,syntax/lambda () ,exp)
  220.                              *syntax*
  221.                              *shape*)))
  222.       (if *front-debug*
  223.           (pp-cps node (terminal-output)))
  224.       node))
  225.  
  226.  
  227. ;;;               PROCESSING INTEGRABLE DEFINITIONS
  228. ;;;===========================================================================
  229.  
  230. ;;; Finds the expressions that contain integrable definitions and 
  231. ;;; transmogrifies them into node trees.  The nodes are sorted so that each is
  232. ;;; simplified before its definition is needed in simplifying any of the
  233. ;;; others.  ODD-INTS are expressions that contain integrable definitions in
  234. ;;; such a way that the compiler cannot determine what value the defined
  235. ;;; variable has.
  236. ;;; Afterwards the expressions are put back into their original order.
  237.  
  238. (define (do-integrable-exps exps shape)
  239.   (iterate loop ((exps exps) (ints '()) (plain '()))
  240.     (cond ((null? exps)
  241.            (return (transmogrify-integrable-nodes ints)
  242.                    (sort-list plain
  243.                               (lambda (x y)
  244.                                 (fx< (module-exp-index x)
  245.                                      (module-exp-index y))))
  246.                    ints))
  247.           ((not (need-value? (module-exp-def (car exps)) shape))
  248.            (loop (cdr exps) ints (cons (car exps) plain)))
  249.           (else
  250.            (process-integrable-exp (car exps) shape)
  251.            (loop (cdr exps) (cons (car exps) ints) plain)))))
  252.  
  253. (define (need-value? name shape)
  254.   (and name
  255.        (let ((def (variable-definition
  256.                    (if (variable? name)
  257.                        name
  258.                        (table-entry (shape-new-env shape) name)))))
  259.          (and def (eq? 'constant (definition-variant def))))))
  260.  
  261. (define (transmogrify-integrable-nodes ints)
  262.   (iterate loop ((ints (int-defs->sorted-nodes ints)) (uses '()))
  263.     (cond ((null? ints)
  264.            uses)
  265.           (else
  266.            (set *current-module-exp* (car ints))
  267.            (loop (cdr ints)
  268.                  (transmogrify-node (module-exp-node (car ints)) uses))))))
  269.  
  270. ;;; Convert an expression containing an integrable definition into a node tree.
  271. ;;; The node-tree is analyzed to get the variable that is defined and any
  272. ;;; integrable variables that are used in the definition.  Nothing is done if
  273. ;;; it is not clear what value the node-tree defines.
  274.  
  275. (define (process-integrable-exp exp shape)
  276.   (set *current-module-exp* exp)
  277.   (let ((node (exp->node exp shape)))
  278.     (receive (defs uses)
  279.              (quick-def-and-use-analyze node)
  280.       (cond ((and (fx= 1 (length defs))
  281.                   (eq? (module-exp-def exp)
  282.                        (car defs)))
  283.              (set (module-exp-uses exp) (delq! (car defs) uses)))
  284.             (else
  285.              (bug '"expression ~S contains several defs" exp)))
  286.       (return))))
  287.  
  288. ;;; This procedure sorts INTS so that no integrable variable is used before it
  289. ;;; is defined.  (TABLE-ENTRY INT-TABLE <def>) is T if the definition has
  290. ;;; already been scheduled and NIL if it hasn't.
  291.  
  292. (define (int-defs->sorted-nodes ints)
  293.   (let ((int-table (make-table 'int-table)))
  294.     (walk (lambda (int)
  295.             (set (table-entry int-table (module-exp-def int)) t))
  296.           ints)
  297.     (iterate loop ((ints ints) (res '()))
  298.       (cond ((null? ints)
  299.              (reverse! res))
  300.             (else 
  301.              (receive (ready unready)
  302.                       (get-ready-int-defs ints int-table)
  303.                (walk (lambda (int)
  304.                        (set (table-entry int-table (module-exp-def int))
  305.                             nil))
  306.                      ready)
  307.                (loop unready (append! ready res))))))))
  308.  
  309. ;;; GET-READY-INT-DEFS finds the INT-DEFs that have no unscheduled
  310. ;;; predecessors.  If there aren't any then there is a recursive loop of
  311. ;;; integrable definitions and something should be done.
  312.  
  313. (define (get-ready-int-defs ints table)
  314.   (iterate loop ((ints ints) (unready '()) (ready '()))
  315.     (cond ((and (null? ints) ready)
  316.            (return (sort-list ready
  317.                               (lambda (x y)
  318.                                 (fx> (module-exp-index x)
  319.                                      (module-exp-index y))))
  320.                    unready))
  321.           ((null? ints)
  322.            (error '"integration loop ~S"
  323.                   (map (lambda (int) (variable-name (module-exp-def int)))
  324.                        unready)))
  325.           ((ready? (car ints) table)
  326.            (loop (cdr ints) unready (cons (car ints) ready)))
  327.           (else
  328.            (loop (cdr ints) (cons (car ints) unready) ready)))))
  329.  
  330. (define (ready? int table)
  331.   (let ((uses (filter! (lambda (use)
  332.                          (table-entry table use))
  333.                        (module-exp-uses int))))
  334.     (set (module-exp-uses int) uses)
  335.     (null? uses)))
  336.  
  337. ;;;              BUILDING EXPRESSION NODES INTO A CODE TREE
  338. ;;;============================================================================
  339.  
  340. ;;; Build nodes into a tree.  An extra thunk is wrapped around the entire
  341. ;;; tree because the rest of the compiler expects it to be there.
  342.  
  343. (define (rebuild nodes)
  344.   (map (lambda (n) (set (node-parent n) empty))
  345.        nodes)
  346.   (do ((first (car nodes) (attach first (car nodes)))
  347.        (nodes (cdr nodes) (cdr nodes)))
  348.       ((null? nodes)
  349.        (let ((top (value-node->thunk first)))
  350.          (set (node-parent top) nil)
  351.          top))))
  352.  
  353. ;;; NODE -> (LAMBDA () V) { = (LAMBDA (C) (C V)) in CPS}
  354.  
  355. (define (value-node->thunk node)
  356.   (let* ((c-var (create-variable 'k))
  357.          (new-l (create-lambda-node 'b (flist2 nil c-var '())))
  358.          (call (create-call-node 2 0)))
  359.     (relate call-proc call (create-reference-node c-var))
  360.     (relate (call-arg 1) call node)
  361.     (relate lambda-body new-l call)
  362.     new-l))
  363.  
  364. ;;; Make SECOND the continuation of FIRST.
  365.  
  366. (define (attach first second)
  367.   (let ((new-l (create-lambda-node 'b (flist1 (create-variable 'ignore) '())))
  368.         (c-var (car (lambda-variables first))))
  369.     (relate lambda-body new-l (detach (lambda-body second)))
  370.     (case (length (variable-refs c-var))
  371.       ((0)
  372.        (bug '"top level lambda ~S doesn't use its continuation" first))
  373.       ((1)
  374.        (let ((ref (car (variable-refs c-var))))
  375.          (cond ((eq? (node-role ref) call-proc)
  376.                 (replace (node-parent ref) (detach (lambda-body new-l)))
  377.                 (erase-all new-l))
  378.                (else
  379.                 (replace ref new-l)))
  380.          (relate lambda-body second (detach (lambda-body first)))
  381.          (erase first)))
  382.       (else
  383.        (let ((call (create-call-node 2 1)))
  384.          (relate call-proc call first)    
  385.          (relate (call-arg 1) call new-l)
  386.          (relate lambda-body second call))))
  387.     second))
  388.  
  389. ;;;                            DEBUGGING
  390. ;;;============================================================================
  391.  
  392. (define (free-refs name var)
  393.   (format t '"~&~S: ~S~%"
  394.           name
  395.           (let ((l
  396.                  (map (lambda (ref)
  397.                         (let ((loc (containing-definition (node-parent ref))))
  398.                           (if loc (variable-name loc) 'top-level)))
  399.                       (variable-refs var))))
  400.             (if (memq? 'top-level l)
  401.                 (cons 'top-level (delq! 'top-level l))
  402.                 l))))
  403.  
  404. (define (make-trees name erase?)
  405.   (receive (exp early-binding-env syntax #f)
  406.            (read-file (->filename name))
  407.     (front-init early-binding-env
  408.                 (lambda ()
  409.                   (receive (nodes env)
  410.                            (file-exps->nodes+shape (cddr exp) syntax)
  411.                     (cond (erase?
  412.                            (walk erase-all nodes)
  413.                            (return '() env))
  414.                           (else
  415.                            (return nodes env))))))))
  416.  
  417.  
  418.  
  419.