diff --git a/.github/workflows/build-and-test.yaml b/.github/workflows/build-and-test.yaml index 4bfb7e12..9c0bbecc 100644 --- a/.github/workflows/build-and-test.yaml +++ b/.github/workflows/build-and-test.yaml @@ -25,6 +25,11 @@ jobs: restore-keys: | pedantic- + - name: Install GL + run: | + sudo apt-get update + sudo apt-get install libgl-dev libglu1-mesa-dev libopengl-dev + - name: Install dependencies run: | stack update @@ -41,7 +46,7 @@ jobs: matrix: os: - ubuntu-latest - - macOS-latest + # - macOS-latest # - windows-latest steps: @@ -63,6 +68,10 @@ jobs: key: ${{ runner.os }}-${{ hashFiles('stack.yaml') }} restore-keys: | ${{ runner.os }} + - name: Install GL + run: | + sudo apt-get update + sudo apt-get install libgl-dev libglu1-mesa-dev libopengl-dev - name: Install dependencies run: | diff --git a/.github/workflows/coverage.yaml b/.github/workflows/coverage.yaml index 2f291476..c14c3546 100644 --- a/.github/workflows/coverage.yaml +++ b/.github/workflows/coverage.yaml @@ -29,6 +29,11 @@ jobs: restore-keys: | coverage- + - name: Install GL + run: | + sudo apt-get update + sudo apt-get install libgl-dev libglu1-mesa-dev libopengl-dev + - name: Build with coverage enabled run: stack build --coverage diff --git a/lamagraph-compiler/app/Main.hs b/lamagraph-compiler/app/Main.hs index 895d34dc..fe6620ef 100644 --- a/lamagraph-compiler/app/Main.hs +++ b/lamagraph-compiler/app/Main.hs @@ -1,6 +1,223 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + module Main (main) where import Relude +import Data.View +import GraphRewriting +import GraphRewriting.Lib.Lib +import GraphRewriting.Pattern.InteractionNet + +import Term qualified + +-- The signature of the graph is determined by the node type we provide. For each node constructor we define as record fields a fixed collection of ports. Here we name ports attached at the top of the nodes input ports and nodes at the bottom output ports. +data SKI + = R {out :: Port} -- Root node, which is supposed to occur exactly once in the graph and correpsonds to the root of the term + | A {inp, out1, out2 :: Port} -- An applicator. It's left-hand subgraph (out1) denotes the expression to which the expression represented by the right-hand subgraph is applied. + | I {inp :: Port} -- The identity combinator. + | E {inp :: Port} -- An eraser. This node type is used to delete the subgraph discarded by the K combinator. + | D {inp1, inp2, out :: Port} -- A duplicator is used to implement sharing in the SKI combinator calculus + | V {inp :: Port, name :: String} -- A free variable + -- Here we implement the SKI combinators in a very fine-grained manner, namely a combinator has to accumulate its arguments one-by-one before it can be applied. That is why we have two variants of the K combinator: K0 (no arguments accumulated) and K1 (saturated). + | K0 {inp :: Port} + | K1 {inp :: Port, out :: Port} + | -- The same goes for the S combinator, which takes even one more parameter. + S0 {inp :: Port} + | S1 {inp :: Port, out :: Port} + | S2 {inp :: Port, out1 :: Port, out2 :: Port} + deriving (Show, Eq) + +-- While it is very convenient to specify the nodes' ports as record fields as above it does not reveal the graph structure to the library. Therefore we have to provide some boilerplate code to expose the ports, for which we use the 'View' abstraction. In the future some Template Haskell might be included in the library to avoid this effort. +instance View [Port] SKI where + -- For each node type we simply have to return a list containing all the ports. + inspect ski = case ski of + R{out = o} -> [o] + A{inp = i, out1 = o1, out2 = o2} -> [i, o1, o2] + I{inp = i} -> [i] + E{inp = i} -> [i] + D{inp1 = i1, inp2 = i2, out = o} -> [i1, i2, o] + V{inp = i} -> [i] + K0{inp = i} -> [i] + K1{inp = i, out = o} -> [i, o] + S0{inp = i} -> [i] + S1{inp = i, out = o} -> [i, o] + S2{inp = i, out1 = o1, out2 = o2} -> [i, o1, o2] + + -- But we also need to provide means for the library to update these ports. + update ports ski = case ski of + R{} -> ski{out = o} where [o] = ports + A{} -> ski{inp = i, out1 = o1, out2 = o2} where [i, o1, o2] = ports + I{} -> ski{inp = i} where [i] = ports + E{} -> ski{inp = i} where [i] = ports + D{} -> ski{inp1 = i1, inp2 = i2, out = o} where [i1, i2, o] = ports + V{} -> ski{inp = i} where [i] = ports + K0{} -> ski{inp = i} where [i] = ports + K1{} -> ski{inp = i, out = o} where [i, o] = ports + S0{} -> ski{inp = i} where [i] = ports + S1{} -> ski{inp = i, out = o} where [i, o] = ports + S2{} -> ski{inp = i, out1 = o1, out2 = o2} where [i, o1, o2] = ports + +-- Since we want to make use of interaction net reductions (using the 'activePair' pattern) we need to specify the principal port for each node type in the form of an index into the port list above. +instance (View SKI n) => INet n where + principalPort n = case inspect n of + R{out = o} -> o + A{inp = i, out1 = o1, out2 = o2} -> o1 + I{inp = i} -> i + E{inp = i} -> i + D{inp1 = i1, inp2 = i2, out = o} -> o + V{inp = i} -> i + K0{inp = i} -> i + K1{inp = i, out = o} -> i + S0{inp = i} -> i + S1{inp = i, out = o} -> i + S2{inp = i, out1 = o1, out2 = o2} -> i + +-- In "Term" a little SKI term parser is given. The code below implements a small compiler that translates the abstract syntax tree into a graph. Here you can see how primitive graph transformation functions like 'newNode' and 'newEdge' can be used to build a graph inside the 'GraphRewriting.Graph.Rewrite' monad. Also it shows how an edge can be attached to a node's port, simply by assigning it to the corresponding record field. +fromTerm :: Term.Expr -> Graph SKI +fromTerm term = flip execGraph emptyGraph $ do + e <- compile term + newNode R{out = e} + +compile :: Term.Expr -> Rewrite SKI Edge +compile term = do + e <- newEdge + void $ case term of + Term.A f x -> do + ef <- compile f + ex <- compile x + newNode A{inp = e, out1 = ef, out2 = ex} + Term.S -> newNode S0{inp = e} + Term.K -> newNode K0{inp = e} + Term.I -> newNode I{inp = e} + Term.V v -> newNode V{inp = e, name = v} + return e + +-- The simplest of the SKI combinators is the I combinator. We match on the active pair of an I node and an applicator using the 'activePair' function which resides in the 'Pattern' monad. Note that the :-: is an infix constructor and is just an alternative representation of a pair. With the left-hand side of the rule given, we build a rule out of it that erases the matched nodes and connects the edges at the input port and the right output port of the applicator using the 'rewire' function. +ruleI :: (View [Port] n, View SKI n) => Rule n +ruleI = do + I{} :-: A{inp = iA, out2 = o2} <- activePair + rewire [[iA, o2]] + +-- The K0 node represents a K combinator that has not yet accumulated an argument, which is what this rule does. Again, we match an active pair of a K0 node and an applicator. Then we replace these nodes by a K1 node that has the right-hand subgraph of the applicator as an argument (at its output port). +ruleK0 :: (View [Port] n, View SKI n) => Rule n +ruleK0 = do + K0{} :-: A{inp = iA, out2 = o2} <- activePair + replace $ byNode K1{inp = iA, out = o2} + +-- The 'replace*' functions can be used replace the matched nodes by a combination of new nodes and rewirings, hence the constructors 'Wire' and 'Node'. +ruleK1 :: (View [Port] n, View SKI n) => Rule n +ruleK1 = do + K1{out = oK} :-: A{inp = iA, out2 = o2A} <- activePair + replace $ byWire iA oK <> byNode E{inp = o2A} + +ruleS0 :: (View [Port] n, View SKI n) => Rule n +ruleS0 = do + S0{} :-: A{inp = iA, out2 = o2A} <- activePair + replace $ byNode S1{inp = iA, out = o2A} + +ruleS1 :: (View [Port] n, View SKI n) => Rule n +ruleS1 = do + S1{out = oS} :-: A{inp = iA, out2 = o2A} <- activePair + replace $ byNode S2{inp = iA, out1 = oS, out2 = o2A} + +-- If we need new edges for the right-hand side of the rewrite rule you can use 'replaceN' with N > 0. +ruleS2 :: (View [Port] n, View SKI n) => Rule n +ruleS2 = do + S2{inp = iS, out1 = oS1, out2 = o2S} :-: a@A{out1 = o1A, out2 = o2A} <- activePair + replace $ do + (i1D, iB, i2D) <- (,,) <$> byEdge <*> byEdge <*> byEdge + byNode A{inp = iS, out1 = oS1, out2 = i1D} + byNode a{out2 = iB} + byNode D{inp1 = i1D, inp2 = i2D, out = o2A} + byNode A{inp = iB, out1 = o2S, out2 = i2D} + +-- This is an abstraction to match any active pair that involves a node with arity 0. +arity0 :: (View [Port] n, View SKI n) => Pattern n (Pair SKI) +arity0 = i <|> k <|> s + where + i = do pair@(n :-: I{}) <- activePair; return pair + k = do pair@(n :-: K0{}) <- activePair; return pair + s = do pair@(n :-: S0{}) <- activePair; return pair + +arity1 :: (View [Port] n, View SKI n) => Pattern n (Pair SKI) +arity1 = k <|> s + where + k = do pair@(n :-: K1{}) <- activePair; return pair + s = do pair@(n :-: S1{}) <- activePair; return pair + +-- If the left-hand side is to be erased completely without any rewirings or new nodes to be replaced with, use the 'erase'. +ruleE0 :: (View [Port] n, View SKI n) => Rule n +ruleE0 = do + E{inp = iE} :-: n <- arity0 + erase + +ruleE1 :: (View [Port] n, View SKI n) => Rule n +ruleE1 = do + E{} :-: n <- arity1 + replace $ byNode E{inp = out n} + +ruleE2 :: (View [Port] n, View SKI n) => Rule n +ruleE2 = do + E{inp = iE} :-: S2{inp = iS, out1 = o1, out2 = o2} <- activePair + replace $ byNode E{inp = o1} <> byNode E{inp = o2} + +ruleD0 :: (View [Port] n, View SKI n) => Rule n +ruleD0 = do + D{inp1 = iD1, inp2 = iD2, out = oD} :-: n <- arity0 + replace $ byNode n{inp = iD1} <> byNode n{inp = iD2} + +ruleD1 :: (View [Port] n, View SKI n) => Rule n +ruleD1 = do + D{inp1 = iD1, inp2 = iD2, out = oD} :-: n <- arity1 + replace $ do + (iD1', iD2') <- (,) <$> byEdge <*> byEdge + byNode n{inp = iD1, out = iD1'} + byNode n{inp = iD2, out = iD2'} + byNode D{inp1 = iD1', inp2 = iD2', out = out n} + +ruleD2 :: (View [Port] n, View SKI n) => Rule n +ruleD2 = do + D{inp1 = iD1, inp2 = iD2, out = oD} :-: S2{inp = iS, out1 = o1, out2 = o2} <- activePair + replace $ do + (l1, l2, x1, x2) <- (,,,) <$> byEdge <*> byEdge <*> byEdge <*> byEdge + byNode S2{inp = iD1, out1 = l1, out2 = x1} + byNode S2{inp = iD2, out1 = x2, out2 = l2} + byNode D{inp1 = l1, inp2 = x2, out = o1} + byNode D{inp1 = x1, inp2 = l2, out = o2} + +-- Here is the only rule that is not an interaction-net reduction, hence it does not rely on the 'activePair' pattern. First we match on an eraser node anywhere in the graph. Next we require a duplicator node that is connected to the eraser. Therefore we use the 'previous' pattern that returns a reference to the previously matched node and feed it to the 'neighbour' function that matches on nodes connected to the referenced node. +eliminate :: (View [Port] n, View SKI n) => Rule n +eliminate = do + E{inp = iE} <- node + D{out = oD, inp1 = i1, inp2 = i2} <- nodeWith iE + require (iE == i1 || iE == i2) + if iE == i1 + then rewire [[oD, i2]] + else rewire [[oD, i1]] + +ruleTreeL :: LabelledTree (Rule SKI) +ruleTreeL = + Branch + "All" + [ Leaf "Eliminate" eliminate + , Branch "Erase" [Leaf "E0" ruleE0, Leaf "E1" ruleE1, Leaf "E2" ruleE2] + , Branch "S" [Leaf "S0" ruleS0, Leaf "S1" ruleS1, Leaf "S2" ruleS2] + , Branch "K" [Leaf "K0" ruleK0, Leaf "K1" ruleK1] + , Leaf "I" ruleI + , Branch "D" [Leaf "D0" ruleD0, Leaf "D1" ruleD1, Leaf "D2" ruleD2] + ] + main :: IO () -main = pure () +main = do + let graph = fromTerm Term.skk + putStrLn $ "Starting graph is:\n" ++ show graph + resultGraph <- run 100 id pure graph ruleTreeL + putStrLn $ "Result graph is:\n" ++ show resultGraph + pure () diff --git a/lamagraph-compiler/app/Term.hs b/lamagraph-compiler/app/Term.hs new file mode 100644 index 00000000..61532833 --- /dev/null +++ b/lamagraph-compiler/app/Term.hs @@ -0,0 +1,8 @@ +module Term (Expr (..), skk) where + +import Relude + +data Expr = A Expr Expr | S | K | I | V String deriving (Ord, Eq, Show) + +skk :: Expr +skk = flip A (V "x") $ A (A S K) K diff --git a/lamagraph-compiler/lamagraph-compiler.cabal b/lamagraph-compiler/lamagraph-compiler.cabal index fa9ac00e..b6ca739e 100644 --- a/lamagraph-compiler/lamagraph-compiler.cabal +++ b/lamagraph-compiler/lamagraph-compiler.cabal @@ -95,6 +95,8 @@ library array , base >=4.7 && <5 , extra + , graph-rewriting + , graph-rewriting-lib , lens , mono-traversable , mtl @@ -107,6 +109,7 @@ library executable lamagraph-compiler-exe main-is: Main.hs other-modules: + Term Paths_lamagraph_compiler hs-source-dirs: app @@ -120,6 +123,8 @@ executable lamagraph-compiler-exe array , base >=4.7 && <5 , extra + , graph-rewriting + , graph-rewriting-lib , lamagraph-compiler , lens , mono-traversable @@ -161,6 +166,8 @@ test-suite lamagraph-compiler-test , directory , extra , filepath + , graph-rewriting + , graph-rewriting-lib , hedgehog , lamagraph-compiler , lens diff --git a/lamagraph-compiler/package.yaml b/lamagraph-compiler/package.yaml index 3cf08280..f996bfe2 100644 --- a/lamagraph-compiler/package.yaml +++ b/lamagraph-compiler/package.yaml @@ -30,6 +30,8 @@ dependencies: - mtl - mono-traversable - unliftio + - graph-rewriting + - graph-rewriting-lib language: GHC2021 diff --git a/lamagraph-core/README.md b/lamagraph-core/README.md index 5c79dc87..7740853a 100644 --- a/lamagraph-core/README.md +++ b/lamagraph-core/README.md @@ -1,3 +1,19 @@ # interaction-nets-in-fpga-core Interaction nets based processor in Clash + +## Build and synthesis + +To make Gowin project you can run: + +```bash +./gprj-processor Core.Core -m create +``` + +Then you need to [add IP-core](https://www.gowinsemi.com/upload/database_doc/3/document/5bfcfde43c45c.pdf) of UART Master in your design. + +After that all pipline is + +```bash +./gprj-processor Core.Core -m pnr --get_uart_out +``` diff --git a/lamagraph-core/bin/HexDecoder.hs b/lamagraph-core/bin/HexDecoder.hs new file mode 100644 index 00000000..cce5408f --- /dev/null +++ b/lamagraph-core/bin/HexDecoder.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -Wno-x-partial #-} + +import qualified Clash.Prelude as C +import qualified Clash.Sized.Vector as Vec +import Core.Core +import Core.Node +import Data.List.Split +import Numeric (readHex) +import Protocols.Uart.Helper +import System.Environment +import Prelude + +type ByteNodeSize = (C.BitSize (Maybe (Node PortsNumber AgentType)) C.+ 7) `C.Div` 8 + +main :: IO () +main = do + args <- getArgs + contents <- readFile $ head args + let bytes = + take (C.natToNum @(CellsNumber C.* ByteNodeSize)) $ + map (C.fromInteger . fst . head . readHex) $ + words contents :: + [Byte] + chunksSize = C.natToNum @ByteNodeSize + result = map (fromBytes . Vec.unsafeFromList) $ chunksOf chunksSize bytes :: [Maybe (Node PortsNumber AgentType)] + + writeFile (head args ++ "_clash") $ C.show result diff --git a/lamagraph-core/gprj-processor.sh b/lamagraph-core/gprj-processor.sh new file mode 100755 index 00000000..83cc2cdc --- /dev/null +++ b/lamagraph-core/gprj-processor.sh @@ -0,0 +1,82 @@ +#!/bin/bash + + +usage() { + echo "Usage: $0 [-h] [-m mode] [-get_uart_out] " + echo " -h show this help" + echo " -m choose one of the build mode: + 1) all -- crate project and run PnR + 2) pnr -- only run PnR + 3) create -- only create project + default is 'all'" + exit 1 +} + +mode="all" +getOut="false" + +OPTIONS=$(getopt -o hm:g -l help,mode:,get_uart_out -n "$0" -- "$@") +if ! OPTIONS=$(getopt -o hm:g -l help,mode:,get_uart_out -n "$0" -- "$@"); then + usage +fi + +eval set -- "$OPTIONS" + +while true; do + case "$1" in + -h|--help) + usage + ;; + -m|--mode) + case "$2" in + all|pnr|create) + mode="$2" + shift 2 + ;; + *) + echo "Wrong mode option: $2" + usage + ;; + esac + ;; + -g|--get_uart_out) + getOut="true" + shift + ;; + --) + shift + break + ;; + *) + echo "Unknown option: $1" + usage + ;; + esac +done + + +clashModule="$1" +device="$2" +gprjName="$3" + +stack run -- clash "$clashModule" --systemverilog -fclash-clear -fclash-hdldir hdl/systemverilog + + +case $mode in + all) + gw_sh hdl/make-project.tcl -name "$gprjName" -board "$device" + gw_sh hdl/run-pnr.tcl "$gprjName" + openFPGALoader "$gprjName"/impl/pnr/"$gprjName".fs + ;; + create) + gw_sh hdl/make-project.tcl -name "$gprjName" -board "$device" + ;; + pnr) + gw_sh hdl/run-pnr.tcl "$gprjName" + openFPGALoader "$gprjName"/impl/pnr/"$gprjName".fs + ;; +esac + +if [ "$getOut" = "true" ]; then + timeout 10 minicom -D /dev/ttyUSB0-H --baud 9600 -C uart_data_"$(date +%Y-%m-%d_%H:%M)" +fi diff --git a/lamagraph-core/hdl/make-project.tcl b/lamagraph-core/hdl/make-project.tcl new file mode 100644 index 00000000..bc7847b6 --- /dev/null +++ b/lamagraph-core/hdl/make-project.tcl @@ -0,0 +1,67 @@ +set board "primer25" +set project_name "INet" + +for {set i 0} {$i < $argc} {incr i} { + set arg [lindex $argv $i] + switch -exact $arg { + "-board" { + incr i + set board [lindex $argv $i] + } + "-name" { + incr i + set project_name [lindex $argv $i] + } + "-h" - + "-help" { + puts "Usage: gw_sh make-project.tcl \[-board \] \[-name \]" + puts " -board (default: primer25)" + puts " -name (default: INet)" + exit 0 + } + default { + puts "Error: unknown argument '$arg'" + exit 1 + } + } +} + +switch -exact $board { + "primer25" { + set device "GW5A-LV25MG121NES" + set device_version "A" + # set constraints_file "../lamagraph-core/hdl/primer25_pin_constraints.cst" + set constraints_file "../hdl/primer25_pin_constraints.cst" + } + "mega138" { + set device "GW5AST-LV138FPG676AES" + set device_version "B" + # set constraints_file "../lamagraph-core/hdl/mega138_pin_constraints.cst" + set constraints_file "../hdl/mega138_pin_constraints.cst" + } + default { + puts "Error: unknown board '$board'" + puts "Expected: primer25, mega138" + exit 1 + } +} + +create_project -name $project_name -pn $device -device_version $device_version -force + +set_option -output_base_name $project_name + +add_file -type cst $constraints_file + +set_option -use_cpu_as_gpio 1 +set_option -synthesis_tool gowinsynthesis +set_option -top_module topEntity +set_option -verilog_std sysv2017 + +# add_file -type verilog ../lamagraph-core/hdl/systemverilog/Core.Core.topEntity/topEntity.sv +# add_file -type verilog ../lamagraph-core/hdl/systemverilog/Core.Core.topEntity/topEntity_types.sv +# add_file -type sdc ../lamagraph-core/hdl/systemverilog/Core.Core.topEntity/topEntity.sdc +add_file -type verilog ../hdl/systemverilog/Core.Core.topEntity/topEntity.sv +add_file -type verilog ../hdl/systemverilog/Core.Core.topEntity/topEntity_types.sv +add_file -type sdc ../hdl/systemverilog/Core.Core.topEntity/topEntity.sdc + +puts "Project '$project_name' for '$board' are created" diff --git a/lamagraph-core/hdl/mega138_pin_constraints.cst b/lamagraph-core/hdl/mega138_pin_constraints.cst new file mode 100644 index 00000000..2a88d81c --- /dev/null +++ b/lamagraph-core/hdl/mega138_pin_constraints.cst @@ -0,0 +1,12 @@ +//IO_LOC "clk" E2; +//IO_PORT "clk" IO_TYPE=LVCMOS33 PULL_MODE=DOWN BANK_VCCIO=3.3; +//IO_LOC "rst" J5; +//IO_PORT "rst" PULL_MODE=NONE BANK_VCCIO=3.3; + +IO_LOC "clk" P16; +IO_PORT "clk" IO_TYPE=LVCMOS33 PULL_MODE=NONE BANK_VCCIO=3.3; +IO_LOC "rstn" G16; +IO_PORT "rstn" PULL_MODE=NONE BANK_VCCIO=3.3; + +IO_LOC "res_tx" V23; +IO_PORT "res_tx" IO_TYPE=LVCMOS33 PULL_MODE=NONE DRIVE=8 BANK_VCCIO=3.3; diff --git a/lamagraph-core/hdl/primer25_pin_constraints.cst b/lamagraph-core/hdl/primer25_pin_constraints.cst new file mode 100644 index 00000000..a44a1f8f --- /dev/null +++ b/lamagraph-core/hdl/primer25_pin_constraints.cst @@ -0,0 +1,9 @@ +IO_LOC "clk" E2; +IO_LOC "rst" H11; +//IO_LOC "sample_clk" J11; + +//IO_PORT "sample_clk" IO_TYPE=LVCMOS33 PULL_MODE=NONE DRIVE=8 BANK_VCCIO=3.3; +IO_PORT "clk" IO_TYPE=LVCMOS33 PULL_MODE=DOWN BANK_VCCIO=3.3; +IO_PORT "rst" IO_TYPE=LVCMOS33 PULL_MODE=DOWN BANK_VCCIO=3.3; + + diff --git a/lamagraph-core/hdl/run-pnr.tcl b/lamagraph-core/hdl/run-pnr.tcl new file mode 100644 index 00000000..e987ccfa --- /dev/null +++ b/lamagraph-core/hdl/run-pnr.tcl @@ -0,0 +1,10 @@ +if {$argc == 1} { + set project_name [lindex $argv 0] +} +if {$argc < 1} { + set project_name "INet" +} + +open_project ${project_name}/${project_name}.gprj + +run all diff --git a/lamagraph-core/hie.yaml b/lamagraph-core/hie.yaml deleted file mode 100644 index f62bc4db..00000000 --- a/lamagraph-core/hie.yaml +++ /dev/null @@ -1,12 +0,0 @@ -cradle: - cabal: - - path: "./src" - component: "lib:lamagraph-core" - - path: "./tests/doctests.hs" - component: "lamagraph-core:doctests" - - path: "./tests" - component: "lamagraph-core:test-library" - - path: "./bin/Clashi.hs" - component: "lamagraph-core:exe:clashi" - - path: "./bin/Clash.hs" - component: "lamagraph-core:exe:clash" diff --git a/lamagraph-core/lamagraph-core.cabal b/lamagraph-core/lamagraph-core.cabal index c2c5425b..91ce8bd3 100644 --- a/lamagraph-core/lamagraph-core.cabal +++ b/lamagraph-core/lamagraph-core.cabal @@ -1,152 +1,464 @@ -cabal-version: 2.4 -name: lamagraph-core -version: 0.1 -license: BSD-2-Clause -author: John Smith -maintainer: John Smith -extra-doc-files: docs/*.svg +cabal-version: 1.18 -common common-options - default-extensions: - BangPatterns - BinaryLiterals - ConstraintKinds - DataKinds - DefaultSignatures - DeriveAnyClass - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - FlexibleContexts - InstanceSigs - KindSignatures - LambdaCase - NamedFieldPuns - NoStarIsType - PolyKinds - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeOperators - ViewPatterns - - -- TemplateHaskell is used to support convenience functions such as - -- 'listToVecTH' and 'bLit'. - TemplateHaskell - QuasiQuotes - - -- Prelude isn't imported by default as Clash offers Clash.Prelude - NoImplicitPrelude - ghc-options: - -Wall -Wcompat - -haddock - - -- Plugins to support type-level constraint solving on naturals - -fplugin GHC.TypeLits.Extra.Solver - -fplugin GHC.TypeLits.Normalise - -fplugin GHC.TypeLits.KnownNat.Solver - - -- Clash needs access to the source code in compiled modules - -fexpose-all-unfoldings - - -- Worker wrappers introduce unstable names for functions that might have - -- blackboxes attached for them. You can disable this, but be sure to add - -- a no-specialize pragma to every function with a blackbox. - -fno-worker-wrapper - - -- Strict annotations - while sometimes preventing space leaks - trigger - -- optimizations Clash can't deal with. See: - -- - -- https://github.com/clash-lang/clash-compiler/issues/2361 - -- - -- These flags disables these optimizations. Note that the fields will - -- remain strict. - -fno-unbox-small-strict-fields - -fno-unbox-strict-fields - build-depends: - base, - Cabal, +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack - -- clash-prelude will set suitable version bounds for the plugins - clash-prelude >= 1.8.1 && < 1.10, - lens, - ghc-typelits-natnormalise, - ghc-typelits-extra, - ghc-typelits-knownnat, - template-haskell, - mtl +name: lamagraph-core +version: 0.1 +author: Efim Kubyshkin +maintainer: Efim Kubyshkin +copyright: 2024 Lamagraph +license: MIT +build-type: Simple +extra-doc-files: + docs/absApplyEmptyInterface.svg + docs/absApplyNonEmpty.svg + docs/absApplyRecInterface.svg + docs/apply.svg + docs/apply_to_lambda_rule.svg + docs/eps_apply_rule.svg + docs/eraseEraseEmptyInterface.svg + docs/idToIdReduceRes.svg + docs/reduceLoopEdge.svg library - import: common-options - hs-source-dirs: src exposed-modules: - Core.Loader - Core.Node - Core.Reducer - Core.MemoryManager.MemoryManager - Core.MemoryManager.ChangesAccumulator - Core.MemoryManager.NodeChanges - Core.Map - Core.Concrete.ReduceRulesLambda - Core.Concrete.Initial - INet.Net - Core.Concrete.TypesTH - Core.CPU - Core.Core + Core.Loader + Core.Node + Core.Reducer + Core.MemoryManager.MemoryManager + Core.MemoryManager.ChangesAccumulator + Core.MemoryManager.NodeChanges + Core.Map + Core.Concrete.ReduceRulesLambda + Core.Concrete.Initial + INet.Net + Core.Concrete.TypesTH + Core.CPU + Core.Core + GraphRewriting.Translator + GraphRewriting.SKI + Protocols.Uart.GowinMaster + Protocols.Uart.Helper + other-modules: + Paths_lamagraph_core + hs-source-dirs: + src + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + InstanceSigs + KindSignatures + LambdaCase + NamedFieldPuns + NoStarIsType + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + TemplateHaskell + QuasiQuotes + NoImplicitPrelude + ghc-options: -Wall -Wcompat -haddock -fplugin=GHC.TypeLits.Extra.Solver -fplugin=GHC.TypeLits.Normalise -fplugin=GHC.TypeLits.KnownNat.Solver -fexpose-all-unfoldings -fno-worker-wrapper -fno-unbox-small-strict-fields -fno-unbox-strict-fields -fconstraint-solver-iterations=20 + build-depends: + Cabal + , base + , clash-prelude >=1.8.1 && <1.10 + , containers + , filepath + , ghc-typelits-extra + , ghc-typelits-knownnat + , ghc-typelits-natnormalise + , graph-rewriting + , graph-rewriting-lib + , graph-rewriting-ski + , lens + , mtl + , split + , string-interpolate + , template-haskell default-language: Haskell2010 --- Builds the executable 'clash', with lamagraph-core project in scope executable clash main-is: bin/Clash.hs + other-modules: + Paths_lamagraph_core + hs-source-dirs: + ./ + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + InstanceSigs + KindSignatures + LambdaCase + NamedFieldPuns + NoStarIsType + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + TemplateHaskell + QuasiQuotes + NoImplicitPrelude + ghc-options: -Wall -Wcompat -haddock -fplugin=GHC.TypeLits.Extra.Solver -fplugin=GHC.TypeLits.Normalise -fplugin=GHC.TypeLits.KnownNat.Solver -fexpose-all-unfoldings -fno-worker-wrapper -fno-unbox-small-strict-fields -fno-unbox-strict-fields -fconstraint-solver-iterations=20 + build-depends: + Cabal + , base + , clash-ghc + , clash-prelude >=1.8.1 && <1.10 + , containers + , filepath + , ghc-typelits-extra + , ghc-typelits-knownnat + , ghc-typelits-natnormalise + , graph-rewriting + , graph-rewriting-lib + , graph-rewriting-ski + , lamagraph-core + , lens + , mtl + , split + , string-interpolate + , template-haskell default-language: Haskell2010 - Build-Depends: base, clash-ghc, lamagraph-core - if !os(Windows) - ghc-options: -dynamic --- Builds the executable 'clashi', with lamagraph-core project in scope executable clashi main-is: bin/Clashi.hs + other-modules: + Paths_lamagraph_core + hs-source-dirs: + ./ + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + InstanceSigs + KindSignatures + LambdaCase + NamedFieldPuns + NoStarIsType + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + TemplateHaskell + QuasiQuotes + NoImplicitPrelude + ghc-options: -Wall -Wcompat -haddock -fplugin=GHC.TypeLits.Extra.Solver -fplugin=GHC.TypeLits.Normalise -fplugin=GHC.TypeLits.KnownNat.Solver -fexpose-all-unfoldings -fno-worker-wrapper -fno-unbox-small-strict-fields -fno-unbox-strict-fields -fconstraint-solver-iterations=20 + build-depends: + Cabal + , base + , clash-ghc + , clash-prelude >=1.8.1 && <1.10 + , containers + , filepath + , ghc-typelits-extra + , ghc-typelits-knownnat + , ghc-typelits-natnormalise + , graph-rewriting + , graph-rewriting-lib + , graph-rewriting-ski + , lamagraph-core + , lens + , mtl + , split + , string-interpolate + , template-haskell default-language: Haskell2010 - if !os(Windows) - ghc-options: -dynamic - build-depends: base, clash-ghc, lamagraph-core -test-suite doctests - type: exitcode-stdio-1.0 +executable parseFile + main-is: bin/HexDecoder.hs + other-modules: + Paths_lamagraph_core + hs-source-dirs: + ./ + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + InstanceSigs + KindSignatures + LambdaCase + NamedFieldPuns + NoStarIsType + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + TemplateHaskell + QuasiQuotes + NoImplicitPrelude + ghc-options: -Wall -Wcompat -haddock -fplugin=GHC.TypeLits.Extra.Solver -fplugin=GHC.TypeLits.Normalise -fplugin=GHC.TypeLits.KnownNat.Solver -fexpose-all-unfoldings -fno-worker-wrapper -fno-unbox-small-strict-fields -fno-unbox-strict-fields -fconstraint-solver-iterations=20 + build-depends: + Cabal + , base + , clash-ghc + , clash-prelude >=1.8.1 && <1.10 + , containers + , filepath + , ghc-typelits-extra + , ghc-typelits-knownnat + , ghc-typelits-natnormalise + , graph-rewriting + , graph-rewriting-lib + , graph-rewriting-ski + , lamagraph-core + , lens + , mtl + , split + , string-interpolate + , template-haskell default-language: Haskell2010 - main-is: doctests.hs - ghc-options: -Wall -Wcompat -threaded - hs-source-dirs: tests + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + other-modules: + Tests.Core.Unit.CPU + Tests.Core.Unit.Loader + Tests.Core.Unit.MemoryManager.MemoryManager + Tests.Core.Unit.Reducer + Tests.GraphRewriting.SKI + Tests.GraphRewriting.SKIExpectedNets + Paths_lamagraph_core + hs-source-dirs: + tests + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + InstanceSigs + KindSignatures + LambdaCase + NamedFieldPuns + NoStarIsType + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + TemplateHaskell + QuasiQuotes + NoImplicitPrelude + ghc-options: -Wall -Wcompat -haddock -fplugin=GHC.TypeLits.Extra.Solver -fplugin=GHC.TypeLits.Normalise -fplugin=GHC.TypeLits.KnownNat.Solver -fexpose-all-unfoldings -fno-worker-wrapper -fno-unbox-small-strict-fields -fno-unbox-strict-fields -fconstraint-solver-iterations=20 -Wall -Wcompat -threaded build-depends: - base, - lamagraph-core, - doctest-parallel >= 0.2 && < 0.4, + Cabal + , QuickCheck + , base + , clash-prelude >=1.8.1 && <1.10 + , clash-prelude-hedgehog + , containers + , doctest-parallel >=0.2 && <0.4 + , filepath + , ghc-typelits-extra + , ghc-typelits-knownnat + , ghc-typelits-natnormalise + , graph-rewriting + , graph-rewriting-lib + , graph-rewriting-ski + , hedgehog + , lamagraph-core + , lens + , mtl + , split + , string-interpolate + , tasty + , tasty-hedgehog + , tasty-hunit + , tasty-th + , template-haskell + , text + default-language: Haskell2010 test-suite test-library - import: common-options - default-language: Haskell2010 - hs-source-dirs: tests type: exitcode-stdio-1.0 - ghc-options: -threaded main-is: unittests.hs other-modules: - Tests.Core.Node - NodeGenerate + Tests.GraphRewriting.SKIExpectedNets + Tests.Core.Unit.CPU + Tests.Core.Unit.Loader + Tests.Core.Unit.MemoryManager.MemoryManager + Tests.Core.Unit.Reducer + Tests.GraphRewriting.SKI + hs-source-dirs: + tests + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + InstanceSigs + KindSignatures + LambdaCase + NamedFieldPuns + NoStarIsType + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + TemplateHaskell + QuasiQuotes + NoImplicitPrelude + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + InstanceSigs + KindSignatures + LambdaCase + NamedFieldPuns + NoStarIsType + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + TemplateHaskell + QuasiQuotes + NoImplicitPrelude + ghc-options: -Wall -Wcompat -haddock -fplugin=GHC.TypeLits.Extra.Solver -fplugin=GHC.TypeLits.Normalise -fplugin=GHC.TypeLits.KnownNat.Solver -fexpose-all-unfoldings -fno-worker-wrapper -fno-unbox-small-strict-fields -fno-unbox-strict-fields -fconstraint-solver-iterations=20 -Wall -Wcompat -threaded -haddock -fplugin=GHC.TypeLits.Extra.Solver -fplugin=GHC.TypeLits.Normalise -fplugin=GHC.TypeLits.KnownNat.Solver -fexpose-all-unfoldings -fno-worker-wrapper -fno-unbox-small-strict-fields -fno-unbox-strict-fields build-depends: - lamagraph-core, - QuickCheck, - clash-prelude-hedgehog, - hedgehog, - tasty >= 1.2 && < 1.6, - tasty-hedgehog, - tasty-th, - tasty-hunit, - text + Cabal + , QuickCheck + , base + , clash-prelude >=1.8.1 && <1.10 + , clash-prelude-hedgehog + , containers + , filepath + , ghc-typelits-extra + , ghc-typelits-knownnat + , ghc-typelits-natnormalise + , graph-rewriting + , graph-rewriting-lib + , graph-rewriting-ski + , hedgehog + , lamagraph-core + , lens + , mtl + , split + , string-interpolate + , tasty + , tasty-hedgehog + , tasty-hunit + , tasty-th + , template-haskell + , text + default-language: Haskell2010 diff --git a/lamagraph-core/package.yaml b/lamagraph-core/package.yaml new file mode 100644 index 00000000..3e2869bf --- /dev/null +++ b/lamagraph-core/package.yaml @@ -0,0 +1,211 @@ +name: lamagraph-core +version: "0.1" +license: MIT +author: "Efim Kubyshkin " +maintainer: "Efim Kubyshkin " +copyright: "2024 Lamagraph" +extra-doc-files: + - "docs/*.svg" + +dependencies: + - base + - Cabal + - clash-prelude >= 1.8.1 && < 1.10 + - lens + - ghc-typelits-natnormalise + - ghc-typelits-extra + - ghc-typelits-knownnat + - template-haskell + - mtl + - graph-rewriting + - graph-rewriting-lib + - containers + - graph-rewriting + - graph-rewriting-ski + - filepath + - string-interpolate + - split + +default-extensions: + - BangPatterns + - BinaryLiterals + - ConstraintKinds + - DataKinds + - DefaultSignatures + - DeriveAnyClass + - DeriveDataTypeable + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - DerivingStrategies + - FlexibleContexts + - InstanceSigs + - KindSignatures + - LambdaCase + - NamedFieldPuns + - NoStarIsType + - PolyKinds + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - TypeFamilies + - TypeOperators + - ViewPatterns + - TemplateHaskell + - QuasiQuotes + - NoImplicitPrelude + +ghc-options: + - -Wall + - -Wcompat + - -haddock + - -fplugin=GHC.TypeLits.Extra.Solver + - -fplugin=GHC.TypeLits.Normalise + - -fplugin=GHC.TypeLits.KnownNat.Solver + - -fexpose-all-unfoldings + - -fno-worker-wrapper + - -fno-unbox-small-strict-fields + - -fno-unbox-strict-fields + - -fconstraint-solver-iterations=20 + +library: + source-dirs: src + exposed-modules: + - Core.Loader + - Core.Node + - Core.Reducer + - Core.MemoryManager.MemoryManager + - Core.MemoryManager.ChangesAccumulator + - Core.MemoryManager.NodeChanges + - Core.Map + - Core.Concrete.ReduceRulesLambda + - Core.Concrete.Initial + - INet.Net + - Core.Concrete.TypesTH + - Core.CPU + - Core.Core + - GraphRewriting.Translator + - GraphRewriting.SKI + - Protocols.Uart.GowinMaster + - Protocols.Uart.Helper + +executables: + clash: + main: bin/Clash.hs + source-dirs: . + dependencies: + - base + - clash-ghc + - lamagraph-core + # ghc-options: -dynamic + + clashi: + main: bin/Clashi.hs + source-dirs: . + dependencies: + - base + - clash-ghc + - lamagraph-core + # ghc-options: -dynamic + + parseFile: + main: bin/HexDecoder.hs + source-dirs: . + dependencies: + - base + - clash-ghc + - lamagraph-core + - split + # ghc-options: -dynamic + +tests: + doctests: + main: doctests.hs + source-dirs: tests + dependencies: + - base + - lamagraph-core + - doctest-parallel >= 0.2 && < 0.4 + - QuickCheck + - clash-prelude-hedgehog + - hedgehog + - tasty + - tasty-hedgehog + - tasty-th + - tasty-hunit + - text + ghc-options: + - -Wall + - -Wcompat + - -threaded + + test-library: + main: unittests.hs + source-dirs: tests + dependencies: + - lamagraph-core + - QuickCheck + - clash-prelude-hedgehog + - hedgehog + - tasty + - tasty-hedgehog + - tasty-th + - tasty-hunit + - text + ghc-options: + - -Wall + - -Wcompat + - -threaded + - -haddock + - -fplugin=GHC.TypeLits.Extra.Solver + - -fplugin=GHC.TypeLits.Normalise + - -fplugin=GHC.TypeLits.KnownNat.Solver + - -fexpose-all-unfoldings + - -fno-worker-wrapper + - -fno-unbox-small-strict-fields + - -fno-unbox-strict-fields + default-extensions: + - BangPatterns + - BinaryLiterals + - ConstraintKinds + - DataKinds + - DefaultSignatures + - DeriveAnyClass + - DeriveDataTypeable + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - DerivingStrategies + - FlexibleContexts + - InstanceSigs + - KindSignatures + - LambdaCase + - NamedFieldPuns + - NoStarIsType + - PolyKinds + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - TypeFamilies + - TypeOperators + - ViewPatterns + - TemplateHaskell + - QuasiQuotes + - NoImplicitPrelude + other-modules: + - Tests.GraphRewriting.SKIExpectedNets + - Tests.Core.Unit.CPU + - Tests.Core.Unit.Loader + - Tests.Core.Unit.MemoryManager.MemoryManager + - Tests.Core.Unit.Reducer + - Tests.GraphRewriting.SKI diff --git a/lamagraph-core/src/Core/CPU.hs b/lamagraph-core/src/Core/CPU.hs index 884a9624..901095c6 100644 --- a/lamagraph-core/src/Core/CPU.hs +++ b/lamagraph-core/src/Core/CPU.hs @@ -27,12 +27,10 @@ newtype CPUIn portsNumber agentType = CPUIn (Maybe (LoadedNode portsNumber agent data CPUOut portsNumber agentType = CPUOut { _ramForm :: Maybe (RamForm portsNumber agentType) , _nextRootNodeAddress :: AddressNumber + , _done :: Bool } deriving (Generic, ShowX, Eq, Show, NFDataX) -defaultOut :: AddressNumber -> CPUOut portsNumber agentType -defaultOut root = CPUOut{_ramForm = def, _nextRootNodeAddress = root} - data Phase (externalNodesNumber :: Nat) (newNodesNumber :: Nat) = Init | FetchLeftActiveAddress @@ -45,7 +43,7 @@ data Phase (externalNodesNumber :: Nat) (newNodesNumber :: Nat) | DelayReduce | DelayFetch | DelayWrite (Index externalNodesNumber) - deriving (Generic, NFDataX, Show) + deriving (Generic, NFDataX, Show, Eq) data CPUState portsNumber nodesNumber edgesNumber agentType = CPUState { _phase :: Phase ((*) 2 portsNumber) nodesNumber @@ -104,21 +102,22 @@ step i@(CPUIn processedLoadedNode) = case _phase of Init -> do put s{_phase = FetchLeftActiveAddress} - pure $ defaultOut _rootNodeAddress + pure $ CPUOut{_ramForm = def, _nextRootNodeAddress = _rootNodeAddress, _done = False} FetchLeftActiveAddress -> if isJust ramForm then do put s{_phase = DelayFetch, _previousRamForm = ramForm} - pure CPUOut{_ramForm = ramForm, _nextRootNodeAddress = _rootNodeAddress} + pure CPUOut{_ramForm = ramForm, _nextRootNodeAddress = _rootNodeAddress, _done = False} else do put s{_phase = Done} - pure $ defaultOut _rootNodeAddress + pure $ + CPUOut{_ramForm = def, _nextRootNodeAddress = _rootNodeAddress, _done = True} where activeAddress = giveActiveAddressNumber _memoryManager ramForm = (\address -> (address, Just (address, Nothing))) <$> activeAddress FetchRightActiveAddress -> do put s{_phase = DelayReduce, _previousLoadedNode = processedLoadedNode, _previousRamForm = ramForm} - pure CPUOut{_ramForm = ramForm, _nextRootNodeAddress = _rootNodeAddress} + pure CPUOut{_ramForm = ramForm, _nextRootNodeAddress = _rootNodeAddress, _done = False} where activeAddress = (view nodeAddress . (fromMaybe (errorX "Wrong definition of active pair") <$> view primaryPort)) @@ -137,7 +136,7 @@ step i@(CPUIn processedLoadedNode) = , _rootNodeAddress = newRootAddress } ) - pure CPUOut{_ramForm = def, _nextRootNodeAddress = newRootAddress} + pure CPUOut{_ramForm = def, _nextRootNodeAddress = newRootAddress, _done = True} where acPair = fromMaybe (errorX $ "cpu: 1. i = \n" P.++ show i) (ActivePair <$> _previousLoadedNode <*> processedLoadedNode) removedActivePairMemoryManager = removeActivePair acPair _memoryManager @@ -155,6 +154,7 @@ step i@(CPUIn processedLoadedNode) = | _ramForm == def && counter == (maxBound :: Index ((*) 2 portsNumber)) || _interface == def = WriteNewNodes 0 | _ramForm == def = ReadExternal $ counter + 1 | otherwise = DelayWrite counter + _done = nextPhase == Done WriteChange counter -> do put s{_phase = nextPhase, _previousRamForm = _ramForm} pure CPUOut{..} @@ -169,6 +169,7 @@ step i@(CPUIn processedLoadedNode) = if counter == (maxBound :: Index ((*) 2 portsNumber)) then WriteNewNodes 0 else ReadExternal $ counter + 1 + _done = nextPhase == Done WriteNewNodes counter -> do put s{_phase = nextPhase, _previousRamForm = _ramForm} pure CPUOut{..} @@ -178,16 +179,17 @@ step i@(CPUIn processedLoadedNode) = nextPhase | counter == (maxBound :: Index nodesNumber) || (_nodesToWrite == def) = FetchLeftActiveAddress | otherwise = WriteNewNodes $ counter + 1 - Done -> pure $ defaultOut _rootNodeAddress + _done = nextPhase == Done + Done -> pure $ CPUOut{_ramForm = def, _nextRootNodeAddress = _rootNodeAddress, _done = True} DelayFetch -> do put s{_phase = FetchRightActiveAddress} - pure CPUOut{_ramForm = _previousRamForm, _nextRootNodeAddress = _rootNodeAddress} + pure CPUOut{_ramForm = _previousRamForm, _nextRootNodeAddress = _rootNodeAddress, _done = False} DelayReduce -> do put s{_phase = Reduce} - pure CPUOut{_ramForm = _previousRamForm, _nextRootNodeAddress = _rootNodeAddress} + pure CPUOut{_ramForm = _previousRamForm, _nextRootNodeAddress = _rootNodeAddress, _done = False} DelayWrite counter -> do put s{_phase = WriteChange counter} - pure CPUOut{_ramForm = _previousRamForm, _nextRootNodeAddress = _rootNodeAddress} + pure CPUOut{_ramForm = _previousRamForm, _nextRootNodeAddress = _rootNodeAddress, _done = False} mealyCore :: forall portsNumber nodesNumber edgesNumber agentType dom. diff --git a/lamagraph-core/src/Core/Concrete/ReduceRulesLambda.hs b/lamagraph-core/src/Core/Concrete/ReduceRulesLambda.hs index 03b13d0e..7a264e6a 100644 --- a/lamagraph-core/src/Core/Concrete/ReduceRulesLambda.hs +++ b/lamagraph-core/src/Core/Concrete/ReduceRulesLambda.hs @@ -21,7 +21,7 @@ data AgentSimpleLambda = Apply | Abstract | Erase - deriving (NFDataX, Generic, Show, Eq, ShowX) + deriving (NFDataX, Generic, Show, Eq, ShowX, BitPack) {- | Reduce rule for `Apply` and `Abs` diff --git a/lamagraph-core/src/Core/Core.hs b/lamagraph-core/src/Core/Core.hs index 796a8b73..ef0b1c4d 100644 --- a/lamagraph-core/src/Core/Core.hs +++ b/lamagraph-core/src/Core/Core.hs @@ -1,4 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Core.Core where @@ -11,8 +13,9 @@ import Core.Loader import Core.MemoryManager.MemoryManager import Core.Node import INet.Net +import Protocols.Uart.GowinMaster -logicBroad :: +logicBoard :: forall portsNumber nodesNumber edgesNumber agentType dom. ( KnownNat portsNumber , KnownNat nodesNumber @@ -24,12 +27,15 @@ logicBroad :: , NFDataX agentType , Show agentType , Eq agentType + , BitPack (Node portsNumber agentType) + , BitPack agentType + , 1 <= portsNumber ) => Vec CellsNumber (Maybe (Node portsNumber agentType)) -> AddressNumber -> MemoryManager -> - Signal dom AddressNumber -logicBroad initialNet initialRootNodeAddress initialMemoryManager = _nextRootNodeAddress <$> o + (Signal dom AddressNumber, Signal dom Bit) +logicBoard initialNet initialRootNodeAddress initialMemoryManager = (_nextRootNodeAddress <$> o, tx) where ram = exposeEnable (blockRam initialNet) initialCPUIn = CPUIn def @@ -38,23 +44,41 @@ logicBroad initialNet initialRootNodeAddress initialMemoryManager = _nextRootNod o = mealyCore @portsNumber @nodesNumber @edgesNumber @agentType initialMemoryManager initialRootNodeAddress i - nextLoadedNode = delayedMaybeRam ram (_ramForm <$> o) + rf = mux (_done <$> o) (exposeEnable ((_done <$> o) `andEnable` iterateOverRamForm) byteTransmitted) (_ramForm <$> o) + nextLoadedNode = delayedMaybeRam ram rf -- (delayedMaybeRam ram (_ramForm <$> o)) nextInput = CPUIn <$> (makeLoadedNodeFromRamForm <$> nextLoadedNode <*> (_ramForm <$> o)) + (tx, byteTransmitted) = transmitNodeByUart nextLoadedNode + makeLoadedNodeFromRamForm n ramForm = LoadedNode <$> n <*> (fst <$> ramForm) +createDomain vSystem{vName = "CustomDom", vPeriod = hzToPeriod 15e6, vResetPolarity = ActiveLow} + +type PortsNumber = 2 +type NodesNumber = 2 +type EdgesNumber = 2 +type AgentType = AgentSimpleLambda +type Dom = CustomDom + topEntity :: - "clk" ::: Clock System -> - "rst" ::: Reset System -> - "en" ::: Enable System -> - "rootNodeAddress" ::: Signal System AddressNumber -topEntity = - exposeClockResetEnable - ( (logicBroad @2 @2 @2 @AgentSimpleLambda) - initialIdApplyToIdNode - 0 - initialIdApplyToIdMM - ) + "clk" ::: Clock Dom -> + "rstn" ::: Reset Dom -> + -- "en" ::: Enable Dom -> + ( "rootNodeAddress" ::: Signal Dom AddressNumber + , "res_tx" ::: Signal Dom Bit + ) +topEntity clk rst = (rn, res_tx) + where + (rn, res_tx) = + exposeClockResetEnable + ( (logicBoard @PortsNumber @NodesNumber @EdgesNumber @AgentType) + initialIdApplyToIdNode + 0 + initialIdApplyToIdMM + ) + clk + rst + enableGen {-# NOINLINE topEntity #-} makeTopEntity 'topEntity diff --git a/lamagraph-core/src/Core/Loader.hs b/lamagraph-core/src/Core/Loader.hs index 322b003f..a12f6d4d 100644 --- a/lamagraph-core/src/Core/Loader.hs +++ b/lamagraph-core/src/Core/Loader.hs @@ -132,3 +132,12 @@ zipInterfaceUpdatedToRamForm = (Just address, Nothing) -> Just (address, def) (Nothing, Just _) -> errorX " interfaced address is Nothing and external node is not " ) + +iterateOverRamForm :: + forall portsNumber agentType dom. + (KnownDomain dom, HiddenClockResetEnable dom, KnownNat portsNumber) => + Signal dom (Maybe (RamForm portsNumber agentType)) +iterateOverRamForm = mux (not <$> isMax) (Just <$> bundle (toEnum <$> idx, def)) def + where + idx = register 0 ((+ 1) <$> idx) + isMax = idx .>. pure (fromEnum (maxBound :: Index CellsNumber)) diff --git a/lamagraph-core/src/Core/Node.hs b/lamagraph-core/src/Core/Node.hs index be115351..b0da804b 100644 --- a/lamagraph-core/src/Core/Node.hs +++ b/lamagraph-core/src/Core/Node.hs @@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} module Core.Node where @@ -21,13 +22,15 @@ pattern NotConnected :: Connection portsNumber pattern NotConnected = Nothing {-# COMPLETE Connected, NotConnected #-} -type AddressBitSize = 4 +type AddressBitSize = 6 type AddressNumber = Unsigned AddressBitSize type CellsNumber = 2 ^ AddressBitSize data IdOfPort (portsNumber :: Nat) = Id (Index portsNumber) | Primary deriving (Generic, Show, Eq, NFDataX, ShowX) +deriving instance (KnownNat portsNumber, 1 <= portsNumber) => BitPack (IdOfPort portsNumber) + data Port (portsNumber :: Nat) = Port { _nodeAddress :: AddressNumber , _portConnectedToId :: IdOfPort portsNumber @@ -36,6 +39,8 @@ data Port (portsNumber :: Nat) = Port $(makeLenses ''Port) +deriving instance (KnownNat portsNumber, 1 <= portsNumber) => BitPack (Port portsNumber) + -- | Node in the RAM. data Node portsNumber agentType = Node { _primaryPort :: Connection portsNumber @@ -46,6 +51,8 @@ data Node portsNumber agentType = Node $(makeLenses ''Node) +deriving instance (KnownNat portsNumber, 1 <= portsNumber, BitPack agentType) => BitPack (Node portsNumber agentType) + {- | `Node` with info about his`Address`. Original address can be useful when reducer working. For example, if this `Node` has reduced then his `Address` is become free diff --git a/lamagraph-core/src/GraphRewriting/SKI.hs b/lamagraph-core/src/GraphRewriting/SKI.hs new file mode 100644 index 00000000..be0d5f6b --- /dev/null +++ b/lamagraph-core/src/GraphRewriting/SKI.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module GraphRewriting.SKI where + +import qualified Clash.Explicit.Prelude as Clash.Prelude +import qualified GraphRewriting.Translator as Translator +import INet.Graph +import Prelude + +data SKINet + = INR + | INA + | INI + | INE + | IND + | INV + | INK0 + | INK1 + | INS0 + | INS1 + | INS2 + deriving (Clash.Prelude.NFDataX, Clash.Prelude.Generic, Show, Eq, Clash.Prelude.ShowX) + +instance Translator.AgentMaps SKI SKINet where + agentToAgent :: SKI -> SKINet + agentToAgent = \case + R{} -> INR + A{} -> INA + I{} -> INI + E{} -> INE + D{} -> IND + V{} -> INV + K0{} -> INK0 + K1{} -> INK1 + S0{} -> INS0 + S1{} -> INS1 + S2{} -> INS2 diff --git a/lamagraph-core/src/GraphRewriting/Translator.hs b/lamagraph-core/src/GraphRewriting/Translator.hs new file mode 100644 index 00000000..a658c5f2 --- /dev/null +++ b/lamagraph-core/src/GraphRewriting/Translator.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +module GraphRewriting.Translator (translate, AgentMaps, agentToAgent) where + +import Clash.Prelude as Clash ( + Enum (fromEnum, toEnum), + Index, + KnownNat, + SNat (SNat), + Vec, + def, + fromSNat, + replace, + type (+), + ) +import qualified Clash.Sized.Vector as Clash +import Control.Monad (forM_) +import Control.Monad.Reader +import Control.Monad.State +import Core.Node +import Data.List (delete, elemIndex) +import qualified Data.List as Prelude +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import GraphRewriting as GR +import GraphRewriting.Pattern.InteractionNet as GRINet +import qualified GraphRewriting.Pattern.InteractionNet as GR +import INet.Net as CoreINet +import Prelude + +-- | Maps graph rewriting node type with INet.Net agent type +class (GRINet.INet n) => AgentMaps n agentType where + agentToAgent :: n -> agentType + +-- | State type: result net and memory map. Reader for graph rewriting functions +type GraphTranslator portsNumber agentType n = + StateT + (Vec CellsNumber (Maybe (Core.Node.Node portsNumber agentType))) + ( StateT + (Map.Map GR.Node AddressNumber, AddressNumber) + (Reader (GR.Graph n)) + ) + +-- | Maps graph rewriting index into fpga memory +memoryMap :: + GR.Node -> GraphTranslator portsNumber agentType n AddressNumber +memoryMap indexInGraph = do + (m, newAddr) <- lift get + case Map.lookup indexInGraph m of + Nothing -> do + lift $ put (Map.insert indexInGraph newAddr m, newAddr + 1) + pure newAddr + Just addr -> pure addr + +{- | Make id of port in INet.Node by GR.Port and GR.Node. +It finds respective number of hyperedge (actually, GR.Port) in own ports +-} +constructIdOfPort :: + ( GRINet.INet n + , View [GR.Port] n + , KnownNat portsNumber + , Show n + ) => + GR.Port -> + GR.Node -> + GraphTranslator portsNumber agentType n (Core.Node.IdOfPort portsNumber) +constructIdOfPort edgeKey nodeKey = do + grNode <- GR.readNode nodeKey + let principalPortKey = GRINet.principalPort grNode + secondaryPortsKeys = delete principalPortKey $ GR.inspect grNode :: [GR.Port] + if principalPortKey == edgeKey + then pure Primary + else + let i = + maybe + (error $ "there is no such Port in the Node: " ++ show grNode ++ " , " ++ show edgeKey) + Clash.toEnum + (elemIndex edgeKey secondaryPortsKeys) + in pure $ Id i + +{- | Make INet.Port in INet.Node by respective GR.Node and hyperedge. +GR.Node is necessary for distinguish "from" port and "to" port (it defines "from") in hyperedge +-} +hyperedgeToPort :: + forall n portsNumber agentType. + ( GRINet.INet n + , View [GR.Port] n + , KnownNat portsNumber + , Show n + ) => + GR.Node -> GR.Edge -> GraphTranslator portsNumber agentType n (Core.Node.Connection portsNumber) +hyperedgeToPort grNodeKey hyperEdge = do + grNodes <- GR.attachedNodes hyperEdge + case grNodes of + [] -> error "empty hyperedge" + [_] -> pure NotConnected + [x, y] -> + if x == grNodeKey + then makeConnection y + else makeConnection x + _ -> error "there are more than two ports in hyperedge" + where + makeConnection n = do + (idOfPort :: (Core.Node.IdOfPort portsNumber)) <- constructIdOfPort hyperEdge n + addr <- memoryMap n + pure $ Connected $ Core.Node.Port addr idOfPort + +{- | Helper function for creating `Vec` of consistent size from a list of values. +It fills the empty cells with `Nothing` +-} +constructVec :: + forall portsNumber a. (KnownNat portsNumber) => [a] -> Vec portsNumber (Maybe a) +constructVec xs = Clash.unsafeFromList $ (Just <$> xs) ++ nothings + where + vecLen = Clash.fromEnum (Clash.fromSNat $ Clash.SNat @portsNumber :: Index (portsNumber + 1)) + nothings = replicate (vecLen - Prelude.length xs) Nothing + +-- | Maps GR.Node in the graph in INet.Node +translateNode :: + forall n portsNumber agentType. + ( View [GR.Port] n + , GRINet.INet n + , KnownNat portsNumber + , Show n + , AgentMaps n agentType + ) => + GR.Node -> GraphTranslator portsNumber agentType n (Core.Node.Node portsNumber agentType) +translateNode grNodeKey = do + grNode <- GR.readNode grNodeKey + edgesKeys <- attachedEdges grNodeKey + (sp :: [(Connection portsNumber, GR.Edge)]) <- + mapM + ( \e -> do + c <- hyperedgeToPort grNodeKey e + pure (c, e) + ) + edgesKeys + let prPort = GR.principalPort grNode + _secondaryPorts = constructVec (map fst $ filter ((/= prPort) . snd) sp) + _primaryPort = + fst $ + fromMaybe (error $ "there is no primary port in the graph. connections:\n" ++ show sp ++ "node:\n" ++ show grNode) $ + Prelude.find + ((== prPort) . snd) + sp + _nodeType = agentToAgent grNode + pure Core.Node.Node{..} + +-- | Maps GR.Graph in INet.Net. It Stateful function, so result Net is in the State +translateGraph :: + forall n portsNumber agentType. + ( View [GR.Port] n + , GRINet.INet n + , KnownNat portsNumber + , Show n + , AgentMaps n agentType + ) => + GraphTranslator portsNumber agentType n () +translateGraph = do + grNodes <- readNodeList + forM_ + grNodes + ( \grNode -> do + inetNode <- translateNode grNode + addr <- memoryMap grNode + addNodeToInet inetNode addr + ) + where + addNodeToInet n addr = modify (Clash.replace i (Just n)) + where + i = Clash.fromEnum addr + +-- | Translate GR.Graph into INet.Net +translate :: + forall n agentType portsNumber. + ( KnownNat portsNumber + , GRINet.INet n + , View [GR.Port] n + , Show n + , AgentMaps n agentType + ) => + GR.Graph n -> Net portsNumber agentType -- alias for `Vec CellsNumber (Maybe (Core.Node.Node portsNumber agentType))` +translate graph = net + where + emptyNetDefined = runStateT translateGraph def + emptyMemoryDefined = runStateT emptyNetDefined (Map.empty, 0) + ((_, net), _) = runReader emptyMemoryDefined graph diff --git a/lamagraph-core/src/INet/Net.hs b/lamagraph-core/src/INet/Net.hs index f46ca843..f1772c07 100644 --- a/lamagraph-core/src/INet/Net.hs +++ b/lamagraph-core/src/INet/Net.hs @@ -26,3 +26,5 @@ class INet agentType nodesNumber edgesNumber portsNumber where LoadedNode portsNumber agentType -> LoadedNode portsNumber agentType -> ReduceRuleResult nodesNumber edgesNumber portsNumber agentType + +type Net (portsNumber :: Nat) agentType = Vec CellsNumber (Maybe (Node portsNumber agentType)) diff --git a/lamagraph-core/src/Protocols/Uart/GowinMaster.hs b/lamagraph-core/src/Protocols/Uart/GowinMaster.hs new file mode 100644 index 00000000..4c96b858 --- /dev/null +++ b/lamagraph-core/src/Protocols/Uart/GowinMaster.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Protocols.Uart.GowinMaster where + +import Clash.Annotations.Primitive +import Clash.Prelude +import Control.Monad.State.Strict +import Core.Node +import Data.Maybe (fromJust, isJust) +import Data.String.Interpolate (__i) +import Protocols.Uart.Helper + +gowinMasterUARTIp :: + (KnownDomain dom) => + Clock dom -> -- I_CLK + Reset dom -> -- I_RESETN + Enable dom -> -- I_TX_EN + Signal dom (BitVector 3) -> -- I_WADDR[2:0] + Enable dom -> -- I_RX_EN + Signal dom (BitVector 3) -> -- I_RADDR[2:0] + Signal dom Bit -> -- SIN + Signal dom (BitVector 8) -> -- I_WDATA[7:0] + -- Signal dom Bit -> -- DCDn + -- Signal dom Bit -> -- CTSn + -- Signal dom Bit -> -- DSRn + -- Signal dom Bit -> -- Rin + ( Signal dom (BitVector 8) -- O_RDATA[7:0] + , Signal dom Bit -- SOUT + , Signal dom Bit -- RxRDYn + , Signal dom Bit -- TxRDYn + -- , Signal dom Bit -- DDIS + -- , Signal dom Bit -- INTR + -- , Signal dom Bit -- DTRn + -- , Signal dom Bit -- RTSn + ) +gowinMasterUARTIp !_ !_ !_ !_ !_ !_ !_ !_ = def +-- {-# NOINLINE gowinMasterUARTIp #-} +{-# ANN gowinMasterUARTIp hasBlackBox #-} +{-# OPAQUE gowinMasterUARTIp #-} +{-# ANN + gowinMasterUARTIp + ( InlineYamlPrimitive + [Verilog, SystemVerilog] + [__i| + BlackBox: + kind: Declaration + name : Protocols.Uart.GowinMaster.gowinMasterUARTIp + type: |- + gowinMasterUARTIp :: + (KnownDomain dom) => + Clock dom -> -- I_CLK + Reset dom -> -- I_RESETN + Signal dom Bit -> -- I_TX_EN + Signal dom (BitVector 3) -> -- I_WADDR[2:0] + Signal dom Bit -> -- I_RX_EN + Signal dom (BitVector 3) -> -- I_RADDR[2:0] + Signal dom Bit -> -- SIN + Signal dom (BitVector 8) -> -- I_WDATA[7:0] + ( Signal dom (BitVector 8) -- O_RDATA[7:0] + , Signal dom Bit -- SOUT + ) + template: |- + // gowinMasterUARTIp begin + + UART_MASTER_Top ~GENSYM[master_uart_ip][0] ( + .I_CLK ( ~ARG[1] ), + .I_RESETN ( ~ARG[2] ), + .I_TX_EN ( ~ARG[3] ), + .I_WADDR ( ~ARG[4] ), + .I_WDATA ( ~ARG[8] ), + .I_RX_EN ( ~ARG[5] ), + .I_RADDR ( ~ARG[6] ), + .O_RDATA ( ~RESULT[10:3] ), + // Processor interface + .DDIS ( ), // Driver disable + .INTR ( ), // Interrupt + // Receiver interface + .SIN ( ~ARG[7] ), // Receiver serial input + .RxRDYn ( ~RESULT[1] ), // Receiver ready + // Transmitter interface + .SOUT ( ~RESULT[2] ), // Transmitter serial output + .TxRDYn ( ~RESULT[0] ), // Transmitter ready + // Modem interface + .DCDn ( 1'b0 ), // Data Carrier Detect + .CTSn ( 1'b0 ), // Clear To Send + .DSRn ( 1'b0 ), // Data Set Ready + .RIn ( 1'b0 ), // Ring Indicator + .DTRn ( ), // Data Terminal Ready + .RTSn ( ) // Request To Send + ); + // gowinMasterUARTIp end + + |] + ) + #-} + +transmitByUARTState :: (Byte, BitVector 8) -> UARTState +transmitByUARTState (d, rdata) = do + (status, r) <- get + let + defaultSt = (r, False, False, False) + configLCRHandler i = case i of + 0 -> do + put (ConfigLCR 1, configLCR) + pure (configLCR, True, False, False) + 1 -> do + put (ConfigLCR 2, r) + pure defaultSt + 2 -> do + put (ReadStatus 0, r) + pure defaultSt + _ -> undefined + readStatusHandler i = case i of + 0 -> do + put (ReadStatus 1, configLSR) + pure (configLSR, False, True, False) + 1 -> do + put (ReadStatus 2, r) + pure defaultSt + 2 -> do + put (ReadStatus 3, r) + pure defaultSt + 3 -> do + put (ReadStatus 4, LSR (unpack $ reverseBV $ truncateB rdata)) + pure defaultSt + 4 -> + if transmittingIsEnable r + then do + put (WriteData 0, r) + pure defaultSt + else do + put (ReadStatus 0, r) + pure defaultSt + _ -> undefined + writeDataHandler i = case i of + 0 -> do + put (WriteData 1, configTHRToWrite d) + pure (configTHRToWrite d, True, False, True) + 1 -> do + put (WriteData 2, r) + pure defaultSt + 2 -> do + put (ReadStatus 0, r) + pure defaultSt + _ -> undefined + case status of + ConfigLCR i -> configLCRHandler i + ReadStatus i -> readStatusHandler i + WriteData i -> writeDataHandler i + +transmitByteByUART :: + forall dom. + (KnownDomain dom, HiddenClockResetEnable dom) => + Signal dom Byte -> + (Signal dom Bit, Enable dom) +transmitByteByUART d = (sout, toEnable enBool) + where + transmitter = + mealyS + transmitByUARTState + (ConfigLCR 0, RBR (RBRTable 0)) + (uartReg, tx_en_bool, rx_en_bool, enBool) = + unbundle $ + transmitter + (bundle (d, rdata)) + rx_en = toEnable rx_en_bool + tx_en = toEnable tx_en_bool + (waddr, wdata) = unbundle (encodeUARTRegister <$> uartReg) + raddr = fst . encodeUARTRegister <$> uartReg + (rdata, sout, _, _) = (hideReset $ hideClock gowinMasterUARTIp) tx_en waddr rx_en raddr def wdata + +transmitNodeByUart :: + ( KnownDomain dom + , HiddenClockResetEnable dom + , KnownNat portsNumber + , 1 <= portsNumber + , BitPack agentType + ) => + Signal dom (Maybe (Node portsNumber agentType)) -> + (Signal dom Bit, Enable dom) +transmitNodeByUart maybeNode = (sout, toEnable isMax) + where + (byte, isMax) = exposeEnable (iterateOverDataBool (toBytes . fromJust <$> maybeNode)) rdyToRx + (sout, rdyToRx) = (isJust <$> maybeNode) `andEnable` transmitByteByUART byte diff --git a/lamagraph-core/src/Protocols/Uart/Helper.hs b/lamagraph-core/src/Protocols/Uart/Helper.hs new file mode 100644 index 00000000..5494ed62 --- /dev/null +++ b/lamagraph-core/src/Protocols/Uart/Helper.hs @@ -0,0 +1,155 @@ +{- HLINT ignore "Use newtype instead of data" -} +module Protocols.Uart.Helper where + +import Clash.Prelude +import Control.Monad.State.Strict + +type TX_EN = Bool +type RX_EN = Bool +type Byte = BitVector 8 + +data RBRTable = RBRTable {rbr :: BitVector 8} deriving (Generic, BitPack, Default, NFDataX) + +data THRTable = THRTable {thr :: BitVector 8} deriving (Generic, BitPack, Default, NFDataX) + +data IERTable = IERTable + { rbri :: Bit + , thri :: Bit + , rlsi :: Bit + , msi :: Bit + } + deriving (Generic, BitPack, Default, NFDataX) + +data IIRTable = IIRTable + { intStat :: Bit + , int01 :: BitVector 2 + , int2 :: Bit + } + deriving (Generic, BitPack, Default, NFDataX) + +data LCRTable = LCRTable + { wls :: BitVector 2 + , stb :: Bit + , pen :: Bit + , eps :: Bit + , sp :: Bit + , sb :: Bit + } + deriving (Generic, BitPack, Default, NFDataX) + +data MCRTable = MCRTable + { dtr :: Bit + , rts :: Bit + } + deriving (Generic, BitPack, Default, NFDataX) + +data LSRTable = LSRTable + { rxrdy :: Bit + , oe :: Bit + , pe :: Bit + , fe :: Bit + , bi :: Bit + , thre :: Bit + , tempt :: Bit + } + deriving (Generic, BitPack, Default, NFDataX) + +data MSRTable = MSRTable + { dcts :: Bit + , ddsr :: Bit + , teri :: Bit + , ddcd :: Bit + , cts :: Bit + , dsr :: Bit + , ri :: Bit + , dcd :: Bit + } + deriving (Generic, BitPack, Default, NFDataX) + +data MasterUARTRegister + = RBR RBRTable + | THR THRTable + | IER IERTable + | IIR IIRTable + | LCR LCRTable + | MCR MCRTable + | LSR LSRTable + | MSR MSRTable + deriving (Generic, BitPack, NFDataX) + +reverseBV :: (KnownNat n) => BitVector n -> BitVector n +reverseBV bv = v2bv $ reverse $ bv2v bv + +encodeUARTRegister :: MasterUARTRegister -> (BitVector 3, BitVector 8) +encodeUARTRegister r = case r of + RBR t -> (0b000, reverseBV $ pack t) + THR t -> (0b000, reverseBV $ pack t) + IER t -> (0b001, zeroExtend $ reverseBV $ pack t) + IIR t -> (0b010, zeroExtend $ reverseBV $ pack t) + LCR t -> (0b011, zeroExtend $ reverseBV $ pack t) + MCR t -> (0b100, zeroExtend $ reverseBV $ pack t) + LSR t -> (0b101, zeroExtend $ reverseBV $ pack t) + MSR t -> (0b110, reverseBV $ pack t) + +data UARTStatus = ConfigLCR (Index 3) | ReadStatus (Index 5) | WriteData (Index 3) deriving (Generic, NFDataX) +type UARTState = + State + ( UARTStatus + , MasterUARTRegister -- read register data (I_RADDR, O_RDATA) or previous state (it should be obvious by context) + ) + ( MasterUARTRegister + , TX_EN + , RX_EN + , Bool + ) + +configLCR :: MasterUARTRegister +configLCR = + LCR + ( LCRTable + { wls = 0b11 -- 8 bit + , stb = 0b0 -- 1 stop bit + , pen = 0b0 -- disable parity bit + , eps = 0b0 -- odd parity (disabled because of `pen`) + , sp = 0b0 -- disable force parity + , sb = 0b0 -- disable interrupt + } + ) + +configLSR :: MasterUARTRegister +configLSR = LSR def + +transmittingIsEnable :: MasterUARTRegister -> Bool +transmittingIsEnable (LSR (LSRTable{..})) = bitToBool tempt +transmittingIsEnable _ = error "transmittingIsEnable get wrong argument" +transmittingIsEnableTable :: LSRTable -> Bool +transmittingIsEnableTable (LSRTable{..}) = bitToBool (tempt .&. thre) + +transmittingIsCompleted :: MasterUARTRegister -> Bool +transmittingIsCompleted (LSR (LSRTable{..})) = bitToBool rxrdy +transmittingIsCompleted _ = error "transmittingIsCompleted get wrong argument" + +configTHRToWrite :: Byte -> MasterUARTRegister +configTHRToWrite d = THR (THRTable $ reverseBV d) + +toBytes :: (BitPack a) => a -> Vec ((BitSize a + 7) `Div` 8) Byte +toBytes x = bytes + where + bits = pack x + bytes = map v2bv (unconcat d8 (bv2v $ resize bits)) + +fromBytes :: (BitPack a) => Vec ((BitSize a + 7) `Div` 8) Byte -> a +fromBytes bytes = unpack (resize bits) + where + bits = v2bv (concatMap bv2v bytes) + +iterateOverDataBool :: + forall dom n d. + (HiddenClockResetEnable dom, KnownNat n) => + Signal dom (Vec n d) -> + (Signal dom d, Signal dom Bool) +iterateOverDataBool bytes = ((!!) <$> bytes <*> idx, isMax) + where + idx = register 0 nextIdx + isMax = idx .==. pure (maxBound :: Index n) + nextIdx = mux isMax def ((+ 1) <$> idx) diff --git a/lamagraph-core/tests/GR-examples/ski/bald-eagle.ski b/lamagraph-core/tests/GR-examples/ski/bald-eagle.ski new file mode 100644 index 00000000..234a2104 --- /dev/null +++ b/lamagraph-core/tests/GR-examples/ski/bald-eagle.ski @@ -0,0 +1 @@ +((S(K((S(K((S(KS))K)))((S(KS))K))))(S(K((S(K((S(KS))K)))((S(KS))K))))) diff --git a/lamagraph-core/tests/GR-examples/ski/bluebird.ski b/lamagraph-core/tests/GR-examples/ski/bluebird.ski new file mode 100644 index 00000000..a707f6ca --- /dev/null +++ b/lamagraph-core/tests/GR-examples/ski/bluebird.ski @@ -0,0 +1 @@ +((S(KS))K) diff --git a/lamagraph-core/tests/GR-examples/ski/cardinal.ski b/lamagraph-core/tests/GR-examples/ski/cardinal.ski new file mode 100644 index 00000000..851e5a1c --- /dev/null +++ b/lamagraph-core/tests/GR-examples/ski/cardinal.ski @@ -0,0 +1 @@ +((S((S(K((S(KS))K)))S))(KK)) diff --git a/lamagraph-core/tests/NodeGenerate.hs b/lamagraph-core/tests/NodeGenerate.hs deleted file mode 100644 index dc93d26c..00000000 --- a/lamagraph-core/tests/NodeGenerate.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} - -module NodeGenerate where - --- import Clash.Hedgehog.Sized.Unsigned --- import Clash.Hedgehog.Sized.Vector --- import Clash.Prelude --- import qualified Clash.Sized.Vector as Vec --- import Core.Node --- import qualified Hedgehog.Gen as Gen --- import Hedgehog.Internal.Gen (MonadGen) --- import qualified Hedgehog.Range as Range --- import qualified Prelude - --- type UnsignedRange (n :: Nat) = Range.Range (Unsigned n) - --- genAddress :: (MonadGen m) => m Address --- genAddress = genUnsigned (Range.linearBounded :: UnsignedRange 16) - --- -- | Honest generating uniq addresses. May be very slow. --- genUniqAddresses :: (MonadGen m, KnownNat n) => m (Vec n Address) --- genUniqAddresses = Gen.filterT addressesAreUniq (genVec genAddress) --- where --- addressesAreUniq vec = allDifferent $ toList vec --- allDifferent list = case list of --- [] -> True --- x : xs -> x `notElem` xs && allDifferent xs - --- genPort :: (MonadGen m) => m Port --- genPort = do --- address <- genAddress --- Port address <$> Gen.bool - --- genPortVisitedFlag :: (MonadGen m) => Bool -> m Port --- genPortVisitedFlag visited = do --- address <- genAddress --- return $ Port address visited - --- type GenNode (n :: Nat) = forall m. (MonadGen m) => m (Node n) - --- genNode :: forall m n. (MonadGen m, KnownNat n) => m (Node n) --- genNode = do --- port <- genPort --- ports <- genMbObjectsVec genPort :: _ (Vec n _) --- return $ Node port ports - --- genLoadedNodeByGivenAddresses :: (MonadGen m) => Address -> Address -> [Address] -> m (LoadedNode 5) --- genLoadedNodeByGivenAddresses nodeAddr prPortAddr secPortsAddr = --- return $ LoadedNode (Node (Port prPortAddr False) secPorts) nodeAddr --- where --- secPorts = Vec.unsafeFromList (mkPorts secPortsAddr) :: Vec 5 (Maybe Port) --- mkPorts = Prelude.map (\a -> Just (Port a False)) - --- genMbObjectsVec :: forall m n a. (MonadGen m, KnownNat n) => m a -> m (Vec n (Maybe a)) --- genMbObjectsVec genObjectFunc = genVec genFunc --- where --- genFunc = --- Gen.frequency --- [ (70, Just <$> genObjectFunc) --- , (30, return Nothing) --- ] diff --git a/lamagraph-core/tests/Tests/Core/Node.hs b/lamagraph-core/tests/Tests/Core/Node.hs deleted file mode 100644 index 1d5baad3..00000000 --- a/lamagraph-core/tests/Tests/Core/Node.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} - -module Tests.Core.Node where - -import qualified Clash.Prelude as C -import qualified Clash.Sized.Vector as Vec -import Core.Node -import qualified Hedgehog as H -import qualified Hedgehog.Gen as Gen -import Test.Tasty -import Test.Tasty.Hedgehog -import Test.Tasty.TH -import Prelude - --- prop_isPortToLoad_diffAddr :: H.Property --- prop_isPortToLoad_diffAddr = H.property $ do --- address <- H.forAll genAddress --- isVisited <- H.forAll Gen.bool --- let --- port = Port address isVisited --- node = Node port C.Nil --- loadedNode = LoadedNode node (address + 1) - --- isPortToLoad loadedNode port H.=== not isVisited - --- prop_isPortToLoad_sameAddr :: H.Property --- prop_isPortToLoad_sameAddr = H.property $ do --- address <- H.forAll genAddress --- isVisited <- H.forAll Gen.bool --- let --- port = Port address isVisited --- node = Node port C.Nil --- loadedNode = LoadedNode node address --- isPortToLoad loadedNode port H.=== False - --- prop_isActive_crossreference :: H.Property --- prop_isActive_crossreference = H.property $ do --- leftAddress <- H.forAll genAddress --- rightAddress <- H.forAll genAddress --- let --- leftPrimPort = Port rightAddress False --- rightPrimPort = Port leftAddress False --- leftNode = Node leftPrimPort C.Nil --- rightNode = Node rightPrimPort C.Nil --- leftLoadedNode = LoadedNode leftNode leftAddress --- rightLoadedNode = LoadedNode rightNode rightAddress --- H.assert $ isActive leftLoadedNode rightLoadedNode - --- prop_isActive_random :: H.Property --- prop_isActive_random = H.property $ do --- leftAddress <- H.forAll genAddress --- rightAddress <- H.forAll genAddress --- leftPortAddr <- H.forAll genAddress --- rightPortAddr <- H.forAll genAddress --- leftIsVisited <- H.forAll Gen.bool --- rightIsVisited <- H.forAll Gen.bool --- let --- leftPrimPort = Port leftPortAddr leftIsVisited --- leftNode = Node leftPrimPort C.Nil --- leftLoadedNode = LoadedNode leftNode leftAddress --- rightPrimPort = Port rightPortAddr rightIsVisited --- rightNode = Node rightPrimPort C.Nil --- rightLoadedNode = LoadedNode rightNode rightAddress --- isActive leftLoadedNode rightLoadedNode H.=== (leftAddress == rightPortAddr && rightAddress == leftPortAddr) - --- prop_selectAddressToLoad_primary_unvisited :: H.Property --- prop_selectAddressToLoad_primary_unvisited = H.property $ do --- nodeAddress <- H.forAll genAddress --- portTargetAddress <- H.forAll genAddress --- let --- port = Port portTargetAddress False --- node = Node port C.Nil --- loadedNode = LoadedNode node nodeAddress --- case selectAddressToLoad loadedNode of --- Nothing -> nodeAddress H.=== portTargetAddress --- Just address -> address H.=== portTargetAddress - --- prop_selectAddressToLoad_all_visited :: H.Property --- prop_selectAddressToLoad_all_visited = H.property $ do --- primPort <- H.forAll $ genPortVisitedFlag True --- secondaryPortsVec <- H.forAll $ genMbObjectsVec (genPortVisitedFlag True) :: _ (C.Vec 10 _) -- 10 is random number, it can be changed --- address <- H.forAll genAddress --- let --- node = Node primPort secondaryPortsVec --- loadedNode = LoadedNode node address --- selectAddressToLoad loadedNode H.=== Nothing - --- prop_markAllInnerEdges_empty_vec_of_nodes :: H.Property --- prop_markAllInnerEdges_empty_vec_of_nodes = H.property $ do --- let nodes = C.def :: C.Vec 10 (Maybe (LoadedNode 10)) --- nodes H.=== markAllInnerEdges nodes - --- prop_markAllInnerEdges_uniq_addresses :: H.Property --- prop_markAllInnerEdges_uniq_addresses = H.property $ do --- let --- uniqAddresses = C.iterateI (+ 1) 1 :: C.Vec 21 Address -- it can be obtained by using function genUniqAddresses, but it is very slow --- preDataToGenLoadedNodes = window 7 $ Vec.toList uniqAddresses --- listOfLoadedNodesGen = map genLoadedNode preDataToGenLoadedNodes --- genVecOfUniqLoadedNodes = sequence $ Vec.unsafeFromList listOfLoadedNodesGen :: H.Gen (C.Vec 3 (LoadedNode 5)) --- vecOfUniqLoadedNodes <- H.forAll genVecOfUniqLoadedNodes --- let vecOfMbUniqLoadedNodes = Just <$> vecOfUniqLoadedNodes --- markAllInnerEdges vecOfMbUniqLoadedNodes H.=== vecOfMbUniqLoadedNodes --- where --- window size list = case splitAt size list of --- ([], []) -> [] --- (xs, remainder) -> xs : window size remainder --- genLoadedNode list = genLoadedNodeByGivenAddresses (head list) (list !! 1) (drop 2 list) - --- prop_markAllInnerEdges_crossreference :: H.Property --- prop_markAllInnerEdges_crossreference = H.property $ do --- addressOfNode1 <- H.forAll genAddress --- addressOfNode2 <- H.forAll genAddress --- port1 <- H.forAll $ genPortVisitedFlag True --- let --- loadedNode1 = Just $ LoadedNode (Node port1 C.Nil) addressOfNode1 --- loadedNode2 = Just $ LoadedNode (Node (Port addressOfNode1 False) C.Nil) addressOfNode2 --- expectedResult = loadedNode1 C.:> Just (LoadedNode (Node (Port addressOfNode1 True) C.Nil) addressOfNode2) C.:> C.Nil --- actualResult = markAllInnerEdges (loadedNode1 C.:> loadedNode2 C.:> C.Nil) - --- actualResult H.=== expectedResult - -accumTests :: TestTree -accumTests = $(testGroupGenerator) - -main :: IO () -main = defaultMain accumTests diff --git a/lamagraph-core/tests/Tests/Core/Unit/CPU.hs b/lamagraph-core/tests/Tests/Core/Unit/CPU.hs index be669cd0..46697fbb 100644 --- a/lamagraph-core/tests/Tests/Core/Unit/CPU.hs +++ b/lamagraph-core/tests/Tests/Core/Unit/CPU.hs @@ -31,6 +31,8 @@ mealyCoreTestTemplate :: , Show agentType , ShowX agentType , Eq agentType + , 1 <= portsNumber + , BitPack agentType ) => Vec CellsNumber (Maybe (Node portsNumber agentType)) -> MemoryManager -> @@ -53,16 +55,18 @@ mealyCoreTestTemplate initNet initMemoryManager expectedAnswer cycleCount rootNo systemActualAnswer = sampleN cycleCount - ( (logicBroad @portsNumber @nodesNumber @edgesNumber @agentType @System) - initNet - rootNodeAddress - initMemoryManager + ( bundle $ + fst $ + (logicBoard @portsNumber @nodesNumber @edgesNumber @agentType @System) + initNet + rootNodeAddress + initMemoryManager ) answersAreEqual = P.all (`elem` systemActualAnswer) expectedAnswer idApplyToIdMealyCore :: TestTree idApplyToIdMealyCore = - mealyCoreTestTemplate @AgentSimpleLambda @2 @2 + mealyCoreTestTemplate @AgentType @NodesNumber @EdgesNumber initialIdApplyToIdNode initialIdApplyToIdMM [0, 1] diff --git a/lamagraph-core/tests/Tests/Core/Unit/Loader.hs b/lamagraph-core/tests/Tests/Core/Unit/Loader.hs index be029682..094efa06 100644 --- a/lamagraph-core/tests/Tests/Core/Unit/Loader.hs +++ b/lamagraph-core/tests/Tests/Core/Unit/Loader.hs @@ -38,8 +38,8 @@ activePairGettingTemplate :: Maybe (ActivePair portsNumber agentType) -> TestTree activePairGettingTemplate testName initialMM initialNet expectedActivePair = - testCase ("load active pair: " P.++ testName) - $ assertBool + testCase ("load active pair: " P.++ testName) $ + assertBool ( "expected:\n" P.++ show expectedActivePair P.++ "\nactual:\n" @@ -71,8 +71,8 @@ activePairGettingComplexTemplate :: [Maybe (ActivePair portsNumber agentType)] -> TestTree activePairGettingComplexTemplate testName initialNet activeAddresses expectedActivePairs = - testCase ("load active pair: " P.++ testName) - $ assertBool + testCase ("load active pair: " P.++ testName) $ + assertBool ( "expected:\n" P.++ show expectedActivePairs P.++ "\nactual:\n" @@ -106,8 +106,8 @@ interfaceReadWriteTemplate :: Vec externalNodesNumber (Maybe (LoadedNode portsNumber agentType)) -> TestTree interfaceReadWriteTemplate testName initialNet interface changedExNodes expectedNotWrittenInterface = - testCase ("load interface: " P.++ testName) - $ assertBool + testCase ("load interface: " P.++ testName) $ + assertBool ( "expected:\n" P.++ show expectedNotWrittenInterface P.++ "\n" @@ -144,8 +144,8 @@ interfaceReadWriteComplexTemplate :: Vec externalNodesNumber (Maybe (LoadedNode portsNumber agentType)) -> TestTree interfaceReadWriteComplexTemplate testName initialNet interface changedExNodes expectedNotWrittenInterface = - testCase ("load interface: " P.++ testName) - $ assertBool + testCase ("load interface: " P.++ testName) $ + assertBool ( "expected:\n" P.++ show expectedNotWrittenInterface P.++ "\n" @@ -168,10 +168,10 @@ interfaceReadWriteComplexTemplate testName initialNet interface changedExNodes e expectedNotWrittenInterface `elem` systemActualAnswer && P.last changedExNodes - `elem` systemActualAnswer + `elem` systemActualAnswer && changedExNodes - P.!! 3 - `elem` systemActualAnswer + P.!! 3 + `elem` systemActualAnswer combinationComplexTemplate :: forall agentType portsNumber externalNodesNumber. @@ -191,8 +191,8 @@ combinationComplexTemplate :: Vec externalNodesNumber (Maybe (LoadedNode portsNumber agentType)) -> TestTree combinationComplexTemplate testName initialNet activeAddresses interfaces changedExNodes expectedActivePairs expectedNotWrittenInterface = - testCase ("load interface and active pair: " P.++ testName) - $ assertBool + testCase ("load interface and active pair: " P.++ testName) $ + assertBool ( "expected:\n" P.++ show expectedNotWrittenInterface P.++ "\n" @@ -397,8 +397,8 @@ combinationComplex = :> Nil activePair1 = ActivePair <$> initialEpsAppToId !! 1 <*> (initialEpsAppToId !! 2) activePair2 = - Just - $ ActivePair + Just $ + ActivePair ( LoadedNode { _containedNode = Node diff --git a/lamagraph-core/tests/Tests/GraphRewriting/SKI.hs b/lamagraph-core/tests/Tests/GraphRewriting/SKI.hs new file mode 100644 index 00000000..ecf02e37 --- /dev/null +++ b/lamagraph-core/tests/Tests/GraphRewriting/SKI.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Eta reduce" #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} + +module Tests.GraphRewriting.SKI where + +import qualified Clash.Prelude as Clash +import qualified Common.Term as Term +import Core.Node +import Data.Maybe +import qualified GraphRewriting.Graph as GR +import GraphRewriting.SKI +import GraphRewriting.Translator as Translator +import INet.Graph +import INet.Net +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit +import Tests.GraphRewriting.SKIExpectedNets +import Prelude as P + +translateSKITerm :: Term.Expr -> Net 2 SKINet +translateSKITerm t = Translator.translate graph + where + graph = fromTerm t + +translateSKIFile :: FilePath -> IO (Net 2 SKINet) +translateSKIFile file = do + term <- Term.parseFile file + pure $ translateSKITerm term + +countOfActivePorts :: Core.Node.Node pn at -> Int +countOfActivePorts (Core.Node.Node _ sp _) = length $ filter isJust $ Clash.toList sp + +skiExamplesPath :: FilePath +skiExamplesPath = "tests" "GR-examples" "ski" + +bluebirdPath :: FilePath +bluebirdPath = skiExamplesPath "bluebird.ski" +cardinalPath :: FilePath +cardinalPath = skiExamplesPath "cardinal.ski" +baldEaglePath :: FilePath +baldEaglePath = skiExamplesPath "bald-eagle.ski" + +goldenTranslateBluebird :: IO TestTree +goldenTranslateBluebird = do + actualNet <- translateSKIFile bluebirdPath + let expectedNet = bluebirdINet + pure $ testCase "bluebird.ski" (actualNet @?= expectedNet) + +unitTranslateCardinal :: IO TestTree +unitTranslateCardinal = do + actualNet <- translateSKIFile cardinalPath + let expectedNet = cardinalINet + pure $ testCase "cardinal.ski" (actualNet @?= expectedNet) + +baldEagleNodesCount :: IO TestTree +baldEagleNodesCount = do + graph <- fromTerm <$> Term.parseFile baldEaglePath + let expectedCountOfNodes = length $ GR.nodeMap graph + actualCountOfNodes = length $ filter isJust $ Clash.toList (Translator.translate graph :: Net 2 SKINet) + pure $ testCase "bald-eagle.ski" (actualCountOfNodes @?= expectedCountOfNodes) + +baldEagleEdgesCount :: IO TestTree +baldEagleEdgesCount = do + graph <- fromTerm <$> Term.parseFile baldEaglePath + let expectedCountOfNodes = 2 * length (GR.edgeMap graph) + actualCountOfNodes = + sum $ map (maybe 0 countOfActivePorts) $ Clash.toList (Translator.translate graph :: Net 2 SKINet) + pure $ testCase "bald-eagle.ski" (actualCountOfNodes @?= expectedCountOfNodes) + +goldenTranslation :: IO TestTree +goldenTranslation = do + bluebirdTranslate <- goldenTranslateBluebird + cardinalTranslate <- unitTranslateCardinal + pure $ testGroup "golden" [bluebirdTranslate, cardinalTranslate] + +nodesCountTests :: IO TestTree +nodesCountTests = do + baldEagle <- baldEagleNodesCount + pure $ testGroup "nodes numbers are equal" [baldEagle] + +edgesCountTests :: IO TestTree +edgesCountTests = do + baldEagle <- baldEagleNodesCount + pure $ testGroup "edges numbers are equal" [baldEagle] + +skiUnitTests :: IO TestTree +skiUnitTests = do + goldenTests <- goldenTranslation + nodesCount <- nodesCountTests + edgesCount <- edgesCountTests + pure $ testGroup "ski translation" [goldenTests, nodesCount, edgesCount] diff --git a/lamagraph-core/tests/Tests/GraphRewriting/SKIExpectedNets.hs b/lamagraph-core/tests/Tests/GraphRewriting/SKIExpectedNets.hs new file mode 100644 index 00000000..11fefa14 --- /dev/null +++ b/lamagraph-core/tests/Tests/GraphRewriting/SKIExpectedNets.hs @@ -0,0 +1,246 @@ +module Tests.GraphRewriting.SKIExpectedNets where + +import Clash.Prelude +import Core.Node +import GraphRewriting.SKI +import INet.Net + +bluebirdINet :: Net 2 SKINet +bluebirdINet = + Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 1, _portConnectedToId = Primary}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 5, _portConnectedToId = Primary})) + :> Just (Just (Port{_nodeAddress = 2, _portConnectedToId = Id 0})) + :> Nil + , _nodeType = INA + } + ) + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 0, _portConnectedToId = Primary}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INS0 + } + ) + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 3, _portConnectedToId = Primary}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 0, _portConnectedToId = Id 1})) + :> Just (Just (Port{_nodeAddress = 4, _portConnectedToId = Primary})) + :> Nil + , _nodeType = INA + } + ) + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 2, _portConnectedToId = Primary}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INK0 + } + ) + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 2, _portConnectedToId = Id 1}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INS0 + } + ) + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 0, _portConnectedToId = Id 0}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 7, _portConnectedToId = Primary})) + :> Just (Just (Port{_nodeAddress = 6, _portConnectedToId = Primary})) + :> Nil + , _nodeType = INA + } + ) + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 5, _portConnectedToId = Id 1}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INK0 + } + ) + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 5, _portConnectedToId = Id 0}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INR + } + ) + :> def + +cardinalINet :: Net 2 SKINet +cardinalINet = + Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 1, _portConnectedToId = Primary}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 15, _portConnectedToId = Primary})) + :> Just (Just (Port{_nodeAddress = 13, _portConnectedToId = Id 0})) + :> Nil + , _nodeType = INA + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 0, _portConnectedToId = Primary}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INS0 + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 3, _portConnectedToId = Primary}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 13, _portConnectedToId = Primary})) + :> Just (Just (Port{_nodeAddress = 4, _portConnectedToId = Id 0})) + :> Nil + , _nodeType = INA + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 2, _portConnectedToId = Primary}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INS0 + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 5, _portConnectedToId = Primary}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 2, _portConnectedToId = Id 1})) + :> Just (Just (Port{_nodeAddress = 11, _portConnectedToId = Id 0})) + :> Nil + , _nodeType = INA + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 4, _portConnectedToId = Primary}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INK0 + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 7, _portConnectedToId = Primary}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 11, _portConnectedToId = Primary})) + :> Just (Just (Port{_nodeAddress = 8, _portConnectedToId = Id 0})) + :> Nil + , _nodeType = INA + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 6, _portConnectedToId = Primary}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INS0 + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 9, _portConnectedToId = Primary}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 6, _portConnectedToId = Id 1})) + :> Just (Just (Port{_nodeAddress = 10, _portConnectedToId = Primary})) + :> Nil + , _nodeType = INA + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 8, _portConnectedToId = Primary}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INK0 + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 8, _portConnectedToId = Id 1}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INS0 + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 6, _portConnectedToId = Id 0}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 4, _portConnectedToId = Id 1})) + :> Just (Just (Port{_nodeAddress = 12, _portConnectedToId = Primary})) + :> Nil + , _nodeType = INA + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 11, _portConnectedToId = Id 1}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INK0 + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 2, _portConnectedToId = Id 0}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 0, _portConnectedToId = Id 1})) + :> Just (Just (Port{_nodeAddress = 14, _portConnectedToId = Primary})) + :> Nil + , _nodeType = INA + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 13, _portConnectedToId = Id 1}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INS0 + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 0, _portConnectedToId = Id 0}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 19, _portConnectedToId = Primary})) + :> Just (Just (Port{_nodeAddress = 16, _portConnectedToId = Id 0})) + :> Nil + , _nodeType = INA + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 17, _portConnectedToId = Primary}) + , _secondaryPorts = + Just (Just (Port{_nodeAddress = 15, _portConnectedToId = Id 1})) + :> Just (Just (Port{_nodeAddress = 18, _portConnectedToId = Primary})) + :> Nil + , _nodeType = INA + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 16, _portConnectedToId = Primary}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INK0 + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 16, _portConnectedToId = Id 1}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INK0 + } + ) -- x + :> Just + ( Node + { _primaryPort = Just (Port{_nodeAddress = 15, _portConnectedToId = Id 0}) + , _secondaryPorts = Nothing :> Nothing :> Nil + , _nodeType = INR + } + ) -- x + :> def diff --git a/lamagraph-core/tests/doctests.hs b/lamagraph-core/tests/doctests.hs index 6b82d0e0..22009689 100644 --- a/lamagraph-core/tests/doctests.hs +++ b/lamagraph-core/tests/doctests.hs @@ -2,6 +2,7 @@ module Main where import System.Environment (getArgs) import Test.DocTest (mainFromCabal) +import Prelude main :: IO () main = mainFromCabal "lamagraph-core" =<< getArgs diff --git a/lamagraph-core/tests/unittests.hs b/lamagraph-core/tests/unittests.hs index bcdf1e95..f0bf4dd9 100644 --- a/lamagraph-core/tests/unittests.hs +++ b/lamagraph-core/tests/unittests.hs @@ -1,20 +1,27 @@ import Prelude import Test.Tasty -import qualified Tests.Core.Node import Tests.Core.Unit.CPU import Tests.Core.Unit.Loader import Tests.Core.Unit.MemoryManager.MemoryManager import Tests.Core.Unit.Reducer +import Tests.GraphRewriting.SKI main :: IO () -main = +main = do + skiUnitTests' <- skiUnitTests defaultMain $ testGroup - "Unit tests" - [ Tests.Core.Node.accumTests - , reducerUnitTests - , memoryManagerUnitTests - , mealyCoreUnitTests - , loaderUnitTests + " Unit tests" + [ testGroup + "Clash tests" + [ reducerUnitTests + , memoryManagerUnitTests + , mealyCoreUnitTests + , loaderUnitTests + ] + , testGroup + "Graph Rewriting translator tests" + [ skiUnitTests' + ] ] diff --git a/stack.yaml b/stack.yaml index 36d02400..03cc33cc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -41,8 +41,17 @@ packages: # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -# extra-deps: - +extra-deps: + - git: https://github.com/Lamagraph/graph-rewriting.git + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + subdirs: + - base + - lib + - strategies + - ski + - layout + - gl + - AC-Vector-2.4.0@sha256:e9b03da163208a948f47d294cfd9f496108d060a73c8a9d1f0ec9c9429d7f67d,1237 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index 893c60ac..b8724151 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,7 +3,92 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/topics/lock_files -packages: [] +packages: +- completed: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + name: graph-rewriting + pantry-tree: + sha256: 286c01307f9dd876d6defc11fa1ab16276677cf48a6f50dcfccff9cc1f756bca + size: 1141 + subdir: base + version: 0.8.0 + original: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + subdir: base +- completed: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + name: graph-rewriting-lib + pantry-tree: + sha256: 02ebd14f4e325d6d52fe523d8c7fcef59d9e5fbc96d607435fbe6b6e8c8dac43 + size: 343 + subdir: lib + version: 0.7.9 + original: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + subdir: lib +- completed: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + name: graph-rewriting-strategies + pantry-tree: + sha256: 0866e9e54e1ed72494b9ce30684fdf54cee4acc30b3672c2b1336fa2237bfb5a + size: 379 + subdir: strategies + version: 0.2.9 + original: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + subdir: strategies +- completed: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + name: graph-rewriting-ski + pantry-tree: + sha256: cf452c25f61c7ec190df2ec17faca687e8d12a1eda25be9193576f7a906b64ea + size: 4675 + subdir: ski + version: 0.6.8 + original: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + subdir: ski +- completed: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + name: graph-rewriting-layout + pantry-tree: + sha256: 0c9428fd4540e10c7765720333da41d1160d9be188232a468be78cea2c2044fd + size: 952 + subdir: layout + version: 0.5.8 + original: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + subdir: layout +- completed: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + name: graph-rewriting-gl + pantry-tree: + sha256: fa12e4cf20dc9f0c187dbc9d637d4e7f9e5dd700033cf5408c99d9fb2ac7db92 + size: 611 + subdir: gl + version: 0.7.9 + original: + commit: 2b12cc9d8c80e2e47824605d487781db3264e4d8 + git: https://github.com/Lamagraph/graph-rewriting.git + subdir: gl +- completed: + hackage: AC-Vector-2.4.0@sha256:e9b03da163208a948f47d294cfd9f496108d060a73c8a9d1f0ec9c9429d7f67d,1237 + pantry-tree: + sha256: 2bef6641223aafbdca6e75eec4534b09edeb7edf40184e87438e099270d4e701 + size: 1038 + original: + hackage: AC-Vector-2.4.0@sha256:e9b03da163208a948f47d294cfd9f496108d060a73c8a9d1f0ec9c9429d7f67d,1237 snapshots: - completed: sha256: d133abe75e408a407cce3f032c96ac1bbadf474a93b5156ebf4135b53382d56b