module/language/ghil.scm

   1 ;;; Guile High Intermediate Language
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language ghil)
  22   #:use-module (system base syntax)
  23   #:use-module (system base pmatch)
  24   #:use-module (ice-9 regex)
  25   #:export
  26   (ghil-env ghil-loc
  27
  28    <ghil-void> make-ghil-void ghil-void?
  29    ghil-void-env ghil-void-loc
  30
  31    <ghil-quote> make-ghil-quote ghil-quote?
  32    ghil-quote-env ghil-quote-loc ghil-quote-obj
  33
  34    <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote?
  35    ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp
  36
  37    <ghil-unquote> make-ghil-unquote ghil-unquote?
  38    ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
  39
  40    <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing?
  41    ghil-unquote-splicing-env ghil-unquote-splicing-loc ghil-unquote-splicing-exp
  42
  43    <ghil-ref> make-ghil-ref ghil-ref?
  44    ghil-ref-env ghil-ref-loc ghil-ref-var
  45
  46    <ghil-set> make-ghil-set ghil-set?
  47    ghil-set-env ghil-set-loc ghil-set-var ghil-set-val
  48
  49    <ghil-define> make-ghil-define ghil-define?
  50    ghil-define-env ghil-define-loc ghil-define-var ghil-define-val
  51
  52    <ghil-if> make-ghil-if ghil-if?
  53    ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else
  54
  55    <ghil-and> make-ghil-and ghil-and?
  56    ghil-and-env ghil-and-loc ghil-and-exps
  57
  58    <ghil-or> make-ghil-or ghil-or?
  59    ghil-or-env ghil-or-loc ghil-or-exps
  60
  61    <ghil-begin> make-ghil-begin ghil-begin?
  62    ghil-begin-env ghil-begin-loc ghil-begin-exps
  63
  64    <ghil-bind> make-ghil-bind ghil-bind?
  65    ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
  66
  67    <ghil-mv-bind> make-ghil-mv-bind ghil-mv-bind?
  68    ghil-mv-bind-env ghil-mv-bind-loc ghil-mv-bind-producer ghil-mv-bind-vars ghil-mv-bind-rest ghil-mv-bind-body
  69
  70    <ghil-lambda> make-ghil-lambda ghil-lambda?
  71    ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest
  72    ghil-lambda-meta ghil-lambda-body
  73
  74    <ghil-inline> make-ghil-inline ghil-inline?
  75    ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
  76
  77    <ghil-call> make-ghil-call ghil-call?
  78    ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
  79
  80    <ghil-mv-call> make-ghil-mv-call ghil-mv-call?
  81    ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer ghil-mv-call-consumer
  82
  83    <ghil-values> make-ghil-values ghil-values?
  84    ghil-values-env ghil-values-loc ghil-values-values
  85
  86    <ghil-values*> make-ghil-values* ghil-values*?
  87    ghil-values*-env ghil-values*-loc ghil-values*-values
  88
  89    <ghil-var> make-ghil-var ghil-var?
  90    ghil-var-env ghil-var-name ghil-var-kind ghil-var-index
  91
  92    <ghil-toplevel-env> make-ghil-toplevel-env ghil-toplevel-env?
  93    ghil-toplevel-env-table
  94
  95    <ghil-env> make-ghil-env ghil-env?
  96    ghil-env-parent ghil-env-table ghil-env-variables
  97
  98    <ghil-reified-env> make-ghil-reified-env ghil-reified-env?
  99    ghil-reified-env-env ghil-reified-env-loc
 100
 101    ghil-env-add!
 102    ghil-env-reify ghil-env-dereify
 103    ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define!
 104    ghil-var-at-module!
 105    call-with-ghil-environment call-with-ghil-bindings
 106
 107    parse-ghil unparse-ghil))
 108
 109 \f
 110 ;;;
 111 ;;; Parse tree
 112 ;;;
 113
 114 (define (print-ghil x port)
 115   (format port "#<ghil ~s>" (unparse-ghil x)))
 116
 117 (define-type (<ghil> #:printer print-ghil
 118                      #:common-slots (env loc))
 119   ;; Objects
 120   (<ghil-void>)
 121   (<ghil-quote> obj)
 122   (<ghil-quasiquote> exp)
 123   (<ghil-unquote> exp)
 124   (<ghil-unquote-splicing> exp)
 125   ;; Variables
 126   (<ghil-ref> var)
 127   (<ghil-set> var val)
 128   (<ghil-define> var val)
 129   ;; Controls
 130   (<ghil-if> test then else)
 131   (<ghil-and> exps)
 132   (<ghil-or> exps)
 133   (<ghil-begin> exps)
 134   (<ghil-bind> vars vals body)
 135   (<ghil-mv-bind> producer vars rest body)
 136   (<ghil-lambda> vars rest meta body)
 137   (<ghil-call> proc args)
 138   (<ghil-mv-call> producer consumer)
 139   (<ghil-inline> inline args)
 140   (<ghil-values> values)
 141   (<ghil-values*> values)
 142   (<ghil-reified-env>))
 143
 144
 145 \f
 146 ;;;
 147 ;;; Variables
 148 ;;;
 149
 150 (define-record <ghil-var> env name kind (index #f))
 151
 152 \f
 153 ;;;
 154 ;;; Modules
 155 ;;;
 156
 157 \f
 158 ;;;
 159 ;;; Environments
 160 ;;;
 161
 162 (define-record <ghil-env> parent (table '()) (variables '()))
 163 (define-record <ghil-toplevel-env> (table '()))
 164
 165 (define (ghil-env-ref env sym)
 166   (assq-ref (ghil-env-table env) sym))
 167
 168 (define-macro (push! item loc)
 169   `(set! ,loc (cons ,item ,loc)))
 170 (define-macro (apush! k v loc)
 171   `(set! ,loc (acons ,k ,v ,loc)))
 172 (define-macro (apopq! k loc)
 173   `(set! ,loc (assq-remove! ,loc ,k)))
 174
 175 (define (ghil-env-add! env var)
 176   (apush! (ghil-var-name var) var (ghil-env-table env))
 177   (push! var (ghil-env-variables env)))
 178
 179 (define (ghil-env-remove! env var)
 180   (apopq! (ghil-var-name var) (ghil-env-table env)))
 181
 182 (define (force-heap-allocation! var)
 183   (set! (ghil-var-kind var) 'external))
 184
 185
 186 \f
 187 ;;;
 188 ;;; Public interface
 189 ;;;
 190
 191 ;; The following four functions used to be one, in ghil-lookup. Now they
 192 ;; are four, to reflect the different intents. A bit of duplication, but
 193 ;; that's OK. The common current is to find out where a variable will be
 194 ;; stored at runtime.
 195 ;;
 196 ;; These functions first search the lexical environments. If the
 197 ;; variable is not in the innermost environment, make sure the variable
 198 ;; is marked as being "external" so that it goes on the heap. If the
 199 ;; variable is being modified (via a set!), also make sure it's on the
 200 ;; heap, so that other continuations see the changes to the var.
 201 ;;
 202 ;; If the variable is not found lexically, it is a toplevel variable,
 203 ;; which will be looked up at runtime with respect to the module that
 204 ;; was current when the lambda was bound, at runtime. The variable will
 205 ;; be resolved when it is first used.
 206 (define (ghil-var-is-bound? env sym)
 207   (let loop ((e env))
 208     (record-case e
 209       ((<ghil-toplevel-env> table)
 210        (let ((key (cons (module-name (current-module)) sym)))
 211          (assoc-ref table key)))
 212       ((<ghil-env> parent table variables)
 213        (and (not (assq-ref table sym))
 214             (loop parent))))))
 215
 216 (define (ghil-var-for-ref! env sym)
 217   (let loop ((e env))
 218     (record-case e
 219       ((<ghil-toplevel-env> table)
 220        (let ((key (cons (module-name (current-module)) sym)))
 221          (or (assoc-ref table key)
 222              (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
 223                (apush! key var (ghil-toplevel-env-table e))
 224                var))))
 225       ((<ghil-env> parent table variables)
 226        (cond
 227         ((assq-ref table sym)
 228          => (lambda (var)
 229               (or (eq? e env)
 230                   (force-heap-allocation! var))
 231               var))
 232         (else
 233          (loop parent)))))))
 234
 235 (define (ghil-var-for-set! env sym)
 236   (let loop ((e env))
 237     (record-case e
 238       ((<ghil-toplevel-env> table)
 239        (let ((key (cons (module-name (current-module)) sym)))
 240          (or (assoc-ref table key)
 241              (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
 242                (apush! key var (ghil-toplevel-env-table e))
 243                var))))
 244       ((<ghil-env> parent table variables)
 245        (cond
 246         ((assq-ref table sym)
 247          => (lambda (var)
 248               (force-heap-allocation! var)
 249               var))
 250         (else
 251          (loop parent)))))))
 252
 253 (define (ghil-var-at-module! env modname sym interface?)
 254   (let loop ((e env))
 255     (record-case e
 256       ((<ghil-toplevel-env> table)
 257        (let ((key (list modname sym interface?)))
 258          (or (assoc-ref table key)
 259              (let ((var (make-ghil-var modname sym
 260                                        (if interface? 'public 'private))))
 261                (apush! key var (ghil-toplevel-env-table e))
 262                var))))
 263       ((<ghil-env> parent table variables)
 264        (loop parent)))))
 265
 266 (define (ghil-var-define! toplevel sym)
 267   (let ((key (cons (module-name (current-module)) sym)))
 268     (or (assoc-ref (ghil-toplevel-env-table toplevel) key)
 269         (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
 270           (apush! key var (ghil-toplevel-env-table toplevel))
 271           var))))
 272
 273 (define (call-with-ghil-environment e syms func)
 274   (let* ((e (make-ghil-env e))
 275          (vars (map (lambda (s)
 276                       (let ((v (make-ghil-var e s 'argument)))
 277                         (ghil-env-add! e v) v))
 278                     syms)))
 279     (func e vars)))
 280
 281 (define (call-with-ghil-bindings e syms func)
 282   (let* ((vars (map (lambda (s)
 283                       (let ((v (make-ghil-var e s 'local)))
 284                         (ghil-env-add! e v) v))
 285                     syms))
 286          (ret (func vars)))
 287     (for-each (lambda (v) (ghil-env-remove! e v)) vars)
 288     ret))
 289
 290 (define (ghil-env-reify env)
 291   (let loop ((e env) (out '()))
 292     (record-case e
 293       ((<ghil-toplevel-env> table)
 294        (map (lambda (v)
 295               (cons (ghil-var-name v)
 296                     (or (ghil-var-index v)
 297                         (error "reify called before indices finalized"))))
 298             out))
 299       ((<ghil-env> parent table variables)
 300        (loop parent
 301              (append out
 302                      (filter (lambda (v) (eq? (ghil-var-kind v) 'external))
 303                              variables)))))))
 304
 305 (define (ghil-env-dereify name-index-alist)
 306   (let* ((e (make-ghil-env (make-ghil-toplevel-env)))
 307          (vars (map (lambda (pair)
 308                       (make-ghil-var e (car pair) 'external (cdr pair)))
 309                     name-index-alist)))
 310     (set! (ghil-env-table e)
 311           (map (lambda (v) (cons (ghil-var-name v) v)) vars))
 312     (set! (ghil-env-variables e) vars)
 313     e))
 314
 315 \f
 316 ;;;
 317 ;;; Parser
 318 ;;;
 319
 320 (define (location x)
 321   (and (pair? x)
 322        (let ((props (source-properties x)))
 323          (and (not (null? props))
 324               (vector (assq-ref props 'line)
 325                       (assq-ref props 'column)
 326                       (assq-ref props 'filename))))))
 327
 328 (define (parse-quasiquote e x level)
 329   (cond ((not (pair? x)) x)
 330         ((memq (car x) '(unquote unquote-splicing))
 331          (let ((l (location x)))
 332            (pmatch (cdr x)
 333              ((,obj)
 334               (cond
 335                ((zero? level)
 336                 (if (eq? (car x) 'unquote)
 337                     (make-ghil-unquote e l (parse-ghil e obj))
 338                     (make-ghil-unquote-splicing e l (parse-ghil e obj))))
 339                (else
 340                 (list (car x) (parse-quasiquote e obj (1- level))))))
 341              (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
 342         ((eq? (car x) 'quasiquote)
 343          (let ((l (location x)))
 344            (pmatch (cdr x)
 345              ((,obj) (list 'quasiquote (parse-quasiquote e obj (1+ level))))
 346              (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
 347         (else (cons (parse-quasiquote e (car x) level)
 348                     (parse-quasiquote e (cdr x) level)))))
 349
 350 (define (parse-ghil env exp)
 351   (let ((loc (location exp))
 352         (retrans (lambda (x) (parse-ghil env x))))
 353     (pmatch exp
 354      ((ref ,sym) (guard (symbol? sym))
 355       (make-ghil-ref env #f (ghil-var-for-ref! env sym)))
 356
 357      (('quote ,exp) (make-ghil-quote env loc exp))
 358
 359      ((void) (make-ghil-void env loc))
 360
 361      ((lambda ,syms ,rest ,meta . ,body)
 362       (call-with-ghil-environment env syms
 363         (lambda (env vars)
 364           (make-ghil-lambda env loc vars rest meta
 365                             (parse-ghil env `(begin ,@body))))))
 366
 367      ((begin . ,body)
 368       (make-ghil-begin env loc (map retrans body)))
 369
 370      ((bind ,syms ,exprs . ,body)
 371       (let ((vals (map retrans exprs)))
 372         (call-with-ghil-bindings env syms
 373           (lambda (vars)
 374             (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
 375
 376      ((bindrec ,syms ,exprs . ,body)
 377       (call-with-ghil-bindings env syms
 378         (lambda (vars)
 379           (let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs)))
 380             (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
 381
 382      ((set ,sym ,val)
 383       (make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val)))
 384
 385      ((define ,sym ,val)
 386       (make-ghil-define env loc (ghil-var-define! env sym) (retrans val)))
 387
 388      ((if ,test ,then ,else)
 389       (make-ghil-if env loc (retrans test) (retrans then) (retrans else)))
 390
 391      ((and . ,exps)
 392       (make-ghil-and env loc (map retrans exps)))
 393
 394      ((or . ,exps)
 395       (make-ghil-or env loc (map retrans exps)))
 396
 397      ((mv-bind ,syms ,rest ,producer . ,body)
 398       (call-with-ghil-bindings env syms
 399         (lambda (vars)
 400           (make-ghil-mv-bind env loc (retrans producer) vars rest
 401                              (map retrans body)))))
 402
 403      ((call ,proc . ,args)
 404       (make-ghil-call env loc (retrans proc) (map retrans args)))
 405
 406      ((mv-call ,producer ,consumer)
 407       (make-ghil-mv-call env loc (retrans producer) (retrans consumer)))
 408
 409      ((inline ,op . ,args)
 410       (make-ghil-inline env loc op (map retrans args)))
 411
 412      ((values . ,values)
 413       (make-ghil-values env loc (map retrans values)))
 414
 415      ((values* . ,values)
 416       (make-ghil-values* env loc (map retrans values)))
 417
 418      ((compile-time-environment)
 419       (make-ghil-reified-env env loc))
 420
 421      ((quasiquote ,exp)
 422       (make-ghil-quasiquote env loc (parse-quasiquote env exp 0)))
 423
 424      (else
 425       (error "unrecognized GHIL" exp)))))
 426
 427 (define (unparse-ghil ghil)
 428   (record-case ghil
 429     ((<ghil-void> env loc)
 430      '(void))
 431     ((<ghil-quote> env loc obj)
 432      `(,'quote ,obj))
 433     ((<ghil-quasiquote> env loc exp)
 434      `(,'quasiquote ,(let lp ((x exp))
 435                        (cond ((struct? x) (unparse-ghil x))
 436                              ((pair? x) (cons (lp (car x)) (lp (cdr x))))
 437                              (else x)))))
 438     ((<ghil-unquote> env loc exp)
 439      `(,'unquote ,(unparse-ghil exp)))
 440     ((<ghil-unquote-splicing> env loc exp)
 441      `(,'unquote-splicing ,(unparse-ghil exp)))
 442   ;; Variables
 443     ((<ghil-ref> env loc var)
 444      `(ref ,(ghil-var-name var)))
 445     ((<ghil-set> env loc var val)
 446      `(set ,(ghil-var-name var) ,(unparse-ghil val)))
 447     ((<ghil-define> env loc var val)
 448      `(define ,(ghil-var-name var) ,(unparse-ghil val)))
 449   ;; Controls
 450     ((<ghil-if> env loc test then else)
 451      `(if ,(unparse-ghil test) ,(unparse-ghil then) ,(unparse-ghil else)))
 452     ((<ghil-and> env loc exps)
 453      `(and ,@(map unparse-ghil exps)))
 454     ((<ghil-or> env loc exps)
 455      `(or ,@(map unparse-ghil exps)))
 456     ((<ghil-begin> env loc exps)
 457      `(begin ,@(map unparse-ghil exps)))
 458     ((<ghil-bind> env loc vars vals body)
 459      `(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals)
 460             ,(unparse-ghil body)))
 461     ((<ghil-mv-bind> env loc producer vars rest body)
 462      `(mv-bind ,(map ghil-var-name vars) ,rest
 463                ,(unparse-ghil producer) ,(unparse-ghil body)))
 464     ((<ghil-lambda> env loc vars rest meta body)
 465      `(lambda ,(map ghil-var-name vars) ,rest ,meta
 466               ,(unparse-ghil body)))
 467     ((<ghil-call> env loc proc args)
 468      `(call ,(unparse-ghil proc) ,@(map unparse-ghil args)))
 469     ((<ghil-mv-call> env loc producer consumer)
 470      `(mv-call ,(unparse-ghil producer) ,(unparse-ghil consumer)))
 471     ((<ghil-inline> env loc inline args)
 472      `(inline ,inline ,@(map unparse-ghil args)))
 473     ((<ghil-values> env loc values)
 474      `(values ,@(map unparse-ghil values)))
 475     ((<ghil-values*> env loc values)
 476      `(values* ,@(map unparse-ghil values)))
 477     ((<ghil-reified-env> env loc)
 478      `(compile-time-environment))))