208 lines
8.3 KiB
Scheme
208 lines
8.3 KiB
Scheme
;; VM-Scheme
|
|
;; (c) 1996-1997 Sebastian Good
|
|
;; (c) 1997-2001 PLT
|
|
|
|
;; Mostly structure definitions for VM AST nodes.
|
|
|
|
(module vmscheme mzscheme
|
|
|
|
(require (lib "unitsig.ss")
|
|
(lib "list.ss")
|
|
(lib "etc.ss"))
|
|
|
|
(require (lib "zodiac-sig.ss" "syntax"))
|
|
|
|
(require "sig.ss")
|
|
(require "../sig.ss")
|
|
|
|
(provide vmscheme@)
|
|
(define vmscheme@
|
|
(unit/sig compiler:vmstructs^
|
|
(import compiler:library^
|
|
compiler:cstructs^
|
|
(zodiac : zodiac^)
|
|
compiler:zlayer^
|
|
compiler:driver^)
|
|
|
|
;; Block statements
|
|
(define-struct (vm:sequence zodiac:zodiac) (vals))
|
|
(define-struct (vm:if zodiac:zodiac) (test then else))
|
|
(define-struct (vm:module-body zodiac:zodiac) (vals invoke syntax?))
|
|
|
|
;; Tail position statements
|
|
(define-struct (vm:void zodiac:zodiac) (val))
|
|
(define-struct (vm:return zodiac:zodiac) (val))
|
|
(define-struct (vm:tail-apply zodiac:zodiac) (closure argc prim))
|
|
(define-struct (vm:tail-call zodiac:zodiac) (label closure set-env?))
|
|
(define-struct (vm:continue zodiac:zodiac) ())
|
|
|
|
;; non-tail imperative statements
|
|
(define-struct (vm:set! zodiac:zodiac) (vars val mode))
|
|
(define-struct (vm:generic-args zodiac:zodiac) (closure tail? prim vals))
|
|
(define-struct (vm:register-args zodiac:zodiac) (vars vals))
|
|
(define-struct (vm:args zodiac:zodiac) (type vals))
|
|
(define-struct (vm:begin0-mark! zodiac:zodiac) (var val))
|
|
(define-struct (vm:begin0-setup! zodiac:zodiac) (var))
|
|
(define-struct (vm:syntax! zodiac:zodiac) (vars val in-mod?))
|
|
|
|
;; r-values (1 step computations)
|
|
(define-struct (vm:alloc zodiac:zodiac) (type))
|
|
(define-struct (vm:build-constant zodiac:zodiac) (text))
|
|
(define-struct (vm:make-closure zodiac:zodiac) (closure))
|
|
(define-struct (vm:make-procedure-closure vm:make-closure)
|
|
(vehicle min-arity max-arity name empty? method?))
|
|
(define-struct (vm:make-case-procedure-closure vm:make-closure)
|
|
(vehicle num-cases case-arities name empty? method?))
|
|
(define-struct (vm:apply zodiac:zodiac)
|
|
(closure argc known? multi? prim simple-tail-prim?))
|
|
(define-struct (vm:macro-apply zodiac:zodiac)
|
|
(name primitive args tail? bool?))
|
|
(define-struct (vm:call zodiac:zodiac) (label closure))
|
|
(define-struct (vm:begin0-extract zodiac:zodiac) (var))
|
|
(define-struct (vm:wcm-mark! zodiac:zodiac) (key val))
|
|
(define-struct (vm:wcm-push! zodiac:zodiac) (var))
|
|
(define-struct (vm:wcm-pop! zodiac:zodiac) (var))
|
|
(define-struct (vm:wcm-remember! zodiac:zodiac) (var val))
|
|
(define-struct (vm:wcm-extract zodiac:zodiac) (var))
|
|
(define-struct (vm:check-global zodiac:zodiac) (var))
|
|
(define-struct (vm:module-create zodiac:zodiac) (shape id))
|
|
|
|
;; a-values
|
|
(define-struct (vm:global-varref zodiac:zodiac) (var))
|
|
(define-struct (vm:bucket zodiac:zodiac) (var))
|
|
(define-struct (vm:per-load-statics-table zodiac:zodiac) ())
|
|
(define-struct (vm:per-invoke-statics-table zodiac:zodiac) ())
|
|
(define-struct (vm:cast zodiac:zodiac) (val rep)) ; last resort
|
|
|
|
;; l-values (locations in memory)
|
|
(define-struct (vm:local-varref zodiac:zodiac) (var binding))
|
|
(define-struct (vm:static-varref zodiac:zodiac) (var))
|
|
(define-struct (vm:static-varref-from-lift vm:static-varref) (lambda))
|
|
(define-struct (vm:per-load-static-varref vm:static-varref) ())
|
|
(define-struct (vm:per-invoke-static-varref vm:static-varref) ())
|
|
(define-struct (vm:per-load-static-varref-from-lift vm:per-load-static-varref) (lambda))
|
|
(define-struct (vm:per-invoke-static-varref-from-lift vm:per-invoke-static-varref) (lambda))
|
|
(define-struct (vm:primitive-varref zodiac:zodiac) (var))
|
|
(define-struct (vm:symbol-varref zodiac:zodiac) (var))
|
|
(define-struct (vm:inexact-varref zodiac:zodiac) (var))
|
|
(define-struct (vm:struct-ref zodiac:zodiac) (field var))
|
|
(define-struct (vm:deref zodiac:zodiac) (var))
|
|
(define-struct (vm:ref zodiac:zodiac) (var))
|
|
|
|
;; immediate values
|
|
(define-struct (vm:immediate zodiac:zodiac) (text))
|
|
|
|
;; defines a structure type
|
|
;; all structures may be indexed by number as well.
|
|
(define-struct vm:struct-type (fields))
|
|
|
|
(define vm:box-struct-type (make-vm:struct-type '(box)))
|
|
|
|
;; argument types
|
|
(define arg-type:register 'arg-type:register)
|
|
(define arg-type:arg 'arg-type:arg)
|
|
(define arg-type:tail-arg 'arg-type:tail-arg)
|
|
|
|
;; set!-target types
|
|
(define target-type:global 'target-type:global)
|
|
(define target-type:lexical 'target-type:lexical)
|
|
(define target-type:static target-type:lexical)
|
|
|
|
;; this is the class of statements that make control leave the block
|
|
(define vm:control-return?
|
|
(one-of vm:return? vm:tail-apply? vm:tail-call? vm:continue?))
|
|
|
|
;; Defines fixnumness in the VM Scheme.
|
|
;; may change under different implementations; and will certainly
|
|
;; need to change as things get unwrapped...
|
|
(define vm:fixnum?
|
|
(lambda (n)
|
|
(and (exact? n) (integer? n) (< n (expt 2 30)) (> n (- (expt 2 30))))))
|
|
|
|
;; This function defines whether a constant must be built or not.
|
|
;; This functions answers #t to constants that may just appear
|
|
;; as constants in VM Scheme.
|
|
(define vm:literal-constant?
|
|
(let ([p? (one-of (all-of number? vm:fixnum?)
|
|
null?
|
|
boolean?
|
|
char?
|
|
void?
|
|
undefined?)])
|
|
(lambda (i)
|
|
(p? (syntax-e (zodiac:zodiac-stx i)))))))))
|
|
|
|
#|
|
|
|
|
(define vm:vm->sexp
|
|
(lambda (ast)
|
|
(cond
|
|
[(vm:sequence? ast) `(sequence ,@(map vm:vm->sexp (vm:sequence-vals ast)))]
|
|
[(vm:if? ast) `(if ,(vm:vm->sexp (vm:if-test ast))
|
|
,(vm:vm->sexp (vm:if-then ast))
|
|
,(vm:vm->sexp (vm:if-else ast)))]
|
|
[(vm:void? ast) `(void ,(vm:vm->sexp (vm:void-val ast)))]
|
|
[(vm:return? ast) `(return ,(vm:vm->sexp (vm:return-val ast)))]
|
|
[(vm:tail-apply? ast) `(tail-apply ,(vm:vm->sexp (vm:tail-apply-closure ast))
|
|
(argc ,(vm:tail-apply-argc ast))
|
|
(prim ,(vm:tail-apply-prim ast)))]
|
|
[(vm:tail-call? ast) `(tail-call ,label (set-env? ,(vm:tail-call-set-env? ast)))]
|
|
[(vm:continue? ast) '(continue)]
|
|
[(vm:set!? ast) `(set! ,@(map (lambda (v)
|
|
`(,(car v) ,(vm:vm->sexp (cdr v))))
|
|
(vm:set!-vars ast))
|
|
,(vm:vm->sexp (vm:set!-val ast)))]
|
|
[(vm:generic-args? ast)
|
|
`(generic-args (tail? ,(vm:generic-args-tail? ast))
|
|
(prim ,(vm:generic-args-prim ast))
|
|
(vals ,@(map vm:vm->sexp (vm:generic-args-vals ast))))]
|
|
[(vm:args? ast)
|
|
`(args (type ,(vm:args-type ast)) (vals ,@(map vm:vm->sexp (vm:args-vals ast))))]
|
|
[(vm:struct? ast)
|
|
(let ([super (vm:struct-super ast)])
|
|
`(struct ,(vm:struct-type ast)
|
|
,(if super (vm:vm->sexp (vm:struct-super ast)) #f)
|
|
,(vm:struct-fields ast)))]
|
|
[(vm:alloc? ast)
|
|
`(alloc ,(rep->sexp (vm:alloc-type ast)))]
|
|
|
|
[(vm:build-constant? ast)
|
|
`(build-constant ,(zodiac:zread-object (vm:build-constant-text ast)))]
|
|
[(vm:make-procedure-closure? ast)
|
|
`(make-procedure-closure ,(vm:vm->sexp (vm:make-closure-closure ast))
|
|
,(vm:make-closure-min-arity ast)
|
|
,(vm:make-closure-max-arity ast))]
|
|
[(vm:apply? ast)
|
|
`(apply ,(vm:vm->sexp (vm:apply-closure ast))
|
|
(argc ,(vm:apply-argc ast))
|
|
(known? ,(vm:apply-known? ast))
|
|
(multi? ,(vm:apply-multi? ast))
|
|
(prim ,(vm:apply-prim ast)))]
|
|
[(vm:call? ast)
|
|
`(call ,(vm:call-label ast))]
|
|
[(vm:global-varref? ast)
|
|
`(global-varref ,(vm:global-varref-var ast))]
|
|
[(vm:local-varref? ast)
|
|
`(local-varref ,(vm:local-varref-var ast))]
|
|
[(vm:static-varref? ast)
|
|
`(static-varref ,(vm:static-varref-var ast))]
|
|
[(vm:primitive-varref? ast)
|
|
`(primitive-varref ,(vm:primitive-varref-var ast))]
|
|
[(vm:struct-ref? ast)
|
|
`(struct-ref ,(vm:struct-ref-field ast)
|
|
,(vm:vm->sexp (vm:struct-ref-var ast)))]
|
|
[(vm:deref? ast)
|
|
`(deref ,(vm:vm->sexp (vm:deref-var ast)))]
|
|
[(vm:ref? ast)
|
|
`(ref ,(vm:vm->sexp (vm:ref-var ast)))]
|
|
[(vm:immediate? ast)
|
|
(let ([text (vm:immediate-text ast)])
|
|
`(immediate ,(cond [(number? text)
|
|
`(label ,text)]
|
|
[(zodiac:zread? text)
|
|
(zodiac:zread-object text)]
|
|
[else (error 'vm:vm->sexp "~a bad immediate text" text)])))]
|
|
[else
|
|
(error 'vm:vm->sexp "~a not supported" ast)])))
|
|
|#
|