Changeset 11650 in project


Ignore:
Timestamp:
08/16/08 02:37:23 (11 years ago)
Author:
Ivan Raikov
Message:

Some updates to the node module.

Location:
release/3/prescheme-compiler
Files:
1 added
1 edited

Legend:

Unmodified
Added
Removed
  • release/3/prescheme-compiler/node/node.scm

    r11110 r11650  
     1
     2(require-extension srfi-69)
     3(require-extension vector-lib)
    14
    25; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
     
    811
    912(define-record-type variable
    10   ((name)        ; Source code name for variable (used for debugging only)
    11    (id)          ; Unique numeric identifier     (used for debugging only)
    12    (type)        ; Type for variable's value
     13  (variable-maker
     14   name        ; Source code name for variable (used for debugging only)
     15   id          ; Unique numeric identifier     (used for debugging only)
     16   type        ; Type for variable's value
    1317   )
    14   (binder        ; LAMBDA node which binds this variable
    15    (refs '())    ; List of leaf nodes n for which (REFERENCE-VARIABLE n) = var.
    16    (flag #f)     ; Useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
    17                  ; all users must leave this is #F
    18    (flags '())   ; For various annotations, e.g. IGNORABLE
    19    (generate #f) ; For whatever code generation wants
    20    ))
    21 
    22 (define-record-discloser type/variable
    23   (lambda (var)
    24     (node-hash var)
    25     (list 'variable (variable-name var) (variable-id var))))
     18  variable?
     19  (name variable-name)
     20  (id variable-id)
     21  (type variable-type)
     22  (binder variable-binder set-variable-binder!)        ; LAMBDA node which binds this variable
     23  (refs variable-refs set-variable-refs!)    ; List of leaf nodes n for which (REFERENCE-VARIABLE n) = var.
     24  (flag variable-flag set-variable-flag!)    ; Useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
     25                                        ; all users must leave this is #F
     26  (flags variable-flags set-variable-flags!)   ; For various annotations, e.g. IGNORABLE
     27  (generate variable-generate set-variable-generate!) ; For whatever code generation wants
     28  )
     29
     30(define-record-printer (variable x out)
     31  (fprintf out "#(variable ~S ~A)"
     32           (variable-name x)
     33           (variable-id x)) )
    2634
    2735(define (make-variable name type)
    28   (variable-maker name (new-id) type))
     36  (let ((var (variable-maker name (new-id) type)))
     37    (set-variable-binder! var #f)
     38    (set-variable-refs! var (list))
     39    (set-variable-flag! var #f)
     40    (set-variable-flags! var (list))
     41    (set-variable-generate! var #f)
     42    var))
     43
    2944
    3045(define (make-global-variable name type)
     
    5570(define (reset-node-id)
    5671  (set! *variable-id* 0)
    57   (set! *node-hash-table* (make-table)))
     72  (set! *node-hash-table* (make-hash-table)))
    5873
    5974(define (node-hash var-or-lambda)
     
    6176                (variable-id var-or-lambda)
    6277                (lambda-id var-or-lambda))))
    63     (table-set! *node-hash-table* id var-or-lambda)))
     78    (hash-table-set! *node-hash-table* id var-or-lambda)))
    6479
    6580(define (node-unhash n)
    66   (table-ref *node-hash-table* n))
     81  (hash-table-ref *node-hash-table* n))
    6782
    6883; The index of VAR in the variables bound by its binder.
     
    128143
    129144(define-record-type node
    130   ((variant)           ; One of LAMBDA, CALL, REFERENCE, LITERAL
     145  (node-maker variant           ; One of LAMBDA, CALL, REFERENCE, LITERAL
    131146   )
    132   ((parent empty)      ; Parent node
    133    (index '<free>)     ; Index of this node in parent
    134    (simplified? #f)    ; True if it has already been simplified.
    135    (flag #f)           ; Useful flag, all users must leave this is #F
    136    stuff-0             ; Variant components - each type of node has a different
    137    stuff-1             ; use for these fields
    138    stuff-2
    139    stuff-3
     147  node?
     148  ((parent node-parent set-node-parent!)  ; Parent node
     149   (index node-index set-node-index!)     ; Index of this node in parent
     150   (simplified? node-simplified? set-node-simplified?!)    ; True if it has already been simplified.
     151   (flag node-flag set-node-flag!)           ; Useful flag, all users must leave this is #F
     152   (stuff-0 node-stuff-0 set-node-stuff-0!)  ; Variant components - each type of node has a different
     153   (stuff-1 node-stuff-1 set-node-stuff-1!)  ; use for these fields
     154   (stuff-2 node-stuff-2 set-node-stuff-2!)             
     155   (stuff-3 node-stuff-3 set-node-stuff-3!)             
    140156   ))
    141157
    142 (define-record-discloser type/node
    143   (lambda (node)
    144     `(node ,(node-variant node)
    145            . ,(case (node-variant node)
    146                 ((lambda)
    147                  (node-hash node)
    148                  (list (lambda-name node) (lambda-id node)))
    149                 ((call)
    150                  (list (primop-id (call-primop node))))
    151                 ((reference)
    152                  (let ((var (reference-variable node)))
    153                    (list (variable-name var) (variable-id var))))
    154                 ((literal)
    155                  (list (literal-value node)))
    156                 (else
    157                  '())))))
    158 
    159 (define make-node node-maker)
     158
     159(define-record-printer (node x out)
     160  (fprintf out "#(node ~A ~A)"
     161           (node-variant x)
     162           (case (node-variant node)
     163             ((lambda)
     164              (node-hash node)
     165              (list (lambda-name node) (lambda-id node)))
     166             ((call)
     167              (list (primop-id (call-primop node))))
     168             ((reference)
     169              (let ((var (reference-variable node)))
     170                (list (variable-name var) (variable-id var))))
     171             ((literal)
     172              (list (literal-value node)))
     173             (else
     174              '()))))
     175
     176(define (make-node variant)
     177  (let ((n (node-maker variant)))
     178    (set-node-parent! n empty)      ; Parent node
     179    (set-node-index! n '<free>)     ; Index of this node in parent
     180    (set-node-simplified?! n #f)    ; True if it has already been simplified.
     181    (set-node-flag! n #f)           ; Useful flag, all users must leave this is #F
     182    n))
     183   
    160184
    161185;--------------------------------------------------------------------------
     
    177201(define (erase node)
    178202  (let label ((node node))
    179     (cond ((empty? node)
    180            #f)
     203    (cond ((empty? node)  #f)
    181204          (else
    182205           (case (node-variant node)
     
    184207              (label (lambda-body node)))
    185208             ((call)
    186               (walk-vector label (call-args node))))
     209              (vector-for-each label (call-args node))))
    187210           (really-erase node)))))
    188211
     
    322345;-------------------------------------------------------------------------
    323346; Syntax for defining the different types of nodes.
    324 
     347#|
    325348(define-syntax define-node-type
    326349  (lambda (form rename compare)
     
    337360                                   . ,r))))
    338361                       ((null? s) (reverse r))))))))
     362|#
     363
    339364
    340365; These are used to rename the NODE-STUFF fields of particular node variants.
Note: See TracChangeset for help on using the changeset viewer.