TakeV/guile-prescheme
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Separate node and variable interfaces

Browse source
This commit is contained in:
Andrew Whatson 2022-08-15 12:08:30 +10:00
parent 1c3eb6636b
commit 7a6e0ff177
3 changed files with 162 additions and 144 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
hall.scm
View file

@ -53,6 +53,7 @@
(scheme-file "node-util")
(scheme-file "pp-cps")
(scheme-file "primop")
(scheme-file "variable")
(scheme-file "vector")))
(scheme-file "param")
(directory

147
ps-compiler/node/node.scm
View file

@ -7,9 +7,6 @@
;;; scheme48-1.9.2/ps-compiler/node/node.scm
;;;
;;; This file contains the definitions of the node tree data structure.
;;;
;;;---------------------------------------------------------------------------
;;; Records to represent variables.
(define-module (ps-compiler node node)
#:use-module (prescheme scheme48)
@ -17,31 +14,10 @@
#:use-module (prescheme record-discloser)
#:use-module (prescheme syntax-utils)
#:use-module (ps-compiler node primop)
#:use-module (ps-compiler node variable)
#:use-module (ps-compiler util syntax)
#:use-module (ps-compiler util util)
#:replace (make-variable variable?)
#:export (global-variable? make-global-variable
variable-name set-variable-name!
variable-id
variable-type set-variable-type!
variable-binder set-variable-binder!
variable-refs set-variable-refs!
variable-flag set-variable-flag!
variable-flags set-variable-flags!
variable-generate set-variable-generate!
erase-variable
variable-index copy-variable used? unused?
variable-flag-accessor variable-flag-setter variable-flag-remover
variable-known-value
add-variable-known-value!
remove-variable-known-value!
variable-simplifier
add-variable-simplifier!
remove-variable-simplifier!
note-known-global-lambda!
variable-known-lambda
reset-node-id node-hash node-unhash
#:export (reset-node-id node-hash node-unhash
node? node-variant
node-parent set-node-parent!
@ -97,123 +73,6 @@
change-lambda-type
walk-lambdas make-lambda-list))
(define-record-type variable
((name) ;; Source code name for variable (used for debugging only)
(id) ;; Unique numeric identifier (used for debugging only)
(type) ;; Type for variable's value
)
(binder ;; LAMBDA node which binds this variable
(refs '()) ;; List of leaf nodes n for which (REFERENCE-VARIABLE n) = var.
(flag #f) ;; Useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
;; all users must leave this is #F
(flags '()) ;; For various annotations, e.g. IGNORABLE
(generate #f) ;; For whatever code generation wants
))
(define-record-discloser type/variable
(lambda (var)
(node-hash var)
(list 'variable (variable-name var) (variable-id var))))
(define (make-variable name type)
(variable-maker name (new-id) type))
(define (make-global-variable name type)
(let ((var (make-variable name type)))
(set-variable-binder! var #f)
var))
(define (global-variable? var)
(not (variable-binder var)))
;; Every variable has a unique numeric identifier that is used for printing.
(define *variable-id* 0)
(define (new-id)
(let ((id *variable-id*))
(set! *variable-id* (+ 1 *variable-id*))
id))
(define (erase-variable var)
(cond ((eq? (variable-id var) '<erased>)
(bug "variable ~S already erased" var))
(else
(set-variable-id! var '<erased>))))
(define *node-hash-table* #f)
(define (reset-node-id)
(set! *variable-id* 0)
(set! *node-hash-table* (make-table)))
(define (node-hash var-or-lambda)
(let ((id (if (variable? var-or-lambda)
(variable-id var-or-lambda)
(lambda-id var-or-lambda))))
(table-set! *node-hash-table* id var-or-lambda)))
(define (node-unhash n)
(table-ref *node-hash-table* n))
;; The index of VAR in the variables bound by its binder.
(define (variable-index var)
(let ((binder (variable-binder var)))
(if (not binder)
(bug "VARIABLE-INDEX called on global variable ~S" var)
(do ((i 0 (+ i 1))
(vs (lambda-variables binder) (cdr vs)))
((eq? (car vs) var)
i)))))
;; Copy an old variable.
(define (copy-variable old)
(let ((var (make-variable (variable-name old) (variable-type old))))
(set-variable-flags! var (variable-flags old))
var))
;; An unused variable is either #F or a variable with no references.
(define (used? var)
(and var
(not (null? (variable-refs var)))))
(define (unused? var)
(not (used? var)))
;; known values for top-level variables
(define (variable-flag-accessor flag)
(lambda (var)
(let ((p (flag-assq flag (variable-flags var))))
(if p (cdr p) #f))))
(define (variable-flag-setter flag)
(lambda (var value)
(set-variable-flags! var
(cons (cons flag value)
(variable-flags var)))))
(define (variable-flag-remover flag)
(lambda (var)
(set-variable-flags! var (filter (lambda (x)
(or (not (pair? x))
(not (eq? (car x) flag))))
(variable-flags var)))))
(define variable-known-value (variable-flag-accessor 'known-value))
(define add-variable-known-value! (variable-flag-setter 'known-value))
(define remove-variable-known-value! (variable-flag-remover 'known-value))
(define variable-simplifier (variable-flag-accessor 'simplifier))
(define add-variable-simplifier! (variable-flag-setter 'simplifier))
(define remove-variable-simplifier! (variable-flag-remover 'simplifier))
(define variable-known-lambda (variable-flag-accessor 'known-lambda))
(define note-known-global-lambda! (variable-flag-setter 'known-lambda))
;;----------------------------------------------------------------------------
;; The main record for the node tree
@ -617,7 +476,7 @@
(define (make-lambda-node name type vars)
(let ((node (make-node 'lambda))
(data (lambda-data-maker name (new-id) type)))
(data (lambda-data-maker name (new-variable-id) type)))
(set-lambda-body! node empty)
(set-lambda-variables! node vars)
(set-lambda-data! node data)

158
ps-compiler/node/variable.scm Normal file
View file

@ -0,0 +1,158 @@
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey
;;;
;;; scheme48-1.9.2/ps-compiler/node/node.scm
;;;
;;; This file contains the definitions of the node tree data structure.
(define-module (ps-compiler node variable)
#:use-module (prescheme scheme48)
#:use-module (prescheme s48-defrecord)
#:use-module (prescheme record-discloser)
#:use-module (ps-compiler node node)
#:use-module (ps-compiler util util)
#:replace (variable? make-variable)
#:export (global-variable? make-global-variable
variable-name set-variable-name!
variable-id
variable-type set-variable-type!
variable-binder set-variable-binder!
variable-refs set-variable-refs!
variable-flag set-variable-flag!
variable-flags set-variable-flags!
variable-generate set-variable-generate!
new-variable-id
erase-variable
variable-index copy-variable used? unused?
variable-flag-accessor variable-flag-setter variable-flag-remover
variable-known-value
add-variable-known-value!
remove-variable-known-value!
variable-simplifier
add-variable-simplifier!
remove-variable-simplifier!
note-known-global-lambda!
variable-known-lambda))
;;;---------------------------------------------------------------------------
;;; Records to represent variables.
(define-record-type variable
((name) ;; Source code name for variable (used for debugging only)
(id) ;; Unique numeric identifier (used for debugging only)
(type) ;; Type for variable's value
)
(binder ;; LAMBDA node which binds this variable
(refs '()) ;; List of leaf nodes n for which (REFERENCE-VARIABLE n) = var.
(flag #f) ;; Useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
;; all users must leave this is #F
(flags '()) ;; For various annotations, e.g. IGNORABLE
(generate #f) ;; For whatever code generation wants
))
(define-record-discloser type/variable
(lambda (var)
(node-hash var)
(list 'variable (variable-name var) (variable-id var))))
(define (make-variable name type)
(variable-maker name (new-variable-id) type))
(define (make-global-variable name type)
(let ((var (make-variable name type)))
(set-variable-binder! var #f)
var))
(define (global-variable? var)
(not (variable-binder var)))
;; Every variable has a unique numeric identifier that is used for printing.
(define *variable-id* 0)
(define (new-variable-id)
(let ((id *variable-id*))
(set! *variable-id* (+ 1 *variable-id*))
id))
(define (erase-variable var)
(cond ((eq? (variable-id var) '<erased>)
(bug "variable ~S already erased" var))
(else
(set-variable-id! var '<erased>))))
(define *node-hash-table* #f)
(define (reset-node-id)
(set! *variable-id* 0)
(set! *node-hash-table* (make-table)))
(define (node-hash var-or-lambda)
(let ((id (if (variable? var-or-lambda)
(variable-id var-or-lambda)
(lambda-id var-or-lambda))))
(table-set! *node-hash-table* id var-or-lambda)))
(define (node-unhash n)
(table-ref *node-hash-table* n))
;; The index of VAR in the variables bound by its binder.
(define (variable-index var)
(let ((binder (variable-binder var)))
(if (not binder)
(bug "VARIABLE-INDEX called on global variable ~S" var)
(do ((i 0 (+ i 1))
(vs (lambda-variables binder) (cdr vs)))
((eq? (car vs) var)
i)))))
;; Copy an old variable.
(define (copy-variable old)
(let ((var (make-variable (variable-name old) (variable-type old))))
(set-variable-flags! var (variable-flags old))
var))
;; An unused variable is either #F or a variable with no references.
(define (used? var)
(and var
(not (null? (variable-refs var)))))
(define (unused? var)
(not (used? var)))
;; known values for top-level variables
(define (variable-flag-accessor flag)
(lambda (var)
(let ((p (flag-assq flag (variable-flags var))))
(if p (cdr p) #f))))
(define (variable-flag-setter flag)
(lambda (var value)
(set-variable-flags! var
(cons (cons flag value)
(variable-flags var)))))
(define (variable-flag-remover flag)
(lambda (var)
(set-variable-flags! var (filter (lambda (x)
(or (not (pair? x))
(not (eq? (car x) flag))))
(variable-flags var)))))
(define variable-known-value (variable-flag-accessor 'known-value))
(define add-variable-known-value! (variable-flag-setter 'known-value))
(define remove-variable-known-value! (variable-flag-remover 'known-value))
(define variable-simplifier (variable-flag-accessor 'simplifier))
(define add-variable-simplifier! (variable-flag-setter 'simplifier))
(define remove-variable-simplifier! (variable-flag-remover 'simplifier))
(define variable-known-lambda (variable-flag-accessor 'known-lambda))
(define note-known-global-lambda! (variable-flag-setter 'known-lambda))