clash-ghc 0.2.2.2 → 0.3
raw patch · 26 files changed
+508/−161 lines, 26 filesdep +bifunctorsdep +containersdep ~clash-lib
Dependencies added: bifunctors, containers
Dependency ranges changed: clash-lib
Files
- clash-ghc.cabal +10/−3
- primitives/clash.ghc.ghc2core.json +6/−0
- primitives/clash.prelude.explicit.json +43/−0
- primitives/clash.prelude.json +27/−10
- primitives/clash.signal.explicit.json +35/−0
- primitives/clash.signal.implicit.json +30/−0
- primitives/clash.signal.json +0/−45
- primitives/clash.signal.types.json +16/−0
- primitives/clash.sized.signed.json +3/−3
- primitives/clash.sized.unsigned.json +3/−3
- primitives/clash.sized.vector.json +35/−24
- primitives/ghc.base.json +25/−8
- primitives/ghc.classes.json +17/−0
- primitives/ghc.cstring.json +5/−0
- primitives/ghc.err.json +0/−5
- primitives/ghc.integer.type.json +49/−25
- primitives/ghc.prim.json +52/−12
- primitives/ghc.real.json +10/−0
- primitives/ghc.types.json +5/−0
- src-bin/InteractiveUI.hs +3/−2
- src-bin/Main.hs +4/−1
- src-ghc/CLaSH/GHC/Evaluator.hs +44/−0
- src-ghc/CLaSH/GHC/GHC2Core.hs +36/−8
- src-ghc/CLaSH/GHC/GenerateBindings.hs +41/−9
- src-ghc/CLaSH/GHC/LoadModules.hs +3/−0
- src-ghc/CLaSH/GHC/NetlistTypes.hs +6/−3
clash-ghc.cabal view
@@ -1,5 +1,5 @@ Name: clash-ghc-Version: 0.2.2.2+Version: 0.3 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -14,7 +14,7 @@ * CλaSH Compiler binary using GHC/Haskell as a frontend . .- Prelude library: http://hackage.haskell.org/package/clash-prelude+ Prelude library: <http://hackage.haskell.org/package/clash-prelude> Homepage: http://christiaanb.github.io/clash2 bug-reports: http://github.com/christiaanb/clash2/issues License: OtherLicense@@ -30,9 +30,13 @@ src-bin/PosixSource.h Data-files: primitives/clash.bit.json,+ primitives/clash.ghc.ghc2core.json, primitives/clash.prelude.json,+ primitives/clash.prelude.explicit.json, primitives/clash.promoted.nat.json,- primitives/clash.signal.json,+ primitives/clash.signal.explicit.json,+ primitives/clash.signal.implicit.json,+ primitives/clash.signal.types.json, primitives/clash.sized.signed.json, primitives/clash.sized.unsigned.json, primitives/clash.sized.vector.json,@@ -74,9 +78,11 @@ Build-Depends: array >= 0.4, base >= 4.3.1.0 && < 5,+ bifunctors >= 4.1.1, bytestring >= 0.9, clash-lib >= 0.2.1, clash-prelude >= 0.2,+ containers >= 0.5.4.0, directory >= 1.2, filepath >= 1.3, ghc >= 7.8,@@ -107,6 +113,7 @@ CLaSH.GHC.Compat.Outputable CLaSH.GHC.Compat.PrelNames CLaSH.GHC.Compat.TyCon+ CLaSH.GHC.Evaluator CLaSH.GHC.GenerateBindings CLaSH.GHC.GHC2Core CLaSH.GHC.LoadInterfaceFiles
+ primitives/clash.ghc.ghc2core.json view
@@ -0,0 +1,6 @@+[ { "BlackBox" :+ { "name" : "EmptyCase"+ , "templateE" : "~DEFAULTO"+ }+ }+]
+ primitives/clash.prelude.explicit.json view
@@ -0,0 +1,43 @@+[ { "BlackBox" :+ { "name" : "CLaSH.Prelude.Explicit.cblockRam"+ , "templateD" :+"~SYM[0]_block : block+ type ram_array is array (natural range <>) of ~TYP[9];+ signal ~SYM[1] : ram_array((~ARG[0]-1) downto 0) := (others => ~ARG[3]); -- ram+ signal ~SYM[2] : ~TYP[9]; -- inp+ signal ~SYM[3] : ~TYP[9] := ~ARG[3]; -- outp+begin+ ~SYM[2] <= ~ARG[9];++ process(~CLKO)+ begin+ if rising_edge(~CLKO) then+ if ~ARG[8] then+ ~SYM[1](to_integer(~ARG[6])) <= ~SYM[2];+ end if;+ ~SYM[3] <= ~SYM[1](to_integer(~ARG[7]));+ end if;+ end process;++ ~RESULT <= ~SYM[3];+end block;"+ }+ }+, { "BlackBox" :+ { "name" : "CLaSH.Prelude.Explicit.csassert"+ , "templateD" :+"~SYM[0]_block : block+begin+ -- pragma translate_off+ process(~CLK[2],~RST[2],~ARG[2],~ARG[3]) is+ begin+ if (rising_edge(~CLK[2]) or rising_edge(~RST[2])) then+ assert (~ARG[2] = ~ARG[3]) report (\"expected: \" & to_string (~ARG[3]) & \", actual: \" & to_string (~ARG[2])) severity error;+ end if;+ end process;+ -- pragma translate_on+ ~RESULT <= ~ARG[4];+end block;"+ }+ }+]
primitives/clash.prelude.json view
@@ -2,24 +2,41 @@ { "name" : "CLaSH.Prelude.blockRam" , "templateD" : "~SYM[0]_block : block- type ram_array is array (natural range <>) of ~TYP[6];- signal ~SYM[1] : ram_array((~ARG[0]-1) downto 0); -- ram- signal ~SYM[2] : ~TYP[6]; -- inp- signal ~SYM[3] : ~TYP[6]; -- outp+ type ram_array is array (natural range <>) of ~TYP[8];+ signal ~SYM[1] : ram_array((~ARG[0]-1) downto 0) := (others => ~ARG[3]); -- ram+ signal ~SYM[2] : ~TYP[8]; -- inp+ signal ~SYM[3] : ~TYP[8] := ~ARG[3]; -- outp begin- ~SYM[2] <= ~ARG[6];+ ~SYM[2] <= ~ARG[8]; - process(~CLK[6])+ process(~CLKO) begin- if rising_edge(~CLK[6]) then- if ~ARG[5] then- ~SYM[1](to_integer(~ARG[3])) <= ~SYM[2];+ if rising_edge(~CLKO) then+ if ~ARG[7] then+ ~SYM[1](to_integer(~ARG[5])) <= ~SYM[2]; end if;- ~SYM[3] <= ~SYM[1](to_integer(~ARG[4]));+ ~SYM[3] <= ~SYM[1](to_integer(~ARG[6])); end if; end process; ~RESULT <= ~SYM[3];+end block;"+ }+ }+, { "BlackBox" :+ { "name" : "CLaSH.Prelude.sassert"+ , "templateD" :+"~SYM[0]_block : block+begin+ -- pragma translate_off+ process(~CLK[2],~RST[2],~ARG[2],~ARG[3]) is+ begin+ if (rising_edge(~CLK[2]) or rising_edge(~RST[2])) then+ assert (~ARG[2] = ~ARG[3]) report (\"expected: \" & to_string (~ARG[3]) & \", actual: \" & to_string (~ARG[2])) severity error;+ end if;+ end process;+ -- pragma translate_on+ ~RESULT <= ~ARG[4]; end block;" } }
+ primitives/clash.signal.explicit.json view
@@ -0,0 +1,35 @@+[ { "BlackBox" :+ { "name" : "CLaSH.Signal.Explicit.cregister"+ , "templateD" :+"~SYM[0]_block : block+ signal ~SYM[1] : ~TYP[2];+begin+ process(~CLKO,~RSTO)+ begin+ if ~RSTO = '0' then+ ~SYM[1] <= ~ARG[1];+ elsif rising_edge(~CLKO) then+ ~SYM[1] <= ~ARG[2];+ end if;+ end process;++ ~RESULT <= ~SYM[1];+end block;"+ }+ }+, { "BlackBox" :+ { "name" : "CLaSH.Signal.Explicit.veryUnsafeSynchronizer"+ , "templateE" : "~ARG[2]"+ }+ }+, { "Primitive" :+ { "name" : "CLaSH.Signal.Explicit.cpack"+ , "primType" : "Function"+ }+ }+, { "Primitive" :+ { "name" : "CLaSH.Signal.Explicit.cunpack"+ , "primType" : "Function"+ }+ }+]
+ primitives/clash.signal.implicit.json view
@@ -0,0 +1,30 @@+[ { "BlackBox" :+ { "name" : "CLaSH.Signal.Implicit.register"+ , "templateD" :+"~SYM[0]_block : block+ signal ~SYM[1] : ~TYP[1];+begin+ process(~CLKO,~RSTO)+ begin+ if ~RSTO = '0' then+ ~SYM[1] <= ~ARG[0];+ elsif rising_edge(~CLKO) then+ ~SYM[1] <= ~ARG[1];+ end if;+ end process;++ ~RESULT <= ~SYM[1];+end block;"+ }+ }+, { "Primitive" :+ { "name" : "CLaSH.Signal.Implicit.pack"+ , "primType" : "Function"+ }+ }+, { "Primitive" :+ { "name" : "CLaSH.Signal.Implicit.unpack"+ , "primType" : "Function"+ }+ }+]
− primitives/clash.signal.json
@@ -1,45 +0,0 @@-[ { "BlackBox" :- { "name" : "CLaSH.Signal.register"- , "templateD" :-"~SYM[0]_block : block- signal ~SYM[1] : ~TYP[1];-begin- process(~CLK[1],~RST[1])- begin- if ~RST[1] = '0' then- ~SYM[1] <= ~ARG[0];- elsif rising_edge(~CLK[1]) then- ~SYM[1] <= ~ARG[1];- end if;- end process;-- ~RESULT <= ~SYM[1];-end block;"- }- }-, { "Primitive" :- { "name" : "CLaSH.Signal.signal"- , "primType" : "Function"- }- }-, { "Primitive" :- { "name" : "CLaSH.Signal.mapSignal"- , "primType" : "Function"- }- }-, { "Primitive" :- { "name" : "CLaSH.Signal.appSignal"- , "primType" : "Function"- }- }-, { "Primitive" :- { "name" : "CLaSH.Signal.pack"- , "primType" : "Function"- }- }-, { "Primitive" :- { "name" : "CLaSH.Signal.unpack"- , "primType" : "Function"- }- }-]
+ primitives/clash.signal.types.json view
@@ -0,0 +1,16 @@+[ { "Primitive" :+ { "name" : "CLaSH.Signal.Types.signal"+ , "primType" : "Function"+ }+ }+, { "Primitive" :+ { "name" : "CLaSH.Signal.Types.mapSignal"+ , "primType" : "Function"+ }+ }+, { "Primitive" :+ { "name" : "CLaSH.Signal.Types.appSignal"+ , "primType" : "Function"+ }+ }+]
primitives/clash.sized.signed.json view
@@ -140,10 +140,10 @@ { "name" : "CLaSH.Sized.Signed.testBitS" , "templateD" : "~SYM[0]_testBitS : block- signal ~SYM[1] : ~TYP[0];+ signal ~SYM[1] : ~TYP[1]; begin- ~SYM[1] <= ~ARG[0];- ~RESULT <= ~SYM[1](~ARG[1]) = '1';+ ~SYM[1] <= ~ARG[1];+ ~RESULT <= ~SYM[1](~ARG[2]) = '1'; end block;" } }
primitives/clash.sized.unsigned.json view
@@ -109,10 +109,10 @@ { "name" : "CLaSH.Sized.Unsigned.testBitU" , "templateD" : "~SYM[0]_testBitU : block- signal ~SYM[1] : ~TYP[0];+ signal ~SYM[1] : ~TYP[1]; begin- ~SYM[1] <= ~ARG[0];- ~RESULT <= ~SYM[1](~ARG[1]) = '1';+ ~SYM[1] <= ~ARG[1];+ ~RESULT <= ~SYM[1](~ARG[2]) = '1'; end block;" } }
primitives/clash.sized.vector.json view
@@ -159,8 +159,8 @@ ~SYM[2]_vmap : for ~SYM[3] in ~RESULT'high downto 0 generate begin ~INST 0- ~OUTPUT <= ~RESULT(~SYM[3])~- ~INPUT <= ~SYM[1](~SYM[3])~+ ~OUTPUT <= ~RESULT(~SYM[3])~ ~TYPEL[~TYPO]~+ ~INPUT <= ~SYM[1](~SYM[3])~ ~TYPEL[~TYP[1]]~ ~INST end generate; end block;"@@ -179,9 +179,9 @@ ~SYM[3]_generate : for ~SYM[4] in ~RESULT'high downto 0 generate begin ~INST 0- ~OUTPUT <= ~RESULT(~SYM[4])~- ~INPUT <= ~SYM[1](~SYM[4])~- ~INPUT <= ~SYM[2](~SYM[4])~+ ~OUTPUT <= ~RESULT(~SYM[4])~ ~TYPEL[~TYPO]~+ ~INPUT <= ~SYM[1](~SYM[4])~ ~TYPEL[~TYP[1]]~+ ~INPUT <= ~SYM[2](~SYM[4])~ ~TYPEL[~TYP[2]]~ ~INST end generate; end block;"@@ -191,7 +191,7 @@ { "name" : "CLaSH.Sized.Vector.vfoldr" , "templateD" : "~SYM[0]_vfoldr : block- type ~SYM[7] is array (natural range <>) of ~TYP[1];+ type ~SYM[7] is array (integer range <>) of ~TYP[1]; signal ~SYM[6] : ~TYP[2]; signal ~SYM[1] : ~SYM[7](~SYM[6]'high downto 0); begin@@ -202,17 +202,17 @@ begin ~SYM[4]_generate : if ~SYM[3] /= (~SYM[6]'high) generate ~INST 0- ~OUTPUT <= ~SYM[1](~SYM[3]+1)~- ~INPUT <= ~SYM[6](~SYM[3])~- ~INPUT <= ~SYM[1](~SYM[3])~+ ~OUTPUT <= ~SYM[1](~SYM[3]+1)~ ~TYP[1]~+ ~INPUT <= ~SYM[6](~SYM[3])~ ~TYPEL[~TYP[2]]~+ ~INPUT <= ~SYM[1](~SYM[3])~ ~TYP[1]~ ~INST end generate; ~SYM[5]_generate : if ~SYM[3] = (~SYM[6]'high) generate ~INST 0- ~OUTPUT <= ~RESULT~- ~INPUT <= ~SYM[6](~SYM[3])~- ~INPUT <= ~SYM[1](~SYM[3])~+ ~OUTPUT <= ~RESULT~ ~TYPO~+ ~INPUT <= ~SYM[6](~SYM[3])~ ~TYPEL[~TYP[2]]~+ ~INPUT <= ~SYM[1](~SYM[3])~ ~TYP[1]~ ~INST end generate; end generate;@@ -223,7 +223,7 @@ { "name" : "CLaSH.Sized.Vector.vfoldl" , "templateD" : "~SYM[0]_vfoldl : block- type ~SYM[7] is array (natural range <>) of ~TYP[1];+ type ~SYM[7] is array (integer range <>) of ~TYP[1]; signal ~SYM[6] : ~TYP[2]; signal ~SYM[1] : ~SYM[7](~SYM[6]'high downto 0); begin@@ -234,17 +234,17 @@ begin ~SYM[4]_generate : if ~SYM[3] /= 0 generate ~INST 0- ~OUTPUT <= ~SYM[1](~SYM[3]-1)~- ~INPUT <= ~SYM[1](~SYM[3])~- ~INPUT <= ~SYM[6](~SYM[3])~+ ~OUTPUT <= ~SYM[1](~SYM[3]-1)~ ~TYP[1]~+ ~INPUT <= ~SYM[1](~SYM[3])~ ~TYP[1]~+ ~INPUT <= ~SYM[6](~SYM[3])~ ~TYPEL[~TYP[2]]~ ~INST end generate; ~SYM[5]_generate : if ~SYM[3] = 0 generate ~INST 0- ~OUTPUT <= ~RESULT~- ~INPUT <= ~SYM[1](~SYM[3])~- ~INPUT <= ~SYM[6](~SYM[3])~+ ~OUTPUT <= ~RESULT~ ~TYPO~+ ~INPUT <= ~SYM[1](~SYM[3])~ ~TYP[1]~+ ~INPUT <= ~SYM[6](~SYM[3])~ ~TYPEL[~TYP[2]]~ ~INST end generate; end generate;@@ -264,9 +264,9 @@ ~SYM[3]_generate : for ~SYM[4] in 1 to ~SYM[2]'high generate begin ~INST 0- ~OUTPUT <= ~SYM[2](~SYM[4])~- ~INPUT <= ~SYM[1](~SYM[4])~- ~INPUT <= ~SYM[2](~SYM[4]-1)~+ ~OUTPUT <= ~SYM[2](~SYM[4])~ ~TYPEL[~TYP[1]]~+ ~INPUT <= ~SYM[1](~SYM[4])~ ~TYPEL[~TYP[1]]~+ ~INPUT <= ~SYM[2](~SYM[4]-1)~ ~TYPEL[~TYP[1]]~ ~INST end generate; @@ -414,8 +414,8 @@ ~SYM[3]_generate : if ~SYM[1] /= (~RESULT'high) generate begin ~INST 0- ~OUTPUT <= ~RESULT(~SYM[1])~- ~INPUT <= ~RESULT(~SYM[1]+1)~+ ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~+ ~INPUT <= ~RESULT(~SYM[1]+1)~ ~TYPEL[~TYPO]~ ~INST end generate; end generate;"@@ -424,6 +424,17 @@ , { "BlackBox" : { "name" : "CLaSH.Sized.Vector.lazyV" , "templateE" : "~ARG[1]"+ }+ }+, { "BlackBox" :+ { "name" : "CLaSH.Sized.Vector.vhead'"+ , "templateD" :+"~SYM[0]_vhead : block+ signal ~SYM[1] : ~TYP[0];+begin+ ~SYM[1] <= ~ARG[0];+ ~RESULT <= ~SYM[1](~SYM[1]'high);+end block;" } } ]
primitives/ghc.base.json view
@@ -1,16 +1,33 @@-[ { "BlackBox" :- { "name" : "GHC.Base.plusInt"- , "templateE" : "~ARG[0] + ~ARG[1]"+[ { "Primitive" :+ { "name" : "GHC.Base.$"+ , "primType" : "Function" } } , { "BlackBox" :- { "name" : "GHC.Base.timesInt"- , "templateE" : "~ARG[0] * ~ARG[1]"+ { "name" : "GHC.Base.quotInt"+ , "templateE" : "~ARG[0] div ~ARG[1]" } }-, { "Primitive" :- { "name" : "GHC.Base.$"- , "primType" : "Function"+, { "BlackBox" :+ { "name" : "GHC.Base.remInt"+ , "templateE" : "~ARG[0] rem ~ARG[1]"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Base.divInt"+ , "templateD" :+"~SYM[0]_block : block+ signal ~SYM[1] : ~TYP[1];+begin+ ~SYM[1] <= ~ARG[0] / ~ARG[1];+ ~RESULT <= ~SYM[1] - 1 when ((~ARG[0] = abs ~ARG[0]) /= (~ARG[1] = abs ~ARG[1])) else+ ~SYM[1];+end block;"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Base.modInt"+ , "templateE" : "~ARG[0] mod ~ARG[1]" } } ]
primitives/ghc.classes.json view
@@ -43,4 +43,21 @@ , "templateE" : "not ~ARG[0]" } }+, { "BlackBox" :+ { "name" : "GHC.Classes.divInt#"+ , "templateD" :+"~SYM[0]_block : block+ signal ~SYM[1] : ~TYP[1];+begin+ ~SYM[1] <= ~ARG[0] / ~ARG[1];+ ~RESULT <= ~SYM[1] - 1 when ((~ARG[0] = abs ~ARG[0]) /= (~ARG[1] = abs ~ARG[1])) else+ ~SYM[1];+end block;"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Classes.modInt#"+ , "templateE" : "~ARG[0] mod ~ARG[1]"+ }+ } ]
primitives/ghc.cstring.json view
@@ -3,4 +3,9 @@ , "primType" : "Function" } }+, { "Primitive" :+ { "name" : "GHC.CString.unpackCStringUtf8#"+ , "primType" : "Function"+ }+ } ]
primitives/ghc.err.json view
@@ -1,9 +1,4 @@ [ { "BlackBox" :- { "name" : "GHC.Err.divZeroError"- , "templateE" : "~DEFAULTO"- }- }-, { "BlackBox" : { "name" : "GHC.Err.error" , "templateE" : "~DEFAULTO" }
primitives/ghc.integer.type.json view
@@ -1,14 +1,39 @@ [ { "BlackBox" :- { "name" : "GHC.Integer.Type.remInteger"- , "templateE" : "~ARG[0] rem ~ARG[1]"+ { "name" : "GHC.Integer.Type.smallInteger"+ , "templateE" : "~ARG[0]" } } , { "BlackBox" :- { "name" : "GHC.Integer.Type.quotInteger"- , "templateE" : "~ARG[0] div ~ARG[1]"+ { "name" : "GHC.Integer.Type.integerToInt"+ , "templateE" : "~ARG[0]" } } , { "BlackBox" :+ { "name" : "GHC.Integer.Type.plusInteger"+ , "templateE" : "~ARG[0] + ~ARG[1]"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Integer.Type.minusInteger"+ , "templateE" : "~ARG[0] - ~ARG[1]"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Integer.Type.timesInteger"+ , "templateE" : "~ARG[0] * ~ARG[1]"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Integer.Type.negateInteger"+ , "templateE" : "-~ARG[0]"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Integer.Type.absInteger"+ , "templateE" : "abs ~ARG[0]"+ }+ }+, { "BlackBox" : { "name" : "GHC.Integer.Type.divInteger" , "templateD" : "~SYM[0]_block : block@@ -20,19 +45,23 @@ end block;" } }- , { "BlackBox" : { "name" : "GHC.Integer.Type.modInteger" , "templateE" : "~ARG[0] mod ~ARG[1]" } } , { "BlackBox" :- { "name" : "GHC.Integer.Type.eqInteger"- , "templateE" : "~ARG[0] = ~ARG[1]"+ { "name" : "GHC.Integer.Type.quotInteger"+ , "templateE" : "~ARG[0] div ~ARG[1]" } } , { "BlackBox" :- { "name" : "GHC.Integer.Type.eqInteger#"+ { "name" : "GHC.Integer.Type.remInteger"+ , "templateE" : "~ARG[0] rem ~ARG[1]"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Integer.Type.eqInteger" , "templateE" : "~ARG[0] = ~ARG[1]" } }@@ -62,38 +91,33 @@ } } , { "BlackBox" :- { "name" : "GHC.Integer.Type.absInteger"- , "templateE" : "abs ~ARG[0]"- }- }-, { "BlackBox" :- { "name" : "GHC.Integer.Type.plusInteger"- , "templateE" : "~ARG[0] + ~ARG[1]"+ { "name" : "GHC.Integer.Type.eqInteger#"+ , "templateE" : "1 when ~ARG[0] = ~ARG[1] else 0" } } , { "BlackBox" :- { "name" : "GHC.Integer.Type.minusInteger"- , "templateE" : "~ARG[0] - ~ARG[1]"+ { "name" : "GHC.Integer.Type.neqInteger#"+ , "templateE" : "1 when ~ARG[0] /= ~ARG[1] else 0" } } , { "BlackBox" :- { "name" : "GHC.Integer.Type.timesInteger"- , "templateE" : "~ARG[0] * ~ARG[1]"+ { "name" : "GHC.Integer.Type.leInteger#"+ , "templateE" : "1 when ~ARG[0] <= ~ARG[1] else 0" } } , { "BlackBox" :- { "name" : "GHC.Integer.Type.negateInteger"- , "templateE" : "-~ARG[0]"+ { "name" : "GHC.Integer.Type.gtInteger#"+ , "templateE" : "1 when ~ARG[0] > ~ARG[1] else 0" } } , { "BlackBox" :- { "name" : "GHC.Integer.Type.integerToInt"- , "templateE" : "~ARG[0]"+ { "name" : "GHC.Integer.Type.ltInteger#"+ , "templateE" : "1 when ~ARG[0] < ~ARG[1] else 0" } } , { "BlackBox" :- { "name" : "GHC.Integer.Type.eqInteger#"- , "templateE" : "~ARG[0] = ~ARG[1]"+ { "name" : "GHC.Integer.Type.geInteger#"+ , "templateE" : "1 when ~ARG[0] >= ~ARG[1] else 0" } } ]
primitives/ghc.prim.json view
@@ -1,36 +1,76 @@ [ { "BlackBox" :- { "name" : "GHC.Prim.tagToEnum#"- , "templateE" : "~ARG[0]"+ { "name" : "GHC.Prim.+#"+ , "templateE" : "~ARG[0] + ~ARG[1]" } } , { "BlackBox" :+ { "name" : "GHC.Prim.-#"+ , "templateE" : "~ARG[0] - ~ARG[1]"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Prim.*#"+ , "templateE" : "~ARG[0] * ~ARG[1]"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Prim.quotInt#"+ , "templateE" : "~ARG[0] div ~ARG[1]"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Prim.remInt#"+ , "templateE" : "~ARG[0] rem ~ARG[1]"+ }+ }+, { "BlackBox" : { "name" : "GHC.Prim.negateInt#" , "templateE" : "-~ARG[0]" } } , { "BlackBox" :- { "name" : "GHC.Prim.<#"- , "templateE" : "~ARG[0] < ~ARG[1]"+ { "name" : "GHC.Prim.>#"+ , "templateE" : "1 when ~ARG[0] > ~ARG[1] else 0" } } , { "BlackBox" :- { "name" : "GHC.Prim.>#"- , "templateE" : "~ARG[0] > ~ARG[1]"+ { "name" : "GHC.Prim.>=#"+ , "templateE" : "1 when ~ARG[0] >= ~ARG[1] else 0" } } , { "BlackBox" :- { "name" : "GHC.Prim.-#"- , "templateE" : "~ARG[0] - ~ARG[1]"+ { "name" : "GHC.Prim.==#"+ , "templateE" : "1 when ~ARG[0] = ~ARG[1] else 0" } } , { "BlackBox" :- { "name" : "GHC.Prim.+#"- , "templateE" : "~ARG[0] + ~ARG[1]"+ { "name" : "GHC.Prim./=#"+ , "templateE" : "1 when ~ARG[0] /= ~ARG[1] else 0" } } , { "BlackBox" :- { "name" : "GHC.Prim.*#"- , "templateE" : "~ARG[0] * ~ARG[1]"+ { "name" : "GHC.Prim.<#"+ , "templateE" : "1 when ~ARG[0] < ~ARG[1] else 0"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Prim.<=#"+ , "templateE" : "1 when ~ARG[0] <= ~ARG[1] else 0"+ }+ }+, { "Primitive" :+ { "name" : "GHC.Prim.dataToTag#"+ , "primType" : "Function"+ }+ }+, { "Primitive" :+ { "name" : "GHC.Prim.tagToEnum#"+ , "primType" : "Function"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Prim.unsafeCoerce#"+ , "templateE" : "~ARG[0]" } } ]
primitives/ghc.real.json view
@@ -3,4 +3,14 @@ , "templateE" : "~DEFAULTO" } }+, { "BlackBox" :+ { "name" : "GHC.Real.ratioZeroDenominatorError"+ , "templateE" : "~DEFAULTO"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Real.overflowError"+ , "templateE" : "~DEFAULTO"+ }+ } ]
primitives/ghc.types.json view
@@ -3,4 +3,9 @@ , "primType" : "Constructor" } }+, { "Primitive" :+ { "name" : "GHC.Types.MkCoercible"+ , "primType" : "Constructor"+ }+ } ]
src-bin/InteractiveUI.hs view
@@ -104,6 +104,7 @@ import GHC.TopHandler ( topHandler ) import qualified CLaSH.Driver+import CLaSH.GHC.Evaluator import CLaSH.GHC.GenerateBindings import CLaSH.GHC.NetlistTypes import qualified CLaSH.Primitives.Util@@ -1500,13 +1501,13 @@ maybe (return ()) (\src -> liftIO $ do primDir <- getDefPrimDir primMap <- CLaSH.Primitives.Util.generatePrimMap [primDir,"."] (bindingsMap,tcm) <- generateBindings primMap src- CLaSH.Driver.generateVHDL bindingsMap primMap tcm ghcTypeToHWType DebugNone+ CLaSH.Driver.generateVHDL bindingsMap primMap tcm ghcTypeToHWType reduceConstant DebugNone ) loc _ -> return () makeVHDL srcs = liftIO $ do primDir <- getDefPrimDir primMap <- CLaSH.Primitives.Util.generatePrimMap [primDir,"."] mapM_ (\src -> do (bindingsMap,tcm) <- generateBindings primMap src- CLaSH.Driver.generateVHDL bindingsMap primMap tcm ghcTypeToHWType DebugNone+ CLaSH.Driver.generateVHDL bindingsMap primMap tcm ghcTypeToHWType reduceConstant DebugNone ) srcs -----------------------------------------------------------------------------
src-bin/Main.hs view
@@ -73,6 +73,7 @@ import Exception (gcatch) import Control.Exception (ErrorCall (..)) import qualified CLaSH.Driver+import CLaSH.GHC.Evaluator import CLaSH.GHC.GenerateBindings import CLaSH.GHC.NetlistTypes import qualified CLaSH.Primitives.Util@@ -166,6 +167,8 @@ , DynFlags.Opt_DataKinds , DynFlags.Opt_TypeOperators , DynFlags.Opt_FlexibleContexts+ , DynFlags.Opt_ConstraintKinds+ , DynFlags.Opt_TypeFamilies ] case postStartupMode of@@ -876,7 +879,7 @@ doVHDL srcs = liftIO $ do primDir <- getDefPrimDir primMap <- CLaSH.Primitives.Util.generatePrimMap [primDir,"."] mapM_ (\(src,_) -> do (bindingsMap,tcm) <- generateBindings primMap src- CLaSH.Driver.generateVHDL bindingsMap primMap tcm ghcTypeToHWType DebugNone+ CLaSH.Driver.generateVHDL bindingsMap primMap tcm ghcTypeToHWType reduceConstant DebugNone ) srcs -- -----------------------------------------------------------------------------
+ src-ghc/CLaSH/GHC/Evaluator.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ViewPatterns #-}+module CLaSH.GHC.Evaluator where++import qualified Data.Bifunctor as Bifunctor+import qualified Data.Either as Either+import qualified Data.HashMap.Strict as HashMap+import qualified Data.List as List+import qualified Data.Text as Text+import CLaSH.Core.DataCon (dcTag)+import CLaSH.Core.Literal (Literal (..))+import CLaSH.Core.Term (Term (..))+import CLaSH.Core.Type (Type (..), ConstTy (..))+import CLaSH.Core.TyCon (TyCon, TyConName, tyConDataCons)+import CLaSH.Core.Util (collectArgs)++reduceConstant :: HashMap.HashMap TyConName TyCon -> Term -> Term+reduceConstant tcm e@(collectArgs -> (Prim nm _, args))+ | nm == Text.pack "GHC.Integer.Type.eqInteger#"+ = case (map (reduceConstant tcm) . Either.lefts) args of+ [Literal (IntegerLiteral i), Literal (IntegerLiteral j)]+ | i == j -> Literal (IntegerLiteral 1)+ | otherwise -> Literal (IntegerLiteral 0)+ _ -> e+ | nm == Text.pack "GHC.Prim.<=#" || nm == Text.pack "GHC.Integer.Type.leInteger#"+ = case (map (reduceConstant tcm) . Either.lefts) args of+ [Literal (IntegerLiteral i), Literal (IntegerLiteral j)]+ | i <= j -> Literal (IntegerLiteral 1)+ | otherwise -> Literal (IntegerLiteral 0)+ _ -> e+ | nm == Text.pack "GHC.Integer.Type.integerToInt"+ = case (map (reduceConstant tcm) . Either.lefts) args of+ [Literal (IntegerLiteral i)] -> Literal (IntegerLiteral i)+ _ -> e+ | nm == Text.pack "GHC.Prim.tagToEnum#"+ = case map (Bifunctor.bimap (reduceConstant tcm) id) args of+ [Right (ConstTy (TyCon tcN)), Left (Literal (IntegerLiteral i))] ->+ let dc = do { tc <- HashMap.lookup tcN tcm+ ; let dcs = tyConDataCons tc+ ; List.find ((== (i+1)) . toInteger . dcTag) dcs+ }+ in maybe e Data dc+ _ -> e++reduceConstant _ e = e
src-ghc/CLaSH/GHC/GHC2Core.hs view
@@ -23,7 +23,7 @@ import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashMap.Strict as HSM import Data.Maybe (fromMaybe)-import Data.Text (pack)+import Data.Text (isInfixOf,pack) import qualified Data.Traversable as T import Unbound.LocallyNameless (Rep, bind, embed, rebind, rec, runFreshM, string2Name, unbind,@@ -254,17 +254,20 @@ Nothing -> C.Data <$> coreToDataCon (isDataConWrapId x && not (isNewTyCon (dataConTyCon dc))) dc Nothing -> case HashMap.lookup xNameS primMap of Just (Primitive f _)- | f == pack "CLaSH.Signal.mapSignal" -> return (mapSyncTerm xType)- | f == pack "CLaSH.Signal.appSignal" -> return (mapSyncTerm xType)- | f == pack "CLaSH.Signal.signal" -> return (syncTerm xType)- | f == pack "CLaSH.Signal.pack" -> return (splitCombineTerm False xType)- | f == pack "CLaSH.Signal.unpack" -> return (splitCombineTerm True xType)- | f == pack "GHC.Base.$" -> return (dollarAppTerm xType)- | otherwise -> return (C.Prim xNameS xType)+ | f == pack "CLaSH.Signal.Types.mapSignal" -> return (mapSyncTerm xType)+ | f == pack "CLaSH.Signal.Types.appSignal" -> return (mapSyncTerm xType)+ | f == pack "CLaSH.Signal.Types.signal" -> return (syncTerm xType)+ | f == pack "CLaSH.Signal.Implicit.pack" -> return (splitCombineTerm False xType)+ | f == pack "CLaSH.Signal.Implicit.unpack" -> return (splitCombineTerm True xType)+ | f == pack "CLaSH.Signal.Explicit.cpack" -> return (cpackCUnpackTerm False xType)+ | f == pack "CLaSH.Signal.Explicit.cunpack" -> return (cpackCUnpackTerm True xType)+ | f == pack "GHC.Base.$" -> return (dollarAppTerm xType)+ | otherwise -> return (C.Prim xNameS xType) Just (BlackBox {}) -> return (C.Prim xNameS xType) Nothing | x `elem` unlocs -> return (C.Prim xNameS xType)+ | pack "$cshow" `isInfixOf` xNameS -> return (C.Prim xNameS xType) | otherwise -> return (C.Var xType xVar) alt (DEFAULT , _ , e) = bind C.DefaultPat <$> term e@@ -441,6 +444,31 @@ in newExpr splitCombineTerm _ ty = error $ $(curLoc) ++ show ty++cpackCUnpackTerm :: Bool+ -> C.Type+ -> C.Term+cpackCUnpackTerm b (C.ForAllTy tvTy) = newExpr+ where+ (aTV,packCDict,clkTV,clkTy,inpTy,outpTy) = runFreshM $ do+ (aTV',C.tyView -> C.FunTy packCDict' (C.ForAllTy ty2)) <- unbind tvTy+ (clkTV',C.tyView -> (C.FunTy clkTy' (C.tyView -> C.FunTy inpTy' outpTy'))) <- unbind ty2+ return (aTV',packCDict',clkTV',clkTy',inpTy',outpTy')+ dictName = string2Name "cpackDict"+ clkName = string2Name "clk"+ sigName = string2Name "csig"+ sigTy = if b then inpTy else outpTy+ dictId = C.Id dictName (embed packCDict)+ clkId = C.Id clkName (embed clkTy)+ sigId = C.Id sigName (embed sigTy)+ newExpr = C.TyLam $ bind aTV $+ C.Lam $ bind dictId $+ C.TyLam $ bind clkTV $+ C.Lam $ bind clkId $+ C.Lam $ bind sigId $+ C.Var sigTy sigName++cpackCUnpackTerm _ ty = error $ $(curLoc) ++ show ty dollarAppTerm :: C.Type -> C.Term
src-ghc/CLaSH/GHC/GenerateBindings.hs view
@@ -7,20 +7,25 @@ import Data.Either (lefts, rights) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap-import Unbound.LocallyNameless (runFreshM, unembed)+import Data.List (isSuffixOf)+import qualified Data.Set as Set+import Unbound.LocallyNameless (name2String, runFreshM, unembed) import qualified CoreSyn as GHC -import CLaSH.Core.Term (Term, TmName)-import CLaSH.Core.Type (Type, splitFunForallTy)+import CLaSH.Core.FreeVars (termFreeIds)+import CLaSH.Core.Term (Term (..), TmName)+import CLaSH.Core.Type (Type, TypeView (..), coreView, mkFunTy, splitFunForallTy) import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Core.TysPrim (tysPrimMap)-import CLaSH.Core.Util (mkLams, mkTyLams)+import CLaSH.Core.Subst (substTms)+import CLaSH.Core.Util (mkLams, mkTyLams, termType) import CLaSH.Core.Var (Var (..)) import CLaSH.Driver.Types (BindingMap) import CLaSH.GHC.GHC2Core (GHC2CoreState, coreToId, coreToTerm, makeAllTyCons, emptyGHC2CoreState) import CLaSH.GHC.LoadModules (loadModules)+import CLaSH.Normalize.Util import CLaSH.Primitives.Types (PrimMap) import CLaSH.Rewrite.Util (mkInternalVar, mkSelectorCase) import CLaSH.Util ((***),first)@@ -36,8 +41,28 @@ allTcCache = tysPrimMap `HashMap.union` tcCache clsMap = HashMap.map (\(ty,i) -> (ty,mkClassSelector allTcCache ty i)) clsVMap allBindings = bindingsMap `HashMap.union` clsMap- return (allBindings,allTcCache)+ topEntities = HashMap.filterWithKey (\var _ -> isSuffixOf "topEntity" $ name2String var) allBindings+ retypedBindings = case HashMap.toList topEntities of+ [topEntity] -> let droppedBindings = lambdaDropPrep allBindings (fst topEntity)+ in snd $ retype allTcCache ([],droppedBindings) (fst topEntity)+ _ -> allBindings+ return (retypedBindings,allTcCache) +-- | clean up cast-removal mess+retype :: HashMap TyConName TyCon+ -> ([TmName], BindingMap) -- (visited, bindings)+ -> TmName -- top+ -> ([TmName], BindingMap)+retype tcm (visited,bindings) current = (visited', HashMap.insert current (ty',tm') bindings')+ where+ (_,tm) = bindings HashMap.! current+ used = Set.toList $ termFreeIds tm+ (visited',bindings') = foldl (retype tcm) (current:visited,bindings) (filter (`notElem` visited) used)+ usedTys = map (fst . (bindings' HashMap.!)) used+ usedVars = zipWith Var usedTys used+ tm' = substTms (zip used usedVars) tm+ ty' = runFreshM (termType tcm tm')+ mkBindings :: PrimMap -> [(GHC.CoreBndr, GHC.CoreExpr)] -- Binders -> [(GHC.CoreBndr,Int)] -- Class operations@@ -70,7 +95,14 @@ $ first (span (\l -> case l of Left _ -> True _ -> False)) $ splitFunForallTy ty- newExpr = runFreshM $ flip State.evalStateT (0 :: Int) $ do- (dcId,dcVar) <- mkInternalVar "dict" dictTy- selE <- mkSelectorCase "mkClassSelector" tcm [] dcVar 1 sel- return (mkTyLams (mkLams selE [dcId]) tvs)+ newExpr = case coreView tcm dictTy of+ (TyConApp _ _) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do+ (dcId,dcVar) <- mkInternalVar "dict" dictTy+ selE <- mkSelectorCase "mkClassSelector" tcm [] dcVar 1 sel+ return (mkTyLams (mkLams selE [dcId]) tvs)+ (FunTy arg res) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do+ (dcId,dcVar) <- mkInternalVar "dict" (mkFunTy arg res)+ return (mkTyLams (mkLams dcVar [dcId]) tvs)+ (OtherType oTy) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do+ (dcId,dcVar) <- mkInternalVar "dict" oTy+ return (mkTyLams (mkLams dcVar [dcId]) tvs)
src-ghc/CLaSH/GHC/LoadModules.hs view
@@ -77,12 +77,15 @@ { DynFlags.ctxtStkDepth = 1000 , DynFlags.optLevel = 2 , DynFlags.ghcMode = GHC.CompManager+ , DynFlags.ghcLink = GHC.LinkInMemory } ) [ DynFlags.Opt_TemplateHaskell , DynFlags.Opt_Arrows , DynFlags.Opt_DataKinds , DynFlags.Opt_TypeOperators , DynFlags.Opt_FlexibleContexts+ , DynFlags.Opt_ConstraintKinds+ , DynFlags.Opt_TypeFamilies ] let dflags2 = wantedOptimizationFlags dflags1 let dflags3 = if ghcDynamic then DynFlags.gopt_set dflags2 DynFlags.Opt_BuildDynamicToo
src-ghc/CLaSH/GHC/NetlistTypes.hs view
@@ -28,9 +28,12 @@ "GHC.Types.Bool" -> return Bool "GHC.Prim.~#" -> fail $ "Can't translate type: " ++ showDoc ty "CLaSH.Bit.Bit" -> return Bit- "CLaSH.Signal.Pack" -> fail $ "Can't translate type: " ++ showDoc ty- "CLaSH.Signal.Signal" -> ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m (head args)- "CLaSH.Signal.SignalP" -> ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m (head args)+ "CLaSH.Signal.Implicit.Pack" -> fail $ "Can't translate type: " ++ showDoc ty+ "CLaSH.Signal.Implicit.CPack" -> fail $ "Can't translate type: " ++ showDoc ty+ "CLaSH.Signal.Types.Signal" -> ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m (head args)+ "CLaSH.Signal.Types.CSignal" -> ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m (args !! 1)+ "CLaSH.Signal.Implicit.SignalP" -> ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m (head args)+ "CLaSH.Signal.Explicit.CSignalP" -> ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m (args !! 1) "CLaSH.Sized.Signed.Signed" -> Signed <$> tyNatSize (head args) "CLaSH.Sized.Unsigned.Unsigned" -> Unsigned <$> tyNatSize (head args) "CLaSH.Sized.Vector.Vec" -> do