# Copyright  :  (C) 2021-2022, QBayLogic B.V.,
#                   2022     , Google Inc.,
# License    :  BSD2 (see the file LICENSE)
# Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
#
# Script to parse output generated by Clash to use in the synthesis tool.
#
# TODO: More user documentation

package require json

namespace eval clash {
    variable metadata {}
    variable topEntity

    # Set verbosity level. Range is 0-4, where 0 means "silent". Example:
    #     set clash::verbosity 3
    variable verbosity 1

    # Dry run can be enabled by
    #     set clash::dryRun true
    variable dryRun false

    # Invoke with $topEntityDir set to the path where the manifest file of
    # your top entity is. Read all the metadata generated by Tcl: manifests
    # and Tcl interface scripts, for the top entity and its dependencies.
    proc readMetadata topEntityDir {
        variable metadata
        variable topEntity

        # If we are called multiple times, we will remove the results of
        # earlier invocations.
        set metadata [dict create]
        if {[namespace exists tclIface]} {
            namespace delete tclIface
        }

        set topEntity [ParseManifest $topEntityDir true]
        Log 1 "Top entity is $topEntity"
        return
    }

    # Issue "read_vhdl" / "read_verilog" for all HDL files generated by Clash
    proc readHdl {} {
        variable metadata
        variable topEntity

        CheckMetadataExists
        set libs [dict get $metadata $topEntity dependencies]
        lappend libs $topEntity
        foreach lib $libs {
            foreach hdlFile [dict get $metadata $lib hdlFiles] {
                if {[string match {*.vhdl} $hdlFile]} {
                    PerformAction {
                        read_vhdl -library } -var lib { } -var hdlFile
                } elseif {[string match {*.v} $hdlFile]} {
                    PerformAction {
                        read_verilog } -var hdlFile
                } elseif {[string match {*.sv} $hdlFile]} {
                    PerformAction {
                        read_verilog -sv } -var hdlFile
                } else {
                    error "Error: Unknown extension on HDL file $hdlFile"
                }
            }
        }
        return
    }

    # Issue "read_xdc" for all constraint files generated by Clash for the top
    # entity, and all constraint files managed by the Clash<->Tcl API (not just
    # for the top entity, but for all libraries).
    proc readXdc orders {
        variable metadata
        variable topEntity

        CheckMetadataExists
        foreach order $orders {
            if {$order ni {early normal late}} {
                error "Error: readXdc: Invalid order $order"
            }
        }
        unset order

        set early {}
        set normal {}
        set late {}
        foreach tclIface [GetAllTclIfaces {purposes readXdc}] {
            namespace upvar ${tclIface} order order
            lappend $order $tclIface
        }

        if {{early} in $orders} {
            foreach tclIface $early {
                ReadManagedXdc $tclIface
            }
        }
        if {{normal} in $orders} {
            ReadUnmanagedXdc
            foreach tclIface $normal {
                ReadManagedXdc $tclIface
            }
        }
        if {{late} in $orders} {
            foreach tclIface $late {
                ReadManagedXdc $tclIface
            }
        }
        return
    }

    # Invoke all Clash-generated Tcl interfaces that specify a "createIp"
    # purpose, which will call Vivado's "create_ip" with any additional
    # arguments passed to this function (hint: "createIp -dir yourdir" will
    # create the IP in the subdirectory named "yourdir"). Following that, the
    # IP is configured.
    #
    # Also see "createAndReadIp" below; call it or use its code as
    # inspiration. It is suggested to call it like "createAndReadIp -dir ip"
    # so you keep the files in a separate directory named "ip". The directory
    # will need to exist already.
    proc createIp args {
        CheckMetadataExists
        # Identical names means identical IP, only one run needed even if it
        # occurs in multiple HDL directories.
        set seen {}
        foreach tclIface [GetAllTclIfaces {purposes createIp}] {
            namespace upvar ${tclIface} ipName ipName
            if {$ipName in $seen} {
                continue
            }
            PerformAction -var tclIface {::createIp } -var ipName { } \
                    -varexpand args
            LogProc 3 {    } ${tclIface}::createIp
            lappend seen $ipName
        }
        return $seen
    }

    # Convenience method to create the IP in a temporary in-memory project and
    # then read in the results in non-project mode. Finally, targets are
    # created for the IP.
    #
    # NOTE WELL: since this switches into and out of project mode, it should
    # probably be the very first thing you call in setting up the design.
    proc createAndReadIp args {
        CheckMetadataExists
        if {![llength [GetAllTclIfaces {purposes createIp}]]} {
            return
        }
        PerformAction {
            create_project -in_memory
        }
        set ips [createIp {*}$args]
        PerformAction {
            set ipFiles [get_property IP_FILE [get_ips } -var ips {]]
            close_project
            read_ip $ipFiles
            set_property GENERATE_SYNTH_CHECKPOINT false [get_files $ipFiles]
            generate_target {synthesis simulation} [get_ips } -var ips {]
        }
        return
    }

    #---------------------------------------------------------------------------
    # Private definitions
    #---------------------------------------------------------------------------

    proc Log {level msg} {
        variable verbosity

        if {$verbosity >= $level} {
            puts "Clash \[$level\]: $msg"
        }
        return
    }

    proc LogDry {level msg} {
        variable dryRun

        if {$dryRun} {
            puts "Clash \[$level\]: \[DRY-RUN\] $msg"
        } else {
            Log $level $msg
        }
        return
    }

    # Remove leading and trailing lines with just spaces
    proc TrimLines msg {
        return [regsub {^( *\n)*(.*?)\n?( *\n?)*$} $msg {\2}]
    }

    proc GetCommonIndent msg {
        set indent -1
        foreach line [split $msg \n] {
            regexp -indices {^ *} $line blanks
            if {[lindex $blanks 1] == [string length $line] - 1} {
                # Empty line or line of all blanks; ignore
                continue
            }
            set leader [expr {[lindex $blanks 1] - [lindex $blanks 0] + 1}]
            if {$indent < 0 || $leader < $indent} {
                set indent $leader
            }
        }
        if {$indent < 0} {
            return 0
        }
        return $indent
    }

    proc LogProc {level leader procName} {
        Log $level "${leader}proc [namespace tail $procName]\
                {[info args $procName]} \{"
        set body [TrimLines [info body $procName]]
        set outdent [GetCommonIndent $body]
        foreach line [split $body \n] {
            Log $level "$leader    [string range $line $outdent end]"
        }
        Log $level $leader\}
        return
    }

    proc PerformAction args {
        variable dryRun

        set action {}
        set trace {}
        set argsLen [llength $args]
        for {set i 0} {$i < $argsLen} {incr i} {
            set fragment [lindex $args $i]
            if {$fragment ni {-var -varexpand}} {
                set action $action$fragment
                set trace $trace$fragment
                continue
            }
            incr i
            if {$i == $argsLen} {
                error "Error: $fragment requires an argument"
            }
            set varName [lindex $args $i]
            upvar $varName var
            switch $fragment {
                -var {
                    set action "$action\${$varName}"
                    set trace $trace$var
                }
                -varexpand {
                    set action "$action{*}\${$varName}"
                    set trace $trace$var
                }
            }
        }
        set trace [TrimLines $trace]
        set outdent [GetCommonIndent $trace]
        foreach line [split $trace \n] {
            LogDry 2 [string range $line $outdent end]
        }
        if {$dryRun} {
            return
        }
        catch {
            uplevel 1 $action
        } msg opts
        dict incr opts -level
        return {*}$opts $msg
    }

    proc WriteIntVar {def gname name1 _name2 _op} {
        upvar $name1 var
        if {![string is integer -strict $var]} {
            set var $def
            error "Error: $gname: Only integer values are accepted;\
                    reset to default: $def"
        }
        return
    }

    proc WriteBoolVar {def gname name1 _name2 _op} {
        upvar $name1 var
        if {![string is boolean -strict $var]} {
            set var $def
            error "Error: $gname: Only {0 1 false true no yes off on} are\
                    accepted; reset to default: $def"
        }
        return
    }

    proc TraceWrite {varName cmd args} {
        set ns [namespace current]
        set commandPrefix [linsert $args 0 ${ns}::$cmd]
        lappend commandPrefix ${ns}::$varName
        uplevel 1 [list trace remove variable $varName write $commandPrefix]
        uplevel 1 [list trace add variable $varName write $commandPrefix]
        return
    }

    proc CheckMetadataExists {} {
        variable metadata
        if {![dict size $metadata]} {
            error "Error: Please invoke clash::readMetadata first."
        }
        return
    }

    proc GetNsVar {ns varName} {
        if {![llength [uplevel 1 [list info vars ${ns}::$varName]]]} {
            error "Error: $ns doesn't provide \"$varName\"\
                    variable."
        }
        return [uplevel 1 [list set ${ns}::$varName]]
    }

    proc ParseManifest {entityDir withDeps} {
        variable metadata

        set manC [open [file join $entityDir clash-manifest.json] r]
        set manifest [json::json2dict [read $manC]]
        close $manC
        set lib [dict get $manifest top_component name]
        Log 1 "New top component: $lib"
        # Clash sometimes lists files multiple times, process them only once
        set seen {}
        set topConstraintName [file join $entityDir "${lib}.sdc"]
        dict set metadata $lib hdlFiles {}
        dict set metadata $lib constraintFiles {}
        foreach fileEntry [dict get $manifest files] {
            set name [file join $entityDir [dict get $fileEntry name]]
            if {$name in $seen} {
                continue
            }
            lappend seen $name
            if {$name eq $topConstraintName} {
                dict set metadata $lib topConstraintFile $name
            } elseif {
                   [string match {*.vhdl} $name]
                || [string match {*.v} $name]
                || [string match {*.sv} $name]
            } then {
                Log 3 "Adding HDL file: $name"
                dict with metadata $lib {
                    lappend hdlFiles $name
                }
            } elseif {
                   [string match {*.sdc} $name]
                || [string match {*.xdc} $name]
            } then {
                Log 3 "Adding constraint file: $name"
                dict with metadata $lib {
                    lappend constraintFiles $name
                }
            } elseif {[string match {*.clash.tcl} $name]} {
                Log 3 "Adding Clash<->Tcl API file: $name"
                LoadTclIface $lib $name
            }
        }
        RemoveManagedFiles $lib

        if {!$withDeps} {
            return $lib
        }

        set dependencies {}
        foreach dependency [dict get $manifest dependencies transitive] {
            set dependencyDir [file join [file dirname $entityDir] $dependency]
            lappend dependencies [ParseManifest $dependencyDir false]
        }
        dict set metadata $lib dependencies $dependencies
        return $lib
    }

    # Populate a namespace with a Clash-generated Tcl interface.
    # Namespace is clash::tclIface::${lib}::$baseName
    proc LoadTclIface {lib tclIfaceFile} {
        set fileName [file tail $tclIfaceFile]
        # Strip all extensions
        set baseName [string range $fileName 0 [string first . $fileName]-1]
        set tclIface [namespace current]::tclIface::${lib}::$baseName
        # Evaluate script code inside temporary throwaway namespace to
        # separate its code from ours and reduce the chance of accidentally
        # corrupting our code.
        namespace eval tmp {}
        set tmp::tclIfaceFile $tclIfaceFile
        set tmp::tclIface $tclIface
        namespace eval tmp {
            # -notrace is a Vivado specific option inhibiting the printing of
            # the script to stdout
            source -notrace $tclIfaceFile
        }
        if {![namespace exists $tclIface]} {
            error "Error: $tclIfaceFile did not create the requested namespace\
                    specified by the \$tclIface variable. The Tcl script does\
                    not conform to the defined Clash<->Tcl API."
        }
        namespace delete tmp
        VerifyTclIface $tclIface $tclIfaceFile true
        return
    }

    # Verify that the read interface file is strictly something we support.
    proc VerifyTclIface {tclIface tclIfaceFile isRoot} {
        set api [GetNsVar $tclIface api]
        if {$api ne {1}} {
            error "Error: $tclIface doesn't implement an API we support:\
                    api = \"$api\"."
        }
        set purpose [GetNsVar $tclIface scriptPurpose]
        Log 3 "  API level / purpose: $api/$purpose"
        if {$purpose eq {multipleScripts}} {
            if {!$isRoot} {
                error "Error: ${tclIface}::scriptPurpose = \"multipleScripts\",\
                        nested use not allowed."
            }
            if {![namespace exists ${tclIface}::multipleScripts]} {
                error "Error: ${tclIface}::multipleScripts does not exist."
            }
            set children [namespace children ${tclIface}::multipleScripts]
            if {![llength $children]} {
                error "Error: ${tclIface}::multipleScripts doesn't provide any\
                        scripts."
            }
            foreach child $children {
                if {[llength [info vars ${child}::api]]} {
                    error "Error: $child cannot specify api: it is specified by\
                            parent script."
                }
                set ${child}::api $api
                VerifyTclIface $child $tclIfaceFile false
            }

        } elseif {$purpose eq {createIp}} {
            Log 3 "    IP name: [GetNsVar $tclIface ipName]"
            # In Tcl, you can call procedures with a partial name. So an
            # invocation of "createIp" could call "createIpAlt" if
            # "createIp" did not exist. Let's be strict here to prevent
            # confusion: only accept the exact name "createIp".
            if {![llength [info procs ${tclIface}::createIp]]} {
                error "Error: $tclIface doesn't provide \"createIp\"\
                        procedure."
            }
            LogProc 4 {    } ${tclIface}::createIp

        } elseif {$purpose eq {readXdc}} {
            set order [GetNsVar $tclIface order]
            if {$order ni {early normal late}} {
                error "Error: ${tclIface}::order bogus value \"$order\"."
            }
            set usedIn [GetNsVar $tclIface usedIn]
            foreach stage $usedIn {
                if {$stage ni {synthesis implementation}} {
                    error "Error: ${tclIface}::usedIn bogus value \"$stage\"."
                }
            }
            set xdcFile [GetNsVar $tclIface xdcFile]
            # "file join" also correctly handles an absolute $xdcFile
            set resolvedFile [file join [file dirname $tclIfaceFile] $xdcFile]
            # "file isfile" also positively matches a symlink to a regular
            # file
            if {![file isfile $resolvedFile]} {
                error "Error: ${tclIface}::xdcFile = \"$xdcFile\" does not\
                        refer to an existing file."
            }
            set ${tclIface}::xdcFile $resolvedFile
            Log 3 "    Constraint file: $resolvedFile"
            Log 4 "    Order: $order"
            if {[llength [info vars ${tclIface}::scopeRef]]} {
                namespace upvar ${tclIface} scopeRef scopeRef
                Log 4 "    Scoped to ref: $scopeRef"
            }
            Log 4 "    Used in: $usedIn"

        } else {
            error "Error: ${tclIface}::scriptPurpose bogus value \"$purpose\"."
        }
        return
    }

    # Remove constraint files that are managed by a Tcl interface script from
    # the list of constraint files for the library.
    proc RemoveManagedFiles lib {
        variable metadata

        foreach tclIface [GetAllTclIfaces {libs $lib purposes readXdc}] {
            namespace upvar ${tclIface} xdcFile xdcFile
            set constraintFiles [dict get $metadata $lib constraintFiles]
            if {[lsearch -exact $constraintFiles $xdcFile] >= 0} {
                Log 3 "Marking as managed by the Clash<->Tcl API: $xdcFile"
                set filtered [lsearch -all -inline -exact -not \
                        $constraintFiles $xdcFile]
                dict set metadata $lib constraintFiles $filtered
            }
        }
        return
    }

    # Return all the Tcl interface namespaces
    #
    # They can optionally be filtered by specifying a list of libraries to
    # consider, a list of interface names to consider, or a list of script
    # purposes to consider. The sole argument of the function is a dictionary of
    # options, with the possible keys "libs", "ifaces" and "purposes".
    #
    # For example, if these two interfaces exist:
    #   - ::clash::tclIface::libA::ifaceX
    #   - ::clash::tclIface::libB::ifaceX
    #
    # Then "GetAllTclIfaces {libs libA}" would only return the first, but
    # "GetAllTclIfaces {ifaces ifaceX}" would return both since the interface
    # names both match.
    proc GetAllTclIfaces {{opts {}}} {
        if {![namespace exists tclIface]} {
            # There are no scripts
            return
        }

        if {[dict exists $opts libs]} {
            set walkLibs {}
            foreach lib [dict get $opts libs] {
                if {[namespace exists tclIface::$lib]} {
                    lappend walkLibs tclIface::$lib
                }
            }
        } else {
            set walkLibs [namespace children tclIface]
        }
        set tclIfaces {}
        set hasIfaces [dict exists $opts ifaces]
        if {$hasIfaces} {
            set ifaces [dict get $opts ifaces]
        }
        set hasPurposes [dict exists $opts purposes]
        if {$hasPurposes} {
            set purposes [dict get $opts purposes]
        }
        foreach libNs $walkLibs {
            foreach tclIface [namespace children $libNs] {
                if {$hasIfaces && [namespace tail $tclIface] ni $ifaces} {
                    continue
                }
                namespace upvar ${tclIface} scriptPurpose purpose
                if {$purpose ne {multipleScripts}} {
                    if {(!$hasPurposes) || $purpose in $purposes} {
                        lappend tclIfaces $tclIface
                    }
                    continue
                }
                set childIfaces \
                        [namespace children ${tclIface}::multipleScripts]
                foreach childIface $childIfaces {
                    namespace upvar ${childIface} scriptPurpose purpose
                    if {(!$hasPurposes) || $purpose in $purposes} {
                        lappend tclIfaces $childIface
                    }
                }
            }
        }
        return $tclIfaces
    }

    # If Clash generates constraint files without an accompanying tclIface, they
    # fall into two categories. Given $lib as the name of the top component in a
    # library, ${lib}.sdc contains the "create_clock" statements. We only read
    # that for the top entity. All other constraint files are passed to Vivado
    # as-is and should match on unique identifiers in the HDL, such that they
    # can be read for all libraries without worrying about `current_instance` or
    # similar scoping mechanisms.
    proc ReadUnmanagedXdc {} {
        variable metadata
        variable topEntity

        if {[dict exists $metadata $topEntity topConstraintFile]} {
            set topConstraintFile \
                    [dict get $metadata $topEntity topConstraintFile]
            PerformAction {
                read_xdc } -var topConstraintFile
        }
        set libs [dict get $metadata $topEntity dependencies]
        lappend libs $topEntity
        foreach lib $libs {
            set constraintFiles [dict get $metadata $lib constraintFiles]
            foreach constraintFile $constraintFiles {
                PerformAction {
                    read_xdc } -var constraintFile
            }
        }
    }

    proc ReadManagedXdc tclIface {
        namespace upvar $tclIface xdcFile xdcFile usedIn usedIn
        if {[llength [info vars ${tclIface}::scopeRef]]} {
            namespace upvar ${tclIface} scopeRef scopeRef
            set scopeRefArg [list -ref $scopeRef]
        } else {
            set scopeRefArg {}
        }
        PerformAction {
            read_xdc } -varexpand scopeRefArg { } -var xdcFile {
            set_property USED_IN } -var usedIn { [get_files } -var xdcFile {]
        }
        return
    }

    TraceWrite verbosity WriteIntVar 1
    TraceWrite dryRun WriteBoolVar false
}
