Changeset 30658 in project


Ignore:
Timestamp:
04/07/14 09:02:16 (7 years ago)
Author:
Ivan Raikov
Message:

picnic: reworking config imports

Location:
release/4/picnic/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/picnic/trunk/picnic-core.scm

    r30644 r30658  
    2626         picnic:math-constants
    2727         picnic-intern picnic-scoped eval-picnic-system-decls
    28          CONST ASGN INITIAL PS SEGPS SET EXTERNAL PRIM LABEL
     28         CONST CONFIG ASGN INITIAL PS SEGPS SET EXTERNAL PRIM LABEL
    2929
    3030         )
     
    175175          (SYSNAME    (name symbol?) )
    176176          (LABEL      (v symbol?) )
     177          (CONFIG     (name symbol?) )
    177178          (CONST      (name symbol?) (value number?) )
    178179          (ASGN       (name symbol?) (value number?) (rhs rhs?) )
     
    273274
    274275        (define (make-picnic-core . alst)
     276
     277          (define local-config (lookup-def 'config alst))
    275278
    276279          ;; floating point precision (single or double; default is double)
     
    518521                                     (cond  ((picnic:quantity? en) 
    519522                                             (cases picnic:quantity en
     523                                                    (CONFIG (name) 
     524                                                            (let ((value (lookup-def name local-config)))
     525                                                              (if (not value)
     526                                                                  (picnic:error 'make-const-env
     527                                                                                ": unknown configuration entry" name))
     528                                                              (hash-table-set! env name value)))
    520529                                                    (CONST (name value) 
    521530                                                           (hash-table-set! env name value))
     
    533542                 (cond  ((picnic:quantity? en) 
    534543                         (cases picnic:quantity en
     544                                (CONFIG (name) 
     545                                       (hash-table-set! env name fptype))
    535546                                (CONST (name value) 
    536547                                       (hash-table-set! env name fptype))
     
    546557            (cond  ((picnic:quantity? en) 
    547558                    (cases picnic:quantity en
     559                           (CONFIG (name)  (let ((v (lookup-def name local-config)))
     560                                             (or (and v v)
     561                                                 (picnic:error 'const-env-entry->value
     562                                                               "unknown configuration entry" name))))
    548563                           (CONST (name value)  value)
    549564                           (PRIM (name value)  value)
     
    551566                   ((procedure? en)  en)
    552567                   ((or (number? en) (symbol? en))   en)
    553                    (else #f)))
     568                   (else (picnic:error 'const-env-entry->value
     569                                       "unknown type of const env entry" en))
     570                   ))
    554571
    555572
     
    570587                      (begin
    571588                        (if (not (hash-table-exists? picnic-env sym))
    572                             (picnic:error 'add-external! ": exported quantity " sym " is not defined"))
     589                            (picnic:error 'add-external! "exported quantity " sym " is not defined"))
    573590                        (let* ((exports-sym   (picnic-intern 'exports))
    574591                               (exports       (hash-table-ref picnic-env exports-sym)))
    575592                          (cases picnic:quantity exports
    576593                                 (EXPORTS (lst) (hash-table-set! picnic-env exports-sym (EXPORTS (append lst (list sym)))))
    577                                  (else  (picnic:error 'add-external! ": invalid exports entry " exports))))))
     594                                 (else  (picnic:error 'add-external! "invalid exports entry " exports))))))
    578595                     
    579596                     (('input sym lsym ns . rest)
     
    582599                            )
    583600                        (if (hash-table-exists? picnic-env lsym)
    584                             (picnic:error 'add-import! ": import symbol " lsym " is already defined"))
     601                            (picnic:error 'add-import! "import symbol " lsym " is already defined"))
    585602                       
    586603                        ((env-extend! picnic-env) lsym '(external) 'none
     
    598615                                 (begin
    599616                                   (pp (hash-table->alist picnic-env))
    600                                    (picnic:error 'symbol-check: s " in the definition of " loc " is not defined")
     617                                   (picnic:error 'symbol-check s " in the definition of " loc " is not defined")
    601618                                   )
    602619                                 ))
     
    613630                         
    614631                          (if (not (= (length fms) (length args)))
    615                               (picnic:error 'arity-check: "procedure " s
     632                              (picnic:error 'arity-check "procedure " s
    616633                                          " called with incorrect number of arguments: "
    617634                                          args)))))
    618                   (picnic:error 'arity-check: "symbol " s "(" loc ")" " is not defined")
     635                  (picnic:error 'arity-check "symbol " s "(" loc ")" " is not defined")
    619636                  )))
    620637
     
    628645
    629646                (if (hash-table-exists? picnic-env sym)
    630                     (picnic:error 'env-extend! ": quantity " sym " already defined")
     647                    (picnic:error 'env-extend! "quantity " sym " already defined")
    631648                    (match type
    632649
     
    634651                            (begin
    635652                              (if (not (symbol? initial))
    636                                   (picnic:error 'env-extend! ": label definitions require symbolic value"))
     653                                  (picnic:error 'env-extend! "label definitions require symbolic value"))
    637654                              (hash-table-set! picnic-env sym (LABEL initial))))
    638655
     
    654671                              (hash-table-set! picnic-env sym (PRIM name val))))
    655672
     673                           (('config)   
     674                            (hash-table-set! picnic-env sym (CONFIG name)))
     675
    656676                           (('const)   
    657677                            (if (not (number? initial))
    658                                 (picnic:error 'env-extend! ": constant definitions require numeric value" name initial)
     678                                (picnic:error 'env-extend! "constant definitions require numeric value" name initial)
    659679                                (hash-table-set! picnic-env sym (CONST name initial))
    660680                                ))
     
    667687                              (if (not (eq? initial 'none))
    668688                                  (picnic:error 'env-extend!
    669                                               ": state function definitions must have initial value of '(none)"))
     689                                              "state function definitions must have initial value of '(none)"))
    670690                              (if (not rhs)
    671                                   (picnic:error 'env-extend! ": state function definitions require an equation"))
     691                                  (picnic:error 'env-extend! "state function definitions require an equation"))
    672692                              (let ((expr1 (normalize-expr rhs (sprintf "assignment ~A" sym))))
    673693                                (hash-table-set! picnic-env sym (ASGN name 0.0 expr1)))
     
    681701                              (if (not (eq? initial 'none))
    682702                                  (picnic:error 'env-extend!
    683                                               ": initial state function definitions must have initial value of '(none)"))
     703                                              "initial state function definitions must have initial value of '(none)"))
    684704                              (if (not rhs)
    685                                   (picnic:error 'env-extend! ": initial state function definitions require an equation"))
     705                                  (picnic:error 'env-extend! "initial state function definitions require an equation"))
    686706                              (let ((expr1 (normalize-expr rhs (sprintf "initial ~A" sym))))
    687707                                (hash-table-set! picnic-env sym (INITIAL name expr1)))
     
    703723                              (if (not (and (symbol? gfun)
    704724                                            (procedure? (hash-table-ref local-env gfun))))
    705                                   (picnic:error 'env-extend! ": process definitions require a generating function"))
     725                                  (picnic:error 'env-extend! "process definitions require a generating function"))
    706726
    707727                              (if (not npts)
    708                                   (picnic:error 'env-extend! ": process definitions require number of points"))
     728                                  (picnic:error 'env-extend! "process definitions require number of points"))
    709729                             
    710730                              (let ((initial-expr
     
    733753                              (if (not (and (symbol? gfun)
    734754                                            (procedure? (hash-table-ref local-env gfun))))
    735                                   (picnic:error 'env-extend! ": segmented process definitions require a generating function"))
     755                                  (picnic:error 'env-extend! "segmented process definitions require a generating function"))
    736756                             
    737757                              (if (not (and nsegs nsegpts))
    738                                   (picnic:error 'env-extend! ": segmented process definitions require number of points and number of segments"))
     758                                  (picnic:error 'env-extend! "segmented process definitions require number of points and number of segments"))
    739759                             
    740760                              (let ((initial-expr
     
    841861
    842862                                                         ((and (symbol? s) (not (member s builtin-ops)) (not (member s lb)))
    843                                                           (picnic:error 'defun ": quantity " s " not defined"))
     863                                                          (picnic:error 'defun "quantity " s " not defined"))
    844864
    845865                                                         (else (fold (enumconsts lb) ax es))
     
    853873
    854874                                                    ((and (symbol? s) (not (member s lb)))
    855                                                      (picnic:error 'defun ": quantity " s " not defined"))
     875                                                     (picnic:error 'defun "quantity " s " not defined"))
    856876
    857877                                                    (else ax)))
     
    863883
    864884                  (if (hash-table-exists? picnic-env sym)
    865                       (picnic:error 'defun! ": quantity " sym " already defined")
     885                      (picnic:error 'defun! "quantity " sym " already defined")
    866886                      (let* (
    867887                             (body    (normalize-expr body (sprintf "function ~A" sym)))
     
    10221042                                      (let ((en1 (COMPONENT name type (delete-duplicates (append lst (list sym))) scope-subst)))
    10231043                                        (hash-table-set! picnic-env comp-name en1)))
    1024                            (else (picnic:error 'component-extend! ": invalid component " comp-name)))
    1025                     (picnic:error 'component-extend! ": invalid component " comp-name)))))
     1044                           (else (picnic:error 'component-extend! "invalid component " comp-name)))
     1045                    (picnic:error 'component-extend! "invalid component " comp-name)))))
    10261046
    10271047
     
    10881108
    10891109
     1110          (define (configs picnic-env)
     1111            (filter-map (lambda (sym)
     1112                          (let ((x (hash-table-ref picnic-env sym)))
     1113                            (and (picnic:quantity? x)
     1114                                 (cases picnic:quantity x
     1115                                        (CONFIG (name)  (list name (lookup-def name local-config) ))
     1116                                        (else #f)))))
     1117                        (hash-table-keys picnic-env)))
     1118
     1119
    10901120          (define (consts picnic-env)
    10911121            (filter-map (lambda (sym)
     
    12731303                                                        (j (car (alist-ref nj name->id-map))))
    12741304                                                    (add-edge! (list i j (format "~A=>~A" ni nj))))))
    1275                                    (else (picnic:error 'make-eqng ": invalid edge " e))))
     1305                                   (else (picnic:error 'make-eqng "invalid edge " e))))
    12761306                          (fold (lambda (qsym ax)
    12771307                                  (let* ((q   (hash-table-ref picnic-env qsym))
     
    12811311                                                                 (lambda (sym)
    12821312                                                                   (if (not (hash-table-exists? picnic-env sym))
    1283                                                                        (picnic:error 'make-eqng ": undefined symbol " sym
     1313                                                                       (picnic:error 'make-eqng "undefined symbol " sym
    12841314                                                                                   " in definition of quantity " qsym))
    12851315                                                                   (and (let ((x (hash-table-ref picnic-env sym)))
     
    12871317                                                                 (lambda (sym)
    12881318                                                                   (if (not (hash-table-exists? picnic-env sym))
    1289                                                                        (picnic:error 'make-eqng ": undefined symbol " sym
     1319                                                                       (picnic:error 'make-eqng "undefined symbol " sym
    12901320                                                                                   " in definition of quantity " qsym))
    12911321                                                                   (and (let ((x (hash-table-ref picnic-env sym)))
     
    12991329                (let ((cycles (graph-cycles-fold g (lambda (cycle ax) (cons cycle ax)) (list))))
    13001330                  (if (null? cycles) (list state-list asgn-list g)
    1301                       (picnic:error 'make-eqng ": equation cycle detected: " (car cycles)))))))
     1331                      (picnic:error 'make-eqng "equation cycle detected: " (car cycles)))))))
    13021332
    13031333
     
    13461376                                                 (list 'set sym rhs))
    13471377                                           (else picnic:error 'make-eval-poset
    1348                                                  ": invalid quantity in equation poset: " sym)))))
     1378                                                 "invalid quantity in equation poset: " sym)))))
    13491379                           lst))
    13501380             eqposet))
     
    14131443                                           (hash-table-set! my-env sym v)))
    14141444                                  (else picnic:error 'eval-poset
    1415                                         ": invalid quantity in equation poset: " sym)))))
     1445                                        "invalid quantity in equation poset: " sym)))))
    14161446                  lst))
    14171447               eqposet)
     
    14571487              ((defuns)              defuns)
    14581488              ((consts)              consts)
     1489              ((configs)             configs)
    14591490              ((exports)             exports)
    14601491              ((imports)             imports)
     
    14721503              ((extended-with-tag)   extended-with-tag)
    14731504              (else
    1474                (picnic:error 'selector ": unknown message " selector " sent to an picnic-core object"))))
     1505               (picnic:error 'selector "unknown message " selector " sent to an picnic-core object"))))
    14751506
    14761507          picnic-dispatch)
     
    15621593                                          (list qs scope-subst)))
    15631594                                       
     1595                                       ;; constant read from a config file
     1596                                       (((or 'config 'CONFIG) (and id (? symbol?)) . rest)
     1597                                        (let* (
     1598                                               (qid    (compute-qid id scope scope-subst))
     1599                                               (alst   (filter identity rest))
     1600                                               )
     1601                                          (apply env-extend! (list qid '(config) #f))
     1602                                          (list (cons qid qs) (update-subst id qid scope-subst))
     1603                                          ))
     1604
     1605
    15641606                                       ;; constant during point generation
    15651607                                       (((or 'const 'CONST) (and id (? symbol?)) '= (and expr (? expr? )) . rest)
     
    17691811                                               (functor  (FUNCTOR sym args typ lst)))
    17701812                                          (if (hash-table-exists? sys sym)
    1771                                               (picnic:error 'eval-picnic-system-decls! ": functor " sym " already defined"))
     1813                                              (picnic:error 'eval-picnic-system-decls! "functor " sym " already defined"))
    17721814                                          (hash-table-set! sys sym functor)
    17731815                                          (list (cons sym qs) scope-subst)))
     
    17751817                                       (((or 'const 'CONST) . _)
    17761818                                        (picnic:error 'eval-picnic-system-decls "declaration: " decl
    1777                                                     ": constant declarations must be of the form: "
     1819                                                    "constant declarations must be of the form: "
    17781820                                                    "const id = expr"))
    17791821                                       
     
    17811823                                        (picnic:error 'eval-picnic-system-decls
    17821824                                                    "declaration " decl
    1783                                                     ": algebraic equations must be of the form: "
     1825                                                    "algebraic equations must be of the form: "
    17841826                                                    "id = expr"))
    17851827                                       
     
    17871829                                        (picnic:error 'eval-picnic-system-decls
    17881830                                                    "declaration " decl
    1789                                                     ": reaction declarations must be of the form: "
     1831                                                    "reaction declarations must be of the form: "
    17901832                                                    "reaction (id ...)"))
    17911833                                       
  • release/4/picnic/trunk/picnic.scm

    r30657 r30658  
    2424
    2525(require-extension srfi-1 picnic-core)
    26 (require-library iexpr ersatz-lib)
     26(require-library iexpr ersatz-lib picnic-utils)
    2727(require-extension datatype matchable lalr-driver getopt-long)
    2828(import (prefix iexpr iexpr: )
    2929        (prefix ersatz-lib ersatz: )
     30        (only picnic-utils load-config-file)
    3031        )
    3132
     
    116117            (transformer ,string->symbol)))
    117118
     119    (config-file "use the given hoc configuration file to obtain parameter values"
     120                 (value (required FILENAME)))
     121
    118122    (template
    119123     "instantiate the given template from the model file by setting the given variables to the respective values"
     
    156160
    157161
    158 (define (picnic-constructor name declarations parse-expr)
    159   (let* ((picnic   (make-picnic-core))
    160          (sys    ((picnic 'system) name))
    161          (qs     (eval-picnic-system-decls picnic name sys declarations parse-expr: parse-expr)))
     162(define picnic-config (make-parameter '()))
     163(if (opt 'config-file)
     164    (picnic-config (load-config-file (opt 'config-file))))
     165
     166
     167(define (picnic-constructor name config declarations parse-expr)
     168  (let* ((picnic   (make-picnic-core `(config . ,config)))
     169         (sys      ((picnic 'system) name))
     170         (qs       (eval-picnic-system-decls picnic name sys declarations parse-expr: parse-expr)))
    162171    (list sys picnic qs)))
    163172
     
    182191
    183192(define (sexp-model-decls->model options model-name model-decls parse-expr)
    184   (let* ((model+picnic  (picnic-constructor model-name model-decls parse-expr))
     193  (let* ((model+picnic  (picnic-constructor model-name (picnic-config) model-decls parse-expr))
    185194         (model (first model+picnic))
    186195         (picnic  (second model+picnic)))
     
    291300            (initials    ((dis 'initials)   sys))
    292301            (sets        ((dis 'sets)   sys))
     302            (configs     ((dis 'configs)  sys))
    293303            (imports     ((dis 'imports)  sys))
    294304            (exports     ((dis 'exports)  sys))
     
    425435
    426436       (for-each pp (map (lambda (x) `(define . ,x)) consts))
     437       (for-each pp (map (lambda (x) `(define . ,x)) configs))
    427438
    428439       (for-each pp (filter-map (lambda (x) (defun-codegen/scheme x)) defuns))
     
    459470
    460471(define picnic-write-pointsets (make-parameter #f))
     472(define picnic-write-sections (make-parameter #f))
    461473(define local-config (make-parameter '()))
    462474
     
    466478(define opt-grammar
    467479  `(
    468     (config-file "use the given hoc configuration file to obtain parameters"
    469                  (value (required FILENAME)))
    470480
    471481    (write-pointsets "write generated pointsets to files"
    472                      (single-char #\w))
     482                     (single-char #\p))
     483   
     484    (write-sections "write generated sections to files"
     485                    (single-char #\s))
    473486   
    474487    (verbose "print additional debugging information"
    475488             (single-char #\v))
    476 
     489   
    477490    (help         (single-char #\h))
    478491    ))
     
    504517    (picnic-write-pointsets #t))
    505518
    506 (if (opt 'config-file)
    507     (local-config (load-config-file (opt 'config-file))))
     519(if (opt 'write-sections)
     520    (picnic-write-sections #t))
    508521
    509522(if (picnic-verbose)
     
    625638                          (if init `(let ((,init-var ,init)) ,ax) ax)))
    626639                        x exprs))
    627       `(second
    628         (fold
    629          (match-lambda*
    630           ((,origin (gid lst))
    631            (list (+ 1 gid)
    632                  (cons (,make-section
    633                         gid ,origin (quote ,section-name)
    634                         (second
    635                          (fold (match-lambda*
    636                                 (((f n) (i lst))
    637                                  (list (+ i n)
    638                                        (list-tabulate n
    639                                                       (lambda (j) (list (+ i j) (f)))))))
    640                                (list 0 '())
    641                                (list . ,(map (match-lambda
    642                                               ((expr init init-var n)
    643                                                `(list (lambda () ,expr)
    644                                                       (inexact->exact ,n))))
    645                                              exprs)))))
    646                        lst))))
    647          (list 0 (list))
    648         ,layout-name))
     640      `(let ((result
     641              (second
     642               (fold
     643                (match-lambda*
     644                 ((,origin (gid lst))
     645                  (list (+ 1 gid)
     646                        (cons (,make-section
     647                               gid ,origin (quote ,section-name)
     648                               (second
     649                                (fold (match-lambda*
     650                                       (((f n) (i lst))
     651                                        (list (+ i n)
     652                                              (list-tabulate n
     653                                                             (lambda (j) (list (+ i j) (f)))))))
     654                                      (list 0 '())
     655                                      (list . ,(map (match-lambda
     656                                                     ((expr init init-var n)
     657                                                      `(list (lambda () ,expr)
     658                                                             (inexact->exact ,n))))
     659                                                    exprs)))))
     660                              lst))))
     661                (list 0 (list))
     662                ,layout-name))))
     663         (if (picnic-write-sections)
     664             (write-sections (quote ,section-name) result))
     665         result
     666         ))
    649667
    650668     ))
    651   )
     669 
    652670
    653671
     
    690708           (
    691709            (,layout-name
    692              ((lambda (body)
    693                (if (not (null? imports))
    694                    `(let ,(map (lambda (x)
    695                                  (let ((sym (first x))
    696                                        (ns  (third x)))
    697                                    (case ns
    698                                      ((config)
    699                                       `(,sym (alist-ref (quote ,(second x)) (local-config) )))
    700                                      (else (error 'forest-codegen "unknown import namespace" ns)))
    701                                    ))
    702                                imports)
    703                       ,body)
    704                    body))
    705               (let* ((pts (kd-tree->list
    706                            (car ,(fold-right
    707                                   (lambda (xs ax)
    708                                     (fold (match-lambda*
    709                                            (((id . sym) ax)
    710                                             (let ((rhs (qrhs (hash-table-ref sys sym))))
    711                                               `(let ((,sym ,rhs)) ,ax))))
    712                                           ax xs))
    713                                   (cdr (last (last layout)))
    714                                   layout))
    715                            ))
    716                      (layout
    717                       ,(case (forest-type forest)
    718                          ((local)
    719                           `(let recur ((pts pts) (myindex 0) (ax '()))
    720                              (if (null? pts) ax
    721                                  (let ((ax1 (if (= (modulo myindex mysize) myrank)
    722                                                 (cons (car pts) ax) ax)))
    723                                    (recur (cdr pts) (+ 1 myindex) ax1)))
    724                              ))
    725                          ((global)
    726                           'pts)))
    727                      )
    728                 (if (picnic-write-pointsets)
    729                     (write-pointset (quote ,(cn forest)) layout))
    730                 layout
    731                 )))
     710             (let* ((pts (kd-tree->list
     711                          (car ,(fold-right
     712                                 (lambda (xs ax)
     713                                   (fold (match-lambda*
     714                                          (((id . sym) ax)
     715                                           (let ((rhs (qrhs (hash-table-ref sys sym))))
     716                                             `(let ((,sym ,rhs)) ,ax))))
     717                                         ax xs))
     718                                 (cdr (last (last layout)))
     719                                 layout))
     720                          ))
     721                    (layout
     722                     ,(case (forest-type forest)
     723                        ((local)
     724                         `(let recur ((pts pts) (myindex 0) (ax '()))
     725                            (if (null? pts) ax
     726                                (let ((ax1 (if (= (modulo myindex mysize) myrank)
     727                                               (cons (car pts) ax) ax)))
     728                                  (recur (cdr pts) (+ 1 myindex) ax1)))
     729                            ))
     730                        ((global)
     731                         'pts)))
     732                    )
     733               (if (picnic-write-pointsets)
     734                   (write-pointset (quote ,(cn forest)) layout))
     735               layout
     736               ))
    732737            .
    733738            ,(map
     
    740745              sections
    741746              section-names)
     747           
    742748            )
    743749         
     
    811817                                 ((cell-forests)
    812818                                  `(,sym ,(first (resolve-forest-imports x imports))))
    813                                  ((config)
    814                                   `(,sym (alist-ref (quote ,(second x)) (local-config) )))
    815819                                 (else (error 'projection-codegen "unknown import namespace" ns)))
    816820                               ))
Note: See TracChangeset for help on using the changeset viewer.