Megatest

twikiparser.scm at [5ba2bbf0ed]
Login

File stml2/modules/twiki/twikiparser.scm artifact cc34f7c51f part of check-in 5ba2bbf0ed



(require-extension sqlite3 regex posix eformat silex stack regex)

(define help "
Usage: nldb [options]


General
  -h                      : this help

Netlist data queries

  -findpath start,end     : find path from start to end. % is a wildcard

Managing netlist data

  -load /path/to/netlist  : load a model into the db
  -d dbname               : name of the .db file
  -dump fname             : dump the netlist in to verilog file

")

(include "/nfs/an/home/mrwellan/stuff/tools/lnkmkr/args.scm")
(include "verilog.l.scm")

;; process args
(define remargs (get-args (argv)
			  (list "-load"
				"-d"          "-dump" 
				"-findpath")
			  
			  (list "-h"
				)
			  arg-hash
			  0)) ;;

(define dbpaths (list "testing.db"))

(define dbpath #f)

(if (get-arg "-d")
    (set! dbpath (get-arg "-d"))
    (for-each
     (lambda (path)
       (if (file-exists? path)
	   (set! dbpath path)))
     dbpaths))

(if (and (not dbpath) (get-arg "-d"))
    (begin
      (print "Can't find db. " (get-arg "-d") " Try again or contact Matt!")
      (exit 1)))

(define dbexists (file-exists? dbpath))

(define realuser (getenv "USER"))
(define user realuser)

(define db (sqlite3:open dbpath))
(sqlite3:set-busy-timeout! db 1000000)

(define (mk-tables)
  (for-each
   (lambda (sqlstmt)
     (sqlite3:exec db sqlstmt))
   (list "CREATE TABLE modules(id INTEGER PRIMARY KEY,name_id INTEGER);"
	 "CREATE TABLE nets   (id INTEGER PRIMARY KEY,name_id INTEGER,module_id INTEGER);"
	 "CREATE TABLE insts  (id INTEGER PRIMARY KEY,name_id INTEGER,module_id INTEGER,parent_id INTEGER);"
	 "CREATE TABLE pins   (id INTEGER PRIMARY KEY,name_id INTEGER,module_id INTEGER,net_id INTEGER,type_id INTEGER);"
	 "CREATE TABLE conns  (id INTEGER PRIMARY KEY,net_id  INTEGER,inst_id INTEGER,pin_id INTEGER);"
	 "CREATE TABLE names  (id INTEGER PRIMARY KEY,name TEXT);"
	 "CREATE TABLE types(id INTEGER PRIMARY KEY,type TEXT);"
	 "INSERT INTO types VALUES(1, 'undef');"
	 "INSERT INTO types VALUES(2, 'input');"
	 "INSERT INTO types VALUES(3, 'output');"
	 "INSERT INTO types VALUES(4, 'inout');"
	 "INSERT INTO types VALUES(5, 'pwr');"
	 "PRAGMA synchronous=OFF;")))

(if (not dbexists)(mk-tables))

;;======================================================================
;; NETLIST READING
;;======================================================================

;; Use a stack to tracking state
;;
(define nldb:*stack* (make-stack))

(define (nldb:read-files fnames) ;; read in a list of files
  (for-each 
   (lambda (fname)
     (if (file-exists? fname)
	 (nldb:read-file fname)))
   fnames))

;;======================================================================
;; PRECOMPILED REGEXS
;;======================================================================

(define nldb:escaped-name     (regexp "^\\s*\\\\([^\\s]+)\\s*"))
(define nldb:trailing-garbage (regexp "^\\s*([^\\s,;]+)[,;\\s]*$"))
(define nldb:module-pin       (regexp "^\\s*([^\\s]+)\\s*([,\\s\\)]*)"))
(define nldb:pins-end         (regexp "\\)\\s*;"))
(define nldb:input-output     (regexp "\\s*(input|output)\\s+([^\\s]+)[\\s;,]"))

;;                                           modname instname( .\pinname[35] (\netname ),
(define nldb:instance         (regexp "^\\s*([^\\s]+)\\s+([^\\s]+)\\s*\\(\\s*\\.([^\\s]+)\\s*\\(\\s*([^\\s]+)\\s*\\)\\s*,"))
(define nldb:inst-conn        (regexp "^\\s*\\.([^\\s]+)\\s*\\(\\s*([^\\s])+\\s+\\)\\s*([\\),;]+)"))

;;                                                 module_name         netname (opt)
(define nldb:module-regex (regexp "^\\s*module\\s+([^\\s]+)\\s*\\(\\s*([^\\s,]+\\s*,|)$"))

;;======================================================================
;; MISC
;;======================================================================

;; apply regex and set nldb:match-val
(define nldb:match-val #f)
(define (nldb:regex-match r l)
  (let ((m (string-match r l)))
    (set! nldb:match-val m) m))

;; stmt can only return *one* value!!
(define (nldb:sqlite3:get-one stmt . params)
  (let ((sqlstmt (sqlite3:prepare db stmt))
	(result  #f))
    (apply sqlite3:for-each-row
	   (lambda (x)
	     (set! result x)) sqlstmt params)
    (sqlite3:finalize! sqlstmt)
    result))

;;======================================================================
;; CACHE
;;======================================================================

(define *cache*             (make-hash-table))
(define *module-name-cache* (make-hash-table))

(define (cache-get-module-hash module)
  (sub-hash-create-get *cache* module))

(define (sub-hash-create-get subhash key)
  (let ((shash (hash-table-get/default subhash key)))
    (if shash shash
	(let ((newh (make-hash-table)))
	  (hash-table-set! subhash key newh)
	  newh))))

;; (cache-set! "abc_adder" 'pin "addrin" 0)
(define (cache-set! module objtype objname value)
  (let* ((mhash (cache-get-module-hash module))
	 (thash (sub-hash-create-get mhash objtype)))
    (hash-table-set! thash objname value)))

(define (cache-ref module objtype objname)
  (let ((mhash (hash-table-ref/default *cache* module)))
    (if mhash
	(let ((ohash (hash-table-ref/default mhash objtype)))
	  (if ohash
	      (hash-table-ref/default ohash objname)
	      #f))
	#f)))
    
;;======================================================================
;; NAMES
;;======================================================================

(define nldb:names-hash (make-hash-table))

;; always sucessful. inserts name if not found
(define (nldb:get-name-id name)
  (let ((cached-id (hash-table-ref/default nldb:names-hash name #f)))
    (if cached-id cached-id
	(let ((id (nldb:sqlite3:get-one "SELECT id FROM names WHERE name=?;" name)))
	  (if id
	      (begin
		(hash-table-set! nldb:names-hash name id )
		id)
	      (begin
		(sqlite3:exec db "INSERT INTO names (name) VALUES (?);" name)
		(nldb:get-name-id name)))))))

(define (nldb:clean-name name)
  (if (nldb:regex-match nldb:escaped-name name) ;; process escaped identifiers
      (list-ref nldb:match-val 1)
      (if (nldb:regex-match nldb:trailing-garbage name)
	  (list-ref nldb:match-val 1)
	  name)))

;;======================================================================
;; MODULES
;;======================================================================

;; add a module and return its id.
(define (nldb:get-module-id name-id)
  (let ((id  (nldb:sqlite3:get-one 
	      "SELECT id FROM modules WHERE name_id=?;" name-id)))
    (if id id
	(begin
	  (nldb:insert-module name-id)
	  (nldb:get-module-id name-id))))) ;; now retrieve and return the id

;; not safe to use outside of get-module-id - could add duplicates
(define (nldb:insert-module name-id)
  (sqlite3:exec db "INSERT INTO modules (name_id) VALUES (?);" name-id))

;; module namespace is unique so this is ok, should check for redefining though.
(define (nldb:get-module-by-name name)
  (let ((module-id (hash-table-ref *module-name-cache* name)))
    (if module-id module-id
	(let ((mid (nldb:get-module-id (nldb:get-name-id name))))
	  (hash-table-set! *module-name-cache* name mid)))))

;;======================================================================
;; PINS
;;======================================================================

(define (nldb:get-pin-id module-id name-id)
  (nldb:sqlite3:get-one 
   (string-append "SELECT id FROM pins WHERE module_id=? AND name_id=?;") 
   module-id name-id))

(define (nldb:add-pin module-id name-id type-id)
  (let ((pin-id (nldb:get-pin-id module-id name-id)))
    (if pin-id pin-id
	(begin	
	  (nldb:insert-pin module-id name-id type-id)
	  (nldb:get-pin-id module-id name-id)))))

(define (nldb:insert-pin module-id name-id type-id)
  (sqlite3:exec db "INSERT INTO pins (module_id,name_id,type_id) VALUES (?,?,?);"
		module-id name-id (if type-id type-id 0)))

(define (nldb:set-pin-direction pin-id direction)
  (sqlite3:exec db "UPDATE pins SET type_id=(SELECT id FROM types WHERE type=?) WHERE id=?;" direction pin-id))

(define (nldb:set-pin-net pin-id net-id)
  (sqlite3:exec db "UPDATE pins SET net_id=? WHERE id=?;" net-id pin-id))

;;====================================================================
;; CONNS
;;======================================================================

(define (nldb:get-conn-id inst-id pin-id)
  ;; (if (not (and inst-id pin-id))(print "ERROR: nldb:get-conn-id called with bad params: inst-id " inst-id " pin-id " pin-id)
  (nldb:sqlite3:get-one  "SELECT id FROM conns WHERE inst_id=? AND pin_id=?;" inst-id pin-id))

(define (nldb:add-conn inst-id pin-id net-id)
  ;;  (if (not (and inst-id pin-id net-id))(print "ERROR: nldb:add-conn called with bad params: inst-id " inst-id " pin-id " pin-id " net-id " net-id)
  (let ((conn-id (nldb:get-conn-id inst-id pin-id)))
    (if conn-id conn-id
	(begin	
	  (nldb:insert-conn inst-id pin-id net-id)
	  (nldb:get-conn-id inst-id pin-id)))))

(define (nldb:insert-conn inst-id pin-id net-id)
  ;;  (if (not (and inst-id pin-id net-id))(print "ERROR: nldb:insert-conn called with bad params: inst-id " inst-id " pin-id " pin-id " net-id " net-id)
  (sqlite3:exec db "INSERT INTO conns (inst_id,pin_id,net_id) VALUES (?,?,?);"
		inst-id pin-id net-id ))

;;======================================================================
;; NET
;;======================================================================

(define (nldb:get-net-id module-id name-id)
  (nldb:sqlite3:get-one "SELECT id FROM nets WHERE name_id=?;" name-id))

(define (nldb:add-net module-id name-id)
  (let ((net-id (nldb:get-net-id module-id name-id)))
    (if net-id net-id
	(begin
	  (nldb:insert-net module-id name-id)
	  (nldb:get-net-id module-id name-id)))))

(define (nldb:insert-net module-id name-id)
  (sqlite3:exec db "INSERT INTO nets (module_id,name_id) VALUES(?,?);" module-id name-id))

;;======================================================================
;; INSTANCES
;;======================================================================

(define (nldb:get-inst-id parent-id name-id)
  (nldb:sqlite3:get-one "SELECT id FROM insts WHERE parent_id=? AND name_id=?;" parent-id name-id))

;; sub-mod-id = type of instance, parent-id = where instantiated
(define (nldb:add-inst module-id parent-id name-id)
  (let ((inst-id (nldb:get-inst-id parent-id name-id))) ;; parent and name are enough to identify it
    (if inst-id inst-id
	(begin
	  (nldb:insert-inst module-id parent-id name-id)
	  (nldb:get-inst-id parent-id name-id)))))

(define (nldb:insert-inst module-id parent-id name-id)
  (sqlite3:exec db "INSERT INTO insts (module_id,parent_id,name_id) VALUES(?,?,?);" module-id parent-id name-id))

;;======================================================================
;; RECORD FOR STATE
;;======================================================================

(define *statevec* (make-vector 5))

(define-inline (curr-pin-id)           (vector-ref  *statevec* 0))
(define-inline (curr-inst-id)          (vector-ref  *statevec* 1))
(define-inline (curr-module-id)        (vector-ref  *statevec* 2))
(define-inline (curr-inst-module-id)   (vector-ref  *statevec* 3))

(define-inline (set-curr-pin-id!         id)(vector-set! *statevec* 0 id))
(define-inline (set-curr-inst-id!        id)(vector-set! *statevec* 1 id))
(define-inline (set-curr-module-id!      id)(vector-set! *statevec* 2 id))
(define-inline (set-curr-inst-module-id! id)(vector-set! *statevec* 3 id))

;;======================================================================
;; FILE I/O
;;======================================================================

;; Initialization and support routines for nldb:read-file
(stack-push! nldb:*stack* 'start)
(define nldb:esc-regex  (regexp "^\\\\([^\\s]*)\\s*$") )
(define (nldb:clean-identifier token)
  (let* ((t   (car token))
	 (v   (cadr token))
	 (ctm (string-match nldb:esc-regex v)))
    (list 'identifier (list-ref ctm 1))))


(define (nldb:read-file fname)
  (let* ((inp (open-input-file fname))
	 (prev-state #f))
    (lexer-init 'port inp)
    (let loop ((token          (lexer)))
      (let ((token-type (car token))
	    (token-val  (cadr token))
	    (state      (stack-peek herc:*stack*)))
	(if (not (eq? prev-state state))
	    (begin
	      (print "state: " state)
	      (set! prev-state state)))
	(case token-type
	  ('end-of-input       (print "Done")(close-input-port inp))
	  ('whitespace         (loop (lexer)))  ;; skip whitespace
	  ('comment-begin      
	   (stack-push! herc:*stack* 'comment )
	   (loop (lexer)))
	  ('comment-end        (stack-pop! herc:*stack*)(loop (lexer)))
	  ('begin              (stack-push! herc:*stack* 'begin)(loop (lexer)))
	  ('end                (stack-pop! herc:*stack*)(loop (lexer)))
	  ('cell
	   (case state
	     ('begin
	       (stack-push! herc:*stack* 'cell-name)
	       (loop (lexer)))
	     (else
	      (loop (lexer)))))
	  ('plainidentifier
	   (case state
	     ('cell-name

	  ('statementend       (stack-pop! nldb:*stack*)(loop (lexer)))
	  ('endparen           (stack-pop! nldb:*stack*)(loop (lexer)))
	  ('endmodule          (stack-pop! nldb:*stack*)(loop (lexer)))

	  ('startparen 
	   (case state
	     ('module-pins     (loop (lexer)))
	     ('inst-def        (loop (lexer)))
	     ('inst-conn-def   (loop (lexer)))
	     ('pin-net         (loop (lexer)))
	     (else             (print "ERROR: Didn't expect an open paren here! Line " (lexer-get-line)))))

	  ('comma
	   (case state
	     ('module-pins     (loop (lexer)))
	     ('input-pin       (loop (lexer)))
	     ('output-pin      (loop (lexer)))
	     ('wire            (loop (lexer)))
	     ('inst-conn-def   (loop (lexer))) ;; (stack-pop! nldb:*stack*) (loop (lexer)))
	     (else             (print "ERROR: Didn't expect a comma here! Line " (lexer-get-line)))))

	  ('module 
	   (case state
	     ('start 
	      (stack-push! nldb:*stack* 'module)      ;; we will be in a module
	      (stack-push! nldb:*stack* 'module-def)) ;; starting in the def
	     (else
	      (print "ERROR: Didn't expect module declaration here! Line " (lexer-get-line))))
	   (loop (lexer)))

	  ('input 
	   (case state
	     ('module      (stack-push! nldb:*stack* 'input-pin))
	     (else         (print "ERROR: Didn't expect \"input\" statement here! Linenum " (lexer-get-line))))
	   (loop (lexer)))

	  ('output
	   (case state
	     ('module      (stack-push! nldb:*stack* 'output-pin))
	     (else         (print "ERROR: Didn't expect \"output\" statement here! Linenum " (lexer-get-line))))
	   (loop (lexer)))
	  
	  ('inout
	   (case state
	     ('module      (stack-push! nldb:*stack* 'inout-pin))
	     (else         (print "ERROR: Didn't expect \"inout\" statement here! Linenum " (lexer-get-line))))
	   (loop (lexer)))

	  ('pin 
	   (case state
	     ('inst-conn-def
	      (let* ((pin-name    (substring token-val 1 (string-length token-val)))
		     (pin-name-id (nldb:get-name-id pin-name))
		     (pin-id      (nldb:add-pin (curr-module-id) pin-name-id #f)))
		(stack-push! nldb:*stack* 'pin-net)
		(set-curr-pin-id! pin-id)
		(loop (lexer))))
	     (else  (print "ERROR: Didn't expect pin here " token-val " Linenum: " (lexer-get-line)))))

	  ('identifier
	   (case state
	     ('module  ;; this must be an instance, an identifier at the top level
	      (let* ((inst-mod-id (nldb:get-module-by-name token-val)))
		(set-curr-inst-module-id! inst-mod-id)
		(stack-push! nldb:*stack* 'inst-def))
	      (loop (lexer)))
	     ('inst-def                  ;;     inst-module type  parent-id    inst-name-id
	      (let* ((inst-id (nldb:add-inst (curr-inst-module-id)(curr-module-id)(nldb:get-name-id token-val))))
		(set-curr-inst-id! inst-id))
	      (stack-push! nldb:*stack* 'inst-conn-def)
	      (loop (lexer)))
	     ('module-def
	      (let* ((m-id (nldb:get-module-by-name token-val)))
		(set-curr-module-id! m-id))
	      (stack-push! nldb:*stack* 'module-pins))
	     ('module-pins
	      (nldb:add-pin (curr-module-id) (nldb:get-name-id token-val) #f))
	     ('input-pin
	      (let ((pin-id (nldb:get-pin-id (curr-module-id) (nldb:get-name-id token-val))))
		(nldb:set-pin-direction pin-id "input")))
	     ('output-pin
	      (let ((pin-id (nldb:get-pin-id (curr-module-id) (nldb:get-name-id token-val))))
		(nldb:set-pin-direction pin-id "output")))
	     ('inout-pin
	      (let ((pin-id (nldb:get-pin-id (curr-module-id) (nldb:get-name-id token-val))))
		(nldb:set-pin-direction pin-id "inout")))
	     ('pin-net
	      (let* ((net-name-id (nldb:get-name-id token-val))
		     (net-id      (nldb:add-net (curr-inst-module-id) net-name-id)))
		(nldb:add-conn (curr-inst-id) (curr-pin-id) net-id)))
	     (else
	      (print "ERROR: Didn't expect an identifier here! Token " token-val " Line " (lexer-get-line))))
	   (loop (lexer)))

	  (else
	   (print "ERROR: unknown token " token " on line " (lexer-get-line))
	   (loop (lexer))))))))