X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/7493339cfc36cf95b77aa8a1ad4cd0b5dd36710a..b0b180d5227d76f5ca1e2f48b06f6d45195bd1f8:/module/system/il/glil.scm diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm index d26ba16b2..4969a0bad 100644 --- a/module/system/il/glil.scm +++ b/module/system/il/glil.scm @@ -20,10 +20,10 @@ ;;; Code: (define-module (system il glil) - #:use-syntax (system base syntax) + #:use-module (system base syntax) + #:use-module (system base pmatch) #:export - (pprint-glil - make-glil-vars + ( make-glil-vars glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts make-glil-asm glil-asm? @@ -70,11 +70,16 @@ glil-call-inst glil-call-nargs make-glil-mv-call glil-mv-call? - glil-mv-call-nargs glil-mv-call-ra)) + glil-mv-call-nargs glil-mv-call-ra -(define-record ( nargs nrest nlocs nexts)) + parse-glil unparse-glil)) -(define-type +(define-record nargs nrest nlocs nexts) + +(define (print-glil x port) + (format port "#" (unparse-glil x))) + +(define-type ( #:printer print-glil) ;; Meta operations ( vars meta body) ( vars) @@ -97,125 +102,57 @@ ( nargs ra)) -;;; -;;; Parser -;;; - -;;; (define (parse-glil x) -;;; (match x -;;; (('@asm args . body) -;;; (let* ((env (make-new-env e)) -;;; (args (parse-args args env))) -;;; (make-asm env args (map-parse body env)))) -;;; (else -;;; (error "Invalid assembly code:" x)))) -;;; -;;; (define (parse-args x e) -;;; (let ((args (cond ((symbol? x) (make-args (list (make-local-var x)) #t)) -;;; ((list? x) (make-args (map make-local-var x) #f)) -;;; (else (let loop ((l x) (v '())) -;;; (if (pair? l) -;;; (loop (cdr l) (cons (car l) v)) -;;; (make-args (map make-local-var -;;; (reverse! (cons l v))) -;;; #t))))))) -;;; (for-each (lambda (v) (env-add! e v)) (args-vars args)) -;;; args)) -;;; -;;; (define (map-parse x e) -;;; (map (lambda (x) (parse x e)) x)) -;;; -;;; (define (parse x e) -;;; (match x -;;; ;; (@asm ARGS BODY...) -;;; (('@asm args . body) -;;; (parse-asm x e)) -;;; ;; (@bind VARS BODY...) -;;; ;; (@block VARS BODY...) -;;; (((or '@bind '@block) vars . body) -;;; (let* ((offset (env-nvars e)) -;;; (vars (args-vars (parse-args vars e))) -;;; (block (make-block (car x) offset vars (map-parse body e)))) -;;; (for-each (lambda (v) (env-remove! e)) vars) -;;; block)) -;;; ;; (void) -;;; (('void) -;;; (make-void)) -;;; ;; (const OBJ) -;;; (('const obj) -;;; (make-const obj)) -;;; ;; (ref NAME) -;;; ;; (set NAME) -;;; (((or 'ref 'set) name) -;;; (make-access (car x) (env-ref e name))) -;;; ;; (label LABEL) -;;; (('label label) -;;; (make-label label)) -;;; ;; (br-if LABEL) -;;; ;; (jump LABEL) -;;; (((or 'br-if 'jump) label) -;;; (make-instl (car x) label)) -;;; ;; (call NARGS) -;;; ;; (tail-call NARGS) -;;; (((or 'call 'goto/args) n) -;;; (make-instn (car x) n)) -;;; ;; (INST) -;;; ((inst) -;;; (if (instruction? inst) -;;; (make-inst inst) -;;; (error "Unknown instruction:" inst))))) - - -;;; -;;; Unparser -;;; - -(define (unparse glil) +(define (parse-glil x) + (pmatch x + ((asm (,nargs ,nrest ,nlocs ,next) ,meta . ,body) + (make-glil-asm (make-glil-vars nargs nrest nlocs next) + meta (map parse-glil body))) + ((bind . ,vars) (make-glil-bind vars)) + ((mv-bind ,vars . ,rest) (make-glil-mv-bind vars (map parse-glil rest))) + ((unbind) (make-glil-unbind)) + ((source ,loc) (make-glil-source loc)) + ((void) (make-glil-void)) + ((const ,obj) (make-glil-const obj)) + ((argument ,op ,index) (make-glil-argument op index)) + ((local ,op ,index) (make-glil-local op index)) + ((external ,op ,depth ,index) (make-glil-external op depth index)) + ((toplevel ,op ,name) (make-glil-toplevel op name)) + ((module public ,op ,mod ,name) (make-glil-module op mod name #t)) + ((module private ,op ,mod ,name) (make-glil-module op mod name #f)) + ((label ,label) (make-label ,label)) + ((branch ,inst ,label) (make-glil-branch inst label)) + ((call ,inst ,nargs) (make-glil-call inst nargs)) + ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra)) + (else (error "invalid glil" x)))) + +(define (unparse-glil glil) (record-case glil ;; meta (( vars meta body) - `(@asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars) - ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars)) - ,meta - ,@(map unparse body))) - (( vars) `(@bind ,@vars)) - (() `(@unbind)) - (( loc) `(@source ,loc)) + `(asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars) + ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars)) + ,meta + ,@(map unparse-glil body))) + (( vars) `(bind ,@vars)) + (( vars rest) `(mv-bind ,vars ,@rest)) + (() `(unbind)) + (( loc) `(source ,loc)) ;; constants (() `(void)) (( obj) `(const ,obj)) ;; variables (( op index) - `(,(symbol-append 'argument- op) ,index)) + `(argument ,op ,index)) (( op index) - `(,(symbol-append 'local- op) ,index)) + `(local ,op ,index)) (( op depth index) - `(,(symbol-append 'external- op) ,depth ,index)) + `(external ,op ,depth ,index)) (( op name) - `(,(symbol-append 'toplevel- op) ,name)) + `(toplevel ,op ,name)) (( op mod name public?) - `(,(symbol-append (if public? 'public 'private) '- op) ,mod ,name)) + `(module ,(if public? 'public 'private) ,op ,mod ,name)) ;; controls - (( label) label) - (( inst label) `(,inst ,label)) - (( inst nargs) `(,inst ,nargs)))) - - -;;; -;;; Printer -;;; - -(define (pprint-glil glil . port) - (let ((port (if (pair? port) (car port) (current-output-port)))) - (let print ((code (unparse glil)) (column 0)) - (display (make-string column #\space) port) - (cond ((and (pair? code) (eq? (car code) '@asm)) - (format port "(@asm ~A\n" (cadr code)) - (let ((col (+ column 2))) - (let loop ((l (cddr code))) - (print (car l) col) - (if (null? (cdr l)) - (display ")" port) - (begin (newline port) (loop (cdr l))))))) - (else (write code port)))) - (newline port))) + (( label) (label ,label)) + (( inst label) `(branch ,inst ,label)) + (( inst nargs) `(call ,inst ,nargs)) + (( nargs ra) `(mv-call ,nargs ,(unparse-glil ra)))))