diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2012-2014, University of Twente +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +http://christiaanb.github.io/clash2/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/clash-ghc.cabal b/clash-ghc.cabal new file mode 100644 --- /dev/null +++ b/clash-ghc.cabal @@ -0,0 +1,117 @@ +Name: clash-ghc +Version: 0.2.1 +Synopsis: CAES Language for Synchronous Hardware +Description: + CλaSH (pronounced ‘clash’) is a functional hardware description language that + borrows both its syntax and semantics from the functional programming language + Haskell. The merits of using a functional language to describe hardware comes + from the fact that combinational circuits can be directly modeled as + mathematical functions and that functional languages lend themselves very well + at describing and (de-)composing mathematical functions. + . + This package provides: + . + * CλaSH Compiler binary using GHC/Haskell as a frontend +Homepage: http://christiaanb.github.io/clash2 +bug-reports: http://github.com/christiaanb/clash2/issues +License: OtherLicense +License-file: LICENSE +Author: Christiaan Baaij +Maintainer: Christiaan Baaij +Copyright: Copyright (c) 2012-2014 University of Twente +Category: Hardware +Build-type: Simple + +Extra-source-files: README.md, + src-bin/HsVersions.h + src-bin/PosixSource.h + +Data-files: primitives/clash.bit.json, + primitives/clash.prelude.json, + primitives/clash.promoted.nat.json, + primitives/clash.signal.json, + primitives/clash.sized.signed.json, + primitives/clash.sized.unsigned.json, + primitives/clash.sized.vector.json, + primitives/ghc.base.json, + primitives/ghc.classes.json, + primitives/ghc.cstring.json, + primitives/ghc.err.json, + primitives/ghc.integer.type.json, + primitives/ghc.prim.json, + primitives/ghc.real.json, + primitives/ghc.typelits.json, + primitives/ghc.types.json, + primitives/unsafe.coerce.json + +Cabal-version: >=1.10 + +source-repository head + type: git + location: git@github.com:christiaanb/clash2.git + +Flag standalone + Description: Build compiler for non-cabal installation + Default: False + +Executable clash + HS-Source-Dirs: src-ghc src-bin + Main-Is: Main.hs + + default-language: Haskell2010 + GHC-Options: -Wall -fno-warn-name-shadowing + CPP-Options: -DGHCI + default-extensions: ForeignFunctionInterface + UnboxedTuples + FlexibleInstances + MagicHash + CPP + PatternGuards + NondecreasingIndentation + + Build-Depends: array >= 0.4, + base >= 4.3.1.0 && < 5, + bytestring >= 0.9, + clash-lib >= 0.2.1, + clash-prelude >= 0.2, + directory >= 1.2, + filepath >= 1.3, + ghc >= 7.8, + process >= 1.2, + hashable >= 1.1.2.3, + haskeline >= 0.7.0.3, + lens >= 4.0.5, + mtl >= 2.1.1, + text >= 0.11.3.1, + transformers >= 0.3, + unbound >= 0.4.0.2, + unordered-containers >= 0.2.1.0 + + if os(windows) + Build-Depends: Win32 + else + Build-Depends: unix + + C-Sources: src-bin/hschooks.c + + Other-Modules: InteractiveUI + GhciMonad + GhciTags + + CLaSH.GHC.Compat.DynFlags + CLaSH.GHC.Compat.FastString + CLaSH.GHC.Compat.GHC + CLaSH.GHC.Compat.Outputable + CLaSH.GHC.Compat.PrelNames + CLaSH.GHC.Compat.TyCon + CLaSH.GHC.GenerateBindings + CLaSH.GHC.GHC2Core + CLaSH.GHC.LoadInterfaceFiles + CLaSH.GHC.LoadModules + CLaSH.GHC.NetlistTypes + + if flag(standalone) + CPP-Options: -DSTANDALONE + else + Build-Depends: ghc-paths + Other-Modules: Paths_clash_ghc diff --git a/primitives/clash.bit.json b/primitives/clash.bit.json new file mode 100644 --- /dev/null +++ b/primitives/clash.bit.json @@ -0,0 +1,26 @@ +[ { "BlackBox" : + { "name" : "CLaSH.Bit.eqBit" + , "templateE" : "~ARG[0] = ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Bit.bAnd" + , "templateE" : "~ARG[0] and ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Bit.bOr" + , "templateE" : "~ARG[0] or ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Bit.bXor" + , "templateE" : "~ARG[0] xor ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Bit.bNot" + , "templateE" : "not ~ARG[0]" + } + } +] diff --git a/primitives/clash.prelude.json b/primitives/clash.prelude.json new file mode 100644 --- /dev/null +++ b/primitives/clash.prelude.json @@ -0,0 +1,26 @@ +[ { "BlackBox" : + { "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 +begin + ~SYM[2] <= ~ARG[6]; + + process(~CLK[6]) + begin + if rising_edge(~CLK[6]) then + if ~ARG[5] then + ~SYM[1](to_integer(~ARG[3])) <= ~SYM[2]; + end if; + ~SYM[3] <= ~SYM[1](to_integer(~ARG[4])); + end if; + end process; + + ~RESULT <= ~SYM[3]; +end block;" + } + } +] diff --git a/primitives/clash.promoted.nat.json b/primitives/clash.promoted.nat.json new file mode 100644 --- /dev/null +++ b/primitives/clash.promoted.nat.json @@ -0,0 +1,11 @@ +[ { "BlackBox" : + { "name" : "CLaSH.Promoted.Nat.SNat" + , "templateE" : "~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Promoted.Nat.fromSNat" + , "templateE" : "~LIT[0]" + } + } +] diff --git a/primitives/clash.signal.json b/primitives/clash.signal.json new file mode 100644 --- /dev/null +++ b/primitives/clash.signal.json @@ -0,0 +1,45 @@ +[ { "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" + } + } +] diff --git a/primitives/clash.sized.signed.json b/primitives/clash.sized.signed.json new file mode 100644 --- /dev/null +++ b/primitives/clash.sized.signed.json @@ -0,0 +1,190 @@ +[ { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.eqS" + , "templateE" : "~ARG[0] = ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.gtS" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.ltS" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.geS" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.leS" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.minBoundS" + , "templateE" : "signed'((~LIT[0]-1) => '1', (~LIT[0]-2) downto 0 => '0')" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.maxBoundS" + , "templateE" : "signed'((~LIT[0]-1) => '0', (~LIT[0]-2) downto 0 => '1')" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.plusS" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.minS" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.timesS" + , "templateE" : "resize(~ARG[1] * ~ARG[2], ~LIT[0])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.negateS" + , "templateE" : "-~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.absS" + , "templateE" : "abs ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.fromIntegerS" + , "templateE" : "to_signed(~ARG[1], ~LIT[0])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.quotS" + , "templateE" : "~ARG[1] / ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.remS" + , "templateE" : "~ARG[1] rem ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.divS" + , "templateD" : +"~SYM[0]_divS : block + signal ~SYM[1] : ~TYP[1]; + signal ~SYM[2] : ~TYP[2]; + signal ~SYM[3] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + ~SYM[2] <= ~ARG[2]; + ~SYM[3] <= ~SYM[1] / ~SYM[2]; + ~RESULT <= ~SYM[3] - to_signed(1,~LIT[0]) when ~SYM[1](~SYM[1]'high) = not (~SYM[2](~SYM[2]'high)) else + ~SYM[3]; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.modS" + , "templateE" : "~ARG[1] mod ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.toIntegerS" + , "templateE" : "to_integer(~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.andS" + , "templateE" : "~ARG[1] and ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.orS" + , "templateE" : "~ARG[1] or ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.xorS" + , "templateE" : "~ARG[1] xor ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.complementS" + , "templateE" : "not ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.bitS" + , "templateD" : +"~SYM[0]_bitS : block + signal ~SYM[1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + process(~SYM[1]) + variable ~SYM[2] : ~TYPO; + begin + ~SYM[2] := (others => '0'); + ~SYM[2](~SYM[1]) := '1'; + ~RESULT <= ~SYM[2]; + end process; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.testBitS" + , "templateD" : +"~SYM[0]_testBitS : block + signal ~SYM[1] : ~TYP[0]; +begin + ~SYM[1] <= ~ARG[0]; + ~RESULT <= ~SYM[1](~ARG[1]) = '1'; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.shiftLS" + , "templateE" : "shift_left(~ARG[1],~ARG[2])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.shiftRS" + , "templateE" : "shift_right(~ARG[1],~ARG[2])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.rotateLS" + , "templateE" : "rotate_left(~ARG[1],~ARG[2])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.rotateRS" + , "templateE" : "rotate_right(~ARG[1],~ARG[2])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.finiteBitSizeS" + , "templateE" : "~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.toBitVector" + , "templateE" : "std_logic_vector(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.fromBitVector" + , "templateE" : "signed(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Signed.resizeS" + , "templateE" : "resize(~ARG[2],~LIT[1])" + } + } +] diff --git a/primitives/clash.sized.unsigned.json b/primitives/clash.sized.unsigned.json new file mode 100644 --- /dev/null +++ b/primitives/clash.sized.unsigned.json @@ -0,0 +1,159 @@ +[ { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.eqU" + , "templateE" : "~ARG[0] = ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.gtU" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.ltU" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.geU" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.leU" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.maxBoundU" + , "templateE" : "unsigned'((~LIT[0]-1) downto 0 => '1')" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.plusU" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.minU" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.timesU" + , "templateE" : "resize(~ARG[1] * ~ARG[2], ~LIT[0])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.fromIntegerU" + , "templateE" : "to_unsigned(~ARG[1], ~LIT[0])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.quotU" + , "templateE" : "~ARG[1] / ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.remU" + , "templateE" : "~ARG[1] rem ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.modU" + , "templateE" : "~ARG[1] mod ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.toIntegerU" + , "templateE" : "to_integer(~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.andU" + , "templateE" : "~ARG[1] and ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.orU" + , "templateE" : "~ARG[1] or ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.xorU" + , "templateE" : "~ARG[1] xor ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.complementU" + , "templateE" : "not ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.bitU" + , "templateD" : +"~SYM[0]_bitU : block + signal ~SYM[1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + process(~SYM[1]) + variable ~SYM[2] : ~TYPO; + begin + ~SYM[2] := (others => '0'); + ~SYM[2](~SYM[1]) := '1'; + ~RESULT <= ~SYM[2]; + end process; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.testBitU" + , "templateD" : +"~SYM[0]_testBitU : block + signal ~SYM[1] : ~TYP[0]; +begin + ~SYM[1] <= ~ARG[0]; + ~RESULT <= ~SYM[1](~ARG[1]) = '1'; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.shiftLU" + , "templateE" : "shift_left(~ARG[1],~ARG[2])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.shiftRU" + , "templateE" : "shift_right(~ARG[1],~ARG[2])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.rotateLU" + , "templateE" : "rotate_left(~ARG[1],~ARG[2])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.rotateRU" + , "templateE" : "rotate_right(~ARG[1],~ARG[2])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.finiteBitSizeU" + , "templateE" : "~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.toBitVector" + , "templateE" : "std_logic_vector(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.fromBitVector" + , "templateE" : "unsigned(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Unsigned.resizeU" + , "templateE" : "resize(~ARG[1],~LIT[0])" + } + } +] diff --git a/primitives/clash.sized.vector.json b/primitives/clash.sized.vector.json new file mode 100644 --- /dev/null +++ b/primitives/clash.sized.vector.json @@ -0,0 +1,424 @@ +[ { "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;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vtail" + , "templateD" : +"~SYM[0]_vtail : block + signal ~SYM[1] : ~TYP[0]; +begin + ~SYM[1] <= ~ARG[0]; + ~RESULT <= ~SYM[1]((~SYM[1]'high)-1 downto 0); +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vlast" + , "templateD" : +"~SYM[0]_vlast : block + signal ~SYM[1] : ~TYP[0]; +begin + ~SYM[1] <= ~ARG[0]; + ~RESULT <= ~SYM[1](0); +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vinit" + , "templateD" : +"~SYM[0]_vinit : block + signal ~SYM[1] : ~TYP[0]; +begin + ~SYM[1] <= ~ARG[0]; + ~RESULT <= ~SYM[1](~SYM[1]'high downto 1); +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.shiftIntoL" + , "templateD" : +"~SYM[0]_shiftIntoL : block + signal ~SYM[1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + ~RESULT <= ~ARG[0] & ~SYM[1](~SYM[1]'high downto 1); +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.snoc" + , "templateE" : "~ARG[1] & ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.shiftIntoR" + , "templateD" : +"~SYM[0]_shiftIntoR : block + signal ~SYM[1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + ~RESULT <= ~SYM[1]((~SYM[1]'high)-1 downto 0) & ~ARG[0]; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vappend" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vsplit" + , "templateD" : +"~SYM[0]_vsplit : block + signal ~SYM[1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + ~RESULT <= (~SYM[1](~SYM[1]'high downto ~LIT[0]),~SYM[1](~LIT[0]-1 downto 0)); +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vconcat" + , "templateD" : +"~SYM[0]_vconcat : block + signal ~SYM[1] : ~TYP[0]; +begin + ~SYM[1] <= ~ARG[0]; + ~SYM[2]_vconcat : for ~SYM[3] in ~ARG[0]'high downto 0 generate + begin + ~RESULT((~SYM[3] * ~SYM[1](0)'length) + ~SYM[1](0)'high) downto (~SYM[3] * ~SYM[1](0)'length)) <= ~SYM[1](~SYM[3]); + end generate; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vunconcat" + , "templateD" : +"~SYM[0]_vunconcat : block + signal ~SYM[1] : ~TYP[2]; +begin + ~SYM[1] <= ~ARG[2]; + ~SYM[2]_vunconcat : for ~SYM[3] in ~RESULT'high downto 0 generate + begin + ~RESULT(~SYM[3]) <= ~SYM[1]((~SYM[3] * ~RESULT(0)'length) + ~RESULT(0)'high) downto (~SYM[3] * ~RESULT(0)'length)); + end generate; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vmerge" + , "templateD" : +"~SYM[0]_vmerge : block + signal ~SYM[1] : ~TYP[0]; + signal ~SYM[2] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[0]; + ~SYM[2] <= ~ARG[1]; + + ~SYM[3]_vmerge : for ~SYM[4] in ~SYM[1]'high downto 0 generate + begin + ~RESULT(2*~SYM[4]+1) <= ~SYM[1](~SYM[4]); + ~RESULT(2*~SYM[4]) <= ~SYM[2](~SYM[4]); + end generate; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vreverse" + , "templateD" : +"~SYM[0]_vreverse : block + signal ~SYM[1] : ~TYP[0]; +begin + ~SYM[1] <= ~ARG[0]; + + process(~SYM[1]) + begin + for ~SYM[2] in ~SYM[1]'range loop + ~RESULT(~SYM[1]'high - ~SYM[2]) <= ~SYM[1](~SYM[2]); + end loop; + end process; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vmap" + , "templateD" : +"~SYM[0]_vmap : block + signal ~SYM[1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + + ~SYM[2]_vmap : for ~SYM[3] in ~RESULT'high downto 0 generate + begin + ~INST 0 + ~OUTPUT <= ~RESULT(~SYM[3])~ + ~INPUT <= ~SYM[1](~SYM[3])~ + ~INST + end generate; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vzipWith" + , "templateD" : +"~SYM[0]_vzipWith : block + signal ~SYM[1] : ~TYP[1]; + signal ~SYM[2] : ~TYP[2]; +begin + ~SYM[1] <= ~ARG[1]; + ~SYM[2] <= ~ARG[2]; + + ~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])~ + ~INST + end generate; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vfoldr" + , "templateD" : +"~SYM[0]_vfoldr : block + type ~SYM[7] is array (natural range <>) of ~TYP[1]; + signal ~SYM[6] : ~TYP[2]; + signal ~SYM[1] : ~SYM[7](~SYM[6]'high downto 0); +begin + ~SYM[1](0) <= ~ARG[1]; + ~SYM[6] <= ~ARG[2]; + + ~SYM[2]_generate : for ~SYM[3] in 0 to ~SYM[6]'high generate + 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])~ + ~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])~ + ~INST + end generate; + end generate; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vfoldl" + , "templateD" : +"~SYM[0]_vfoldl : block + type ~SYM[7] is array (natural range <>) of ~TYP[1]; + signal ~SYM[6] : ~TYP[2]; + signal ~SYM[1] : ~SYM[7](~SYM[6]'high downto 0); +begin + ~SYM[1](~SYM[1]'high) <= ~ARG[1]; + ~SYM[6] <= ~ARG[2]; + + ~SYM[2]_generate : for ~SYM[3] in ~SYM[6]'high downto 0 generate + 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])~ + ~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])~ + ~INST + end generate; + end generate; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vfoldr1" + , "templateD" : +"~SYM[0]_vfoldr1 : block + signal ~SYM[1] : ~TYP[1]; + signal ~SYM[2] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + ~SYM[2](0) <= SYM[1](0); + + ~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)~ + ~INST + end generate; + + ~RESULT <= ~SYM[2](~SYM[2]'high); +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vzip" + , "templateD" : +"~SYM[0]_vzip : block + signal ~SYM[1] : ~TYP[0]; + signal ~SYM[2] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[0]; + ~SYM[2] <= ~ARG[1]; + + ~SYM[3]_vzip : for ~SYM[4] in ~RESULT'high downto 0 generate + begin + ~RESULT(~SYM[4]) <= (~SYM[1](~SYM[4]),~SYM[2](~SYM[4])); + end generate; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vunzip" + , "templateD" : +"~SYM[0]_vunzip : block + signal ~SYM[1] : ~TYP[0]; +begin + ~SYM[1] <= ~ARG[0]; + + ~SYM[2]_vunzip : for ~SYM[3] in ~RESULT'high downto 0 generate + begin + ~RESULT.~TYPO_sel0(~SYM[3]) <= ~SYM[1](~SYM[3]).~TYP[0]_sel0; + ~RESULT.~TYPO_sel1(~SYM[3]) <= ~SYM[1](~SYM[3]).~TYP[0]_sel1; + end generate; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vindex_integer" + , "templateD" : +"~SYM[0]_vindex_integer : block + signal ~SYM[1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + ~RESULT <= ~SYM[1](~ARG[2]); +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.maxIndex" + , "templateD" : +"~SYM[0]_maxIndex : block + signal ~SYM[1] : ~TYP[1]; +begin + ~RESULT <= ~SYM[1]'high; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vreplace_integer" + , "templateD" : +"~SYM[0]_vreplace_integer : block + signal ~SYM[1] : ~TYP[1]; + signal ~SYM[2] : ~TYP[2] := ~DEFAULT[2]; + signal ~SYM[3] : ~TYP[3]; +begin + ~SYM[1] <= ~ARG[1]; + ~SYM[2] <= ~ARG[2]; + ~SYM[3] <= ~ARG[3]; + process(~SYM[1],~SYM[2],~SYM[3]) + variable ~SYM[4] : ~TYP[1]; + begin + ~SYM[4] := ~SYM[1]; + ~SYM[4](~SYM[2]) := ~SYM[3]; + ~RESULT <= ~SYM[4]; + end process; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vtake" + , "templateD" : +"~SYM[0]_vtake : block + signal ~SYM[1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + ~RESULT <= ~SYM[1](~SYM[1]'high downto (~SYM[1]'length - ~LIT[0])); +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vdrop" + , "templateD" : +"~SYM[0]_vdrop : block + signal ~SYM[1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + ~RESULT <= ~SYM[1]((~SYM[1]'high - ~LIT[0]) downto 0); +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vexact" + , "templateD" : +"~SYM[0]_vexact : block + signal ~SYM[1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[1]; + ~RESULT <= ~SYM[1](~LIT[0]); +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vselect" + , "templateD" : +"~SYM[0]_vselect : block + signal ~SYM[1] : ~TYP[3]; +begin + ~SYM[1] <= ~ARG[3]; + ~SYM[2]_vselect : for ~SYM[3] in 0 to ~RESULT'high generate + begin + ~RESULT(~RESULT'high - ~SYM[3]) <= ~SYM[1](~SYM[1]'high - (~LIT[0]+(~LIT[1]*~SYM[3]))); + end generate; +end block;" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.vcopy" + , "templateE" : "~TYPMO'((~LIT[0] - 1) downto 0 => ~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "CLaSH.Sized.Vector.viterate" + , "templateD" : +"~SYM[0]_viterate : for ~SYM[1] in ~RESULT'high downto 0 generate +begin + ~SYM[2]_generate : if ~SYM[1] = (~RESULT'high) generate + begin + ~RESULT(~SYM[1]) <= ~ARG[2]; + end generate; + + ~SYM[3]_generate : if ~SYM[1] /= (~RESULT'high) generate + begin + ~INST 0 + ~OUTPUT <= ~RESULT(~SYM[1])~ + ~INPUT <= ~RESULT(~SYM[1]+1)~ + ~INST + end generate; +end generate;" + } + } +] diff --git a/primitives/ghc.base.json b/primitives/ghc.base.json new file mode 100644 --- /dev/null +++ b/primitives/ghc.base.json @@ -0,0 +1,16 @@ +[ { "BlackBox" : + { "name" : "GHC.Base.plusInt" + , "templateE" : "~ARG[0] + ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.timesInt" + , "templateE" : "~ARG[0] * ~ARG[1]" + } + } +, { "Primitive" : + { "name" : "GHC.Base.$" + , "primType" : "Function" + } + } +] diff --git a/primitives/ghc.classes.json b/primitives/ghc.classes.json new file mode 100644 --- /dev/null +++ b/primitives/ghc.classes.json @@ -0,0 +1,46 @@ +[ { "BlackBox" : + { "name" : "GHC.Classes.eqInt" + , "templateE" : "~ARG[0] = ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.neInt" + , "templateE" : "~ARG[0] /= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.gtInt" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.geInt" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.ltInt" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.leInt" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.&&" + , "templateE" : "~ARG[0] and ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.||" + , "templateE" : "~ARG[0] or ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.not" + , "templateE" : "not ~ARG[0]" + } + } +] diff --git a/primitives/ghc.cstring.json b/primitives/ghc.cstring.json new file mode 100644 --- /dev/null +++ b/primitives/ghc.cstring.json @@ -0,0 +1,6 @@ +[ { "Primitive" : + { "name" : "GHC.CString.unpackCString#" + , "primType" : "Function" + } + } +] diff --git a/primitives/ghc.err.json b/primitives/ghc.err.json new file mode 100644 --- /dev/null +++ b/primitives/ghc.err.json @@ -0,0 +1,11 @@ +[ { "BlackBox" : + { "name" : "GHC.Err.divZeroError" + , "templateE" : "~DEFAULTO" + } + } +, { "BlackBox" : + { "name" : "GHC.Err.error" + , "templateE" : "~DEFAULTO" + } + } +] diff --git a/primitives/ghc.integer.type.json b/primitives/ghc.integer.type.json new file mode 100644 --- /dev/null +++ b/primitives/ghc.integer.type.json @@ -0,0 +1,99 @@ +[ { "BlackBox" : + { "name" : "GHC.Integer.Type.remInteger" + , "templateE" : "~ARG[0] rem ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.quotInteger" + , "templateE" : "~ARG[0] div ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.divInteger" + , "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.Integer.Type.modInteger" + , "templateE" : "~ARG[0] mod ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.eqInteger" + , "templateE" : "~ARG[0] = ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.eqInteger#" + , "templateE" : "~ARG[0] = ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.neqInteger" + , "templateE" : "~ARG[0] /= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.leInteger" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.gtInteger" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.ltInteger" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.geInteger" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.absInteger" + , "templateE" : "abs ~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.integerToInt" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.eqInteger#" + , "templateE" : "~ARG[0] = ~ARG[1]" + } + } +] diff --git a/primitives/ghc.prim.json b/primitives/ghc.prim.json new file mode 100644 --- /dev/null +++ b/primitives/ghc.prim.json @@ -0,0 +1,26 @@ +[ { "BlackBox" : + { "name" : "GHC.Prim.tagToEnum#" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.negateInt#" + , "templateE" : "-~ARG[0]" + } + } +, { "BlackBox" : + { "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]" + } + } +] diff --git a/primitives/ghc.real.json b/primitives/ghc.real.json new file mode 100644 --- /dev/null +++ b/primitives/ghc.real.json @@ -0,0 +1,6 @@ +[ { "BlackBox" : + { "name" : "GHC.Real.divZeroError" + , "templateE" : "~DEFAULTO" + } + } +] diff --git a/primitives/ghc.typelits.json b/primitives/ghc.typelits.json new file mode 100644 --- /dev/null +++ b/primitives/ghc.typelits.json @@ -0,0 +1,6 @@ +[ { "BlackBox" : + { "name" : "GHC.TypeLits.natVal" + , "templateE" : "~LIT[0]" + } + } +] diff --git a/primitives/ghc.types.json b/primitives/ghc.types.json new file mode 100644 --- /dev/null +++ b/primitives/ghc.types.json @@ -0,0 +1,6 @@ +[ { "Primitive" : + { "name" : "GHC.Types.Eq#" + , "primType" : "Constructor" + } + } +] diff --git a/primitives/unsafe.coerce.json b/primitives/unsafe.coerce.json new file mode 100644 --- /dev/null +++ b/primitives/unsafe.coerce.json @@ -0,0 +1,6 @@ +[ { "BlackBox" : + { "name" : "Unsafe.Coerce.unsafeCoerce" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/src-bin/GhciMonad.hs b/src-bin/GhciMonad.hs new file mode 100644 --- /dev/null +++ b/src-bin/GhciMonad.hs @@ -0,0 +1,389 @@ +{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +----------------------------------------------------------------------------- +-- +-- Monadery code used in InteractiveUI +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module GhciMonad ( + GHCi(..), startGHCi, + GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState, + GHCiOption(..), isOptionSet, setOption, unsetOption, + Command, + BreakLocation(..), + TickArray, + getDynFlags, + + runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs, + + printForUser, printForUserPartWay, prettyLocations, + initInterpBuffering, turnOffBuffering, flushInterpBuffers, + ) where + +#include "HsVersions.h" + +import qualified GHC +import GhcMonad hiding (liftIO) +import Outputable hiding (printForUser, printForUserPartWay) +import qualified Outputable +import Util +import DynFlags +import HscTypes +import SrcLoc +import Module +import ObjLink +import Linker + +import Exception +import Numeric +import Data.Array +import Data.Int ( Int64 ) +import Data.IORef +import System.CPUTime +import System.Environment +import System.IO +import Control.Applicative (Applicative(..)) +import Control.Monad +import GHC.Exts + +import System.Console.Haskeline (CompletionFunc, InputT) +import qualified System.Console.Haskeline as Haskeline +import Control.Monad.Trans.Class +import Control.Monad.IO.Class + +----------------------------------------------------------------------------- +-- GHCi monad + +type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi) + +data GHCiState = GHCiState + { + progname :: String, + args :: [String], + prompt :: String, + prompt2 :: String, + editor :: String, + stop :: String, + options :: [GHCiOption], + line_number :: !Int, -- input line + break_ctr :: !Int, + breaks :: ![(Int, BreakLocation)], + tickarrays :: ModuleEnv TickArray, + -- tickarrays caches the TickArray for loaded modules, + -- so that we don't rebuild it each time the user sets + -- a breakpoint. + -- available ghci commands + ghci_commands :: [Command], + -- ":" at the GHCi prompt repeats the last command, so we + -- remember is here: + last_command :: Maybe Command, + cmdqueue :: [String], + + remembered_ctx :: [InteractiveImport], + -- the imports that the user has asked for, via import + -- declarations and :module commands. This list is + -- persistent over :reloads (but any imports for modules + -- that are not loaded are temporarily ignored). After a + -- :load, all the home-package imports are stripped from + -- this list. + + -- See bugs #2049, #1873, #1360 + + transient_ctx :: [InteractiveImport], + -- An import added automatically after a :load, usually of + -- the most recently compiled module. May be empty if + -- there are no modules loaded. This list is replaced by + -- :load, :reload, and :add. In between it may be modified + -- by :module. + + ghc_e :: Bool, -- True if this is 'ghc -e' (or runghc) + + -- help text to display to a user + short_help :: String, + long_help :: String + } + +type TickArray = Array Int [(BreakIndex,SrcSpan)] + +data GHCiOption + = ShowTiming -- show time/allocs after evaluation + | ShowType -- show the type of expressions + | RevertCAFs -- revert CAFs after every evaluation + | Multiline -- use multiline commands + deriving Eq + +data BreakLocation + = BreakLocation + { breakModule :: !GHC.Module + , breakLoc :: !SrcSpan + , breakTick :: {-# UNPACK #-} !Int + , onBreakCmd :: String + } + +instance Eq BreakLocation where + loc1 == loc2 = breakModule loc1 == breakModule loc2 && + breakTick loc1 == breakTick loc2 + +prettyLocations :: [(Int, BreakLocation)] -> SDoc +prettyLocations [] = text "No active breakpoints." +prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs + +instance Outputable BreakLocation where + ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> + if null (onBreakCmd loc) + then empty + else doubleQuotes (text (onBreakCmd loc)) + +recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int) +recordBreak brkLoc = do + st <- getGHCiState + let oldActiveBreaks = breaks st + -- don't store the same break point twice + case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of + (nm:_) -> return (True, nm) + [] -> do + let oldCounter = break_ctr st + newCounter = oldCounter + 1 + setGHCiState $ st { break_ctr = newCounter, + breaks = (oldCounter, brkLoc) : oldActiveBreaks + } + return (False, oldCounter) + +newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a } + +reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a +reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s + +reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a +reifyGHCi f = GHCi f' + where + -- f' :: IORef GHCiState -> Ghc a + f' gs = reifyGhc (f'' gs) + -- f'' :: IORef GHCiState -> Session -> IO a + f'' gs s = f (s, gs) + +startGHCi :: GHCi a -> GHCiState -> Ghc a +startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref + +instance Functor GHCi where + fmap = liftM + +instance Applicative GHCi where + pure = return + (<*>) = ap + +instance Monad GHCi where + (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s + return a = GHCi $ \_ -> return a + +getGHCiState :: GHCi GHCiState +getGHCiState = GHCi $ \r -> liftIO $ readIORef r +setGHCiState :: GHCiState -> GHCi () +setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s +modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi () +modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f + +liftGhc :: Ghc a -> GHCi a +liftGhc m = GHCi $ \_ -> m + +instance MonadIO GHCi where + liftIO = liftGhc . liftIO + +instance HasDynFlags GHCi where + getDynFlags = getSessionDynFlags + +instance GhcMonad GHCi where + setSession s' = liftGhc $ setSession s' + getSession = liftGhc $ getSession + +instance HasDynFlags (InputT GHCi) where + getDynFlags = lift getDynFlags + +instance GhcMonad (InputT GHCi) where + setSession = lift . setSession + getSession = lift getSession + +instance ExceptionMonad GHCi where + gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) + gmask f = + GHCi $ \s -> gmask $ \io_restore -> + let + g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s') + in + unGHCi (f g_restore) s + +instance Haskeline.MonadException Ghc where + controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let + run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s) + in fmap (flip unGhc s) $ f run' + +instance Haskeline.MonadException GHCi where + controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let + run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s) + in fmap (flip unGHCi s) $ f run' + +instance ExceptionMonad (InputT GHCi) where + gcatch = Haskeline.catch + gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_) + +isOptionSet :: GHCiOption -> GHCi Bool +isOptionSet opt + = do st <- getGHCiState + return (opt `elem` options st) + +setOption :: GHCiOption -> GHCi () +setOption opt + = do st <- getGHCiState + setGHCiState (st{ options = opt : filter (/= opt) (options st) }) + +unsetOption :: GHCiOption -> GHCi () +unsetOption opt + = do st <- getGHCiState + setGHCiState (st{ options = filter (/= opt) (options st) }) + +printForUser :: GhcMonad m => SDoc -> m () +printForUser doc = do + unqual <- GHC.getPrintUnqual + dflags <- getDynFlags + liftIO $ Outputable.printForUser dflags stdout unqual doc + +printForUserPartWay :: SDoc -> GHCi () +printForUserPartWay doc = do + unqual <- GHC.getPrintUnqual + dflags <- getDynFlags + liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc + +-- | Run a single Haskell expression +runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult) +runStmt expr step = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.handleSourceError (\e -> do GHC.printException e; + return Nothing) $ do + r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step + return (Just r) + +runDecls :: String -> GHCi [GHC.Name] +runDecls decls = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do + GHC.runDeclsWithLocation (progname st) (line_number st) decls + +resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult +resume canLogSpan step = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.resume canLogSpan step + +-- -------------------------------------------------------------------------- +-- timing & statistics + +timeIt :: InputT GHCi a -> InputT GHCi a +timeIt action + = do b <- lift $ isOptionSet ShowTiming + if not b + then action + else do allocs1 <- liftIO $ getAllocations + time1 <- liftIO $ getCPUTime + a <- action + allocs2 <- liftIO $ getAllocations + time2 <- liftIO $ getCPUTime + dflags <- getDynFlags + liftIO $ printTimes dflags (fromIntegral (allocs2 - allocs1)) + (time2 - time1) + return a + +foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 + -- defined in ghc/rts/Stats.c + +printTimes :: DynFlags -> Integer -> Integer -> IO () +printTimes dflags allocs psecs + = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float + secs_str = showFFloat (Just 2) secs + putStrLn (showSDoc dflags ( + parens (text (secs_str "") <+> text "secs" <> comma <+> + text (show allocs) <+> text "bytes"))) + +----------------------------------------------------------------------------- +-- reverting CAFs + +revertCAFs :: GHCi () +revertCAFs = do + liftIO rts_revertCAFs + s <- getGHCiState + when (not (ghc_e s)) $ liftIO turnOffBuffering + -- Have to turn off buffering again, because we just + -- reverted stdout, stderr & stdin to their defaults. + +foreign import ccall "revertCAFs" rts_revertCAFs :: IO () + -- Make it "safe", just in case + +----------------------------------------------------------------------------- +-- To flush buffers for the *interpreted* computation we need +-- to refer to *its* stdout/stderr handles + +GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ()) +GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ()) +GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ()) + +-- After various attempts, I believe this is the least bad way to do +-- what we want. We know look up the address of the static stdin, +-- stdout, and stderr closures in the loaded base package, and each +-- time we need to refer to them we cast the pointer to a Handle. +-- This avoids any problems with the CAF having been reverted, because +-- we'll always get the current value. +-- +-- The previous attempt that didn't work was to compile an expression +-- like "hSetBuffering stdout NoBuffering" into an expression of type +-- IO () and run this expression each time we needed it, but the +-- problem is that evaluating the expression might cache the contents +-- of the Handle rather than referring to it from its static address +-- each time. There's no safe workaround for this. + +initInterpBuffering :: Ghc () +initInterpBuffering = do -- make sure these are linked + dflags <- GHC.getSessionDynFlags + liftIO $ do + initDynLinker dflags + + -- ToDo: we should really look up these names properly, but + -- it's a fiddle and not all the bits are exposed via the GHC + -- interface. + mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure" + mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure" + mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure" + + let f ref (Just ptr) = writeIORef ref ptr + f _ Nothing = panic "interactiveUI:setBuffering2" + zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr] + [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] + +flushInterpBuffers :: GHCi () +flushInterpBuffers + = liftIO $ do getHandle stdout_ptr >>= hFlush + getHandle stderr_ptr >>= hFlush + +turnOffBuffering :: IO () +turnOffBuffering + = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr] + mapM_ (\h -> hSetBuffering h NoBuffering) hdls + +getHandle :: IORef (Ptr ()) -> IO Handle +getHandle ref = do + (Ptr addr) <- readIORef ref + case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval) + diff --git a/src-bin/GhciTags.hs b/src-bin/GhciTags.hs new file mode 100644 --- /dev/null +++ b/src-bin/GhciTags.hs @@ -0,0 +1,206 @@ +----------------------------------------------------------------------------- +-- +-- GHCi's :ctags and :etags commands +-- +-- (c) The GHC Team 2005-2007 +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module GhciTags ( + createCTagsWithLineNumbersCmd, + createCTagsWithRegExesCmd, + createETagsFileCmd +) where + +import Exception +import GHC +import GhciMonad +import Outputable + +-- ToDo: figure out whether we need these, and put something appropriate +-- into the GHC API instead +import Name (nameOccName) +import OccName (pprOccName) +import ConLike +import MonadUtils + +import Data.Function +import Data.Maybe +import Data.Ord +import Panic +import Data.List +import Control.Monad +import System.IO +import System.IO.Error + +----------------------------------------------------------------------------- +-- create tags file for currently loaded modules. + +createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd, + createETagsFileCmd :: String -> GHCi () + +createCTagsWithLineNumbersCmd "" = + ghciCreateTagsFile CTagsWithLineNumbers "tags" +createCTagsWithLineNumbersCmd file = + ghciCreateTagsFile CTagsWithLineNumbers file + +createCTagsWithRegExesCmd "" = + ghciCreateTagsFile CTagsWithRegExes "tags" +createCTagsWithRegExesCmd file = + ghciCreateTagsFile CTagsWithRegExes file + +createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS" +createETagsFileCmd file = ghciCreateTagsFile ETags file + +data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes + +ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi () +ghciCreateTagsFile kind file = do + createTagsFile kind file + +-- ToDo: +-- - remove restriction that all modules must be interpreted +-- (problem: we don't know source locations for entities unless +-- we compiled the module. +-- +-- - extract createTagsFile so it can be used from the command-line +-- (probably need to fix first problem before this is useful). +-- +createTagsFile :: TagsKind -> FilePath -> GHCi () +createTagsFile tagskind tagsFile = do + graph <- GHC.getModuleGraph + mtags <- mapM listModuleTags (map GHC.ms_mod graph) + either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags + case either_res of + Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e + Right _ -> return () + + +listModuleTags :: GHC.Module -> GHCi [TagInfo] +listModuleTags m = do + is_interpreted <- GHC.moduleIsInterpreted m + -- should we just skip these? + when (not is_interpreted) $ + let mName = GHC.moduleNameString (GHC.moduleName m) in + throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted")) + mbModInfo <- GHC.getModuleInfo m + case mbModInfo of + Nothing -> return [] + Just mInfo -> do + dflags <- getDynFlags + mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo + let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual + let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo + let localNames = filter ((m==) . nameModule) names + mbTyThings <- mapM GHC.lookupName localNames + return $! [ tagInfo dflags unqual exported kind name realLoc + | tyThing <- catMaybes mbTyThings + , let name = getName tyThing + , let exported = GHC.modInfoIsExportedName mInfo name + , let kind = tyThing2TagKind tyThing + , let loc = srcSpanStart (nameSrcSpan name) + , RealSrcLoc realLoc <- [loc] + ] + + where + tyThing2TagKind (AnId _) = 'v' + tyThing2TagKind (AConLike RealDataCon{}) = 'd' + tyThing2TagKind (AConLike PatSynCon{}) = 'p' + tyThing2TagKind (ATyCon _) = 't' + tyThing2TagKind (ACoAxiom _) = 'x' + + +data TagInfo = TagInfo + { tagExported :: Bool -- is tag exported + , tagKind :: Char -- tag kind + , tagName :: String -- tag name + , tagFile :: String -- file name + , tagLine :: Int -- line number + , tagCol :: Int -- column number + , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset + } + + +-- get tag info, for later translation into Vim or Emacs style +tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc + -> TagInfo +tagInfo dflags unqual exported kind name loc + = TagInfo exported kind + (showSDocForUser dflags unqual $ pprOccName (nameOccName name)) + (showSDocForUser dflags unqual $ ftext (srcLocFile loc)) + (srcLocLine loc) (srcLocCol loc) Nothing + + +collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ()) +-- ctags style with the Ex exresion being just the line number, Vim et al +collateAndWriteTags CTagsWithLineNumbers file tagInfos = do + let tags = unlines $ sort $ map showCTag tagInfos + tryIO (writeFile file tags) + +-- ctags style with the Ex exresion being a regex searching the line, Vim et al +collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al + tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos + let tags = unlines $ sort $ map showCTag $concat tagInfoGroups + tryIO (writeFile file tags) + +collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs + tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos + let tagGroups = map processGroup tagInfoGroups + tryIO (writeFile file $ concat tagGroups) + + where + processGroup [] = throwGhcException (CmdLineError "empty tag file group??") + processGroup group@(tagInfo:_) = + let tags = unlines $ map showETag group in + "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags + + +makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]] +makeTagGroupsWithSrcInfo tagInfos = do + let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos + mapM addTagSrcInfo groups + + where + addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??") + addTagSrcInfo group@(tagInfo:_) = do + file <- readFile $tagFile tagInfo + let sortedGroup = sortBy (comparing tagLine) group + return $ perFile sortedGroup 1 0 $ lines file + + perFile allTags@(tag:tags) cnt pos allLs@(l:ls) + | tagLine tag > cnt = + perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls + | tagLine tag == cnt = + tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs + perFile _ _ _ _ = [] + + +-- ctags format, for Vim et al +showCTag :: TagInfo -> String +showCTag ti = + tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++ + tagKind ti : ( if tagExported ti then "" else "\tfile:" ) + + where + tagCmd = + case tagSrcInfo ti of + Nothing -> show $tagLine ti + Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/" + + where + escapeSlashes '/' r = '\\' : '/' : r + escapeSlashes '\\' r = '\\' : '\\' : r + escapeSlashes c r = c : r + + +-- etags format, for Emacs/XEmacs +showETag :: TagInfo -> String +showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo, + tagSrcInfo = Just (srcLine,charPos) } + = take (colNo - 1) srcLine ++ tag + ++ "\x7f" ++ tag + ++ "\x01" ++ show lineNo + ++ "," ++ show charPos +showETag _ = throwGhcException (CmdLineError "missing source file info in showETag") + diff --git a/src-bin/HsVersions.h b/src-bin/HsVersions.h new file mode 100644 --- /dev/null +++ b/src-bin/HsVersions.h @@ -0,0 +1,44 @@ +#ifndef HSVERSIONS_H +#define HSVERSIONS_H + +/* Global variables may not work in other Haskell implementations, + * but we need them currently! so the conditional on GLASGOW won't do. */ +#if defined(__GLASGOW_HASKELL__) || !defined(__GLASGOW_HASKELL__) +#define GLOBAL_VAR(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.global (value); + +#define GLOBAL_VAR_M(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.globalM (value); +#endif + +#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else +#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else +#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $ + +-- Examples: Assuming flagSet :: String -> m Bool +-- +-- do { c <- getChar; MASSERT( isUpper c ); ... } +-- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... } +-- do { str <- getStr; ASSERTM( flagSet str ); .. } +-- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. } +-- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. } +#define MASSERT(e) ASSERT(e) return () +#define MASSERT2(e,msg) ASSERT2(e,msg) return () +#define ASSERTM(e) do { bool <- e; MASSERT(bool) } +#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) } +#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () } + +-- Useful for declaring arguments to be strict +#define STRICT1(f) f a | a `seq` False = undefined +#define STRICT2(f) f a b | a `seq` b `seq` False = undefined +#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined +#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined +#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined +#define STRICT6(f) f a b c d e f | a `seq` b `seq` c `seq` d `seq` e `seq` f `seq` False = undefined + +#endif /* HsVersions.h */ + diff --git a/src-bin/InteractiveUI.hs b/src-bin/InteractiveUI.hs new file mode 100644 --- /dev/null +++ b/src-bin/InteractiveUI.hs @@ -0,0 +1,3198 @@ +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +----------------------------------------------------------------------------- +-- +-- GHC Interactive User Interface +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module InteractiveUI ( + interactiveUI, + GhciSettings(..), + defaultGhciSettings, + ghciCommands, + ghciWelcomeMsg + ) where + +#include "HsVersions.h" + +-- GHCi +import qualified GhciMonad ( args, runStmt ) +import GhciMonad hiding ( args, runStmt ) +import GhciTags +import Debugger + +-- The GHC interface +import DynFlags +import GhcMonad ( modifySession ) +import qualified GHC +import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), + TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, + handleSourceError ) +import HsImpExp +import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, + setInteractivePrintName ) +import Module +import Name +import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap ) +import PprTyThing +import RdrName ( getGRE_NameQualifier_maybes ) +import SrcLoc +import qualified Lexer + +import StringBuffer +import UniqFM ( eltsUFM ) +import Outputable hiding ( printForUser, printForUserPartWay, bold ) + +-- Other random utilities +import BasicTypes hiding ( isTopLevel ) +import Config +import Digraph +import Encoding +import FastString +import Linker +import Maybes ( orElse, expectJust ) +import NameSet +import Panic hiding ( showException ) +import Util + +-- Haskell Libraries +import System.Console.Haskeline as Haskeline + +import Control.Applicative hiding (empty) +import Control.Monad as Monad +import Control.Monad.Trans.Class +import Control.Monad.IO.Class + +import Data.Array +import qualified Data.ByteString.Char8 as BS +import Data.Char +import Data.Function +import Data.IORef ( IORef, readIORef, writeIORef ) +import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, + partition, sort, sortBy ) +import Data.Maybe + +import Exception hiding (catch) + +import Foreign.C +import Foreign.Safe + +import System.Directory +import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) +import System.FilePath +import System.IO +import System.IO.Error +import System.IO.Unsafe ( unsafePerformIO ) +import System.Process +import Text.Printf +import Text.Read ( readMaybe ) + +#ifndef mingw32_HOST_OS +import System.Posix hiding ( getEnv ) +#else +import qualified System.Win32 +#endif + +import GHC.Exts ( unsafeCoerce# ) +import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) +import GHC.IO.Handle ( hFlushAll ) +import GHC.TopHandler ( topHandler ) + +import qualified CLaSH.Driver +import CLaSH.GHC.GenerateBindings +import CLaSH.GHC.NetlistTypes +import qualified CLaSH.Primitives.Util +import CLaSH.Rewrite.Types (DebugLevel(..)) + +#ifdef STANDALONE + +import qualified Control.Exception + +getDefPrimDir :: IO FilePath +getDefPrimDir = catchIO_ (getEnv "CLASH_PRIMDIR") (error "Environment variable \"CLASH_PRIMDIR\" undefined") + +catchIO_ :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO_ = Control.Exception.catch + +#else + +import Paths_clash_ghc +getDefPrimDir :: IO FilePath +getDefPrimDir = getDataFileName "primitives" + +#endif + +----------------------------------------------------------------------------- + +data GhciSettings = GhciSettings { + availableCommands :: [Command], + shortHelpText :: String, + fullHelpText :: String, + defPrompt :: String, + defPrompt2 :: String + } + +defaultGhciSettings :: GhciSettings +defaultGhciSettings = + GhciSettings { + availableCommands = ghciCommands, + shortHelpText = defShortHelpText, + fullHelpText = defFullHelpText, + defPrompt = default_prompt, + defPrompt2 = default_prompt2 + } + +ghciWelcomeMsg :: String +ghciWelcomeMsg = "CLaSHi, version " ++ cProjectVersion ++ + ": http://www.haskell.org/ghc/ :? for help" + +cmdName :: Command -> String +cmdName (n,_,_) = n + +GLOBAL_VAR(macros_ref, [], [Command]) + +ghciCommands :: [Command] +ghciCommands = [ + -- Hugs users are accustomed to :e, so make sure it doesn't overlap + ("?", keepGoing help, noCompletion), + ("add", keepGoingPaths addModule, completeFilename), + ("abandon", keepGoing abandonCmd, noCompletion), + ("break", keepGoing breakCmd, completeIdentifier), + ("back", keepGoing backCmd, noCompletion), + ("browse", keepGoing' (browseCmd False), completeModule), + ("browse!", keepGoing' (browseCmd True), completeModule), + ("cd", keepGoing' changeDirectory, completeFilename), + ("check", keepGoing' checkModule, completeHomeModule), + ("continue", keepGoing continueCmd, noCompletion), + ("complete", keepGoing completeCmd, noCompletion), + ("cmd", keepGoing cmdCmd, completeExpression), + ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename), + ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename), + ("def", keepGoing (defineMacro False), completeExpression), + ("def!", keepGoing (defineMacro True), completeExpression), + ("delete", keepGoing deleteCmd, noCompletion), + ("edit", keepGoing' editFile, completeFilename), + ("etags", keepGoing createETagsFileCmd, completeFilename), + ("force", keepGoing forceCmd, completeExpression), + ("forward", keepGoing forwardCmd, noCompletion), + ("help", keepGoing help, noCompletion), + ("history", keepGoing historyCmd, noCompletion), + ("info", keepGoing' (info False), completeIdentifier), + ("info!", keepGoing' (info True), completeIdentifier), + ("issafe", keepGoing' isSafeCmd, completeModule), + ("kind", keepGoing' (kindOfType False), completeIdentifier), + ("kind!", keepGoing' (kindOfType True), completeIdentifier), + ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), + ("list", keepGoing' listCmd, noCompletion), + ("module", keepGoing moduleCmd, completeSetModule), + ("main", keepGoing runMain, completeFilename), + ("print", keepGoing printCmd, completeExpression), + ("quit", quit, noCompletion), + ("reload", keepGoing' reloadModule, noCompletion), + ("run", keepGoing runRun, completeFilename), + ("script", keepGoing' scriptCmd, completeFilename), + ("set", keepGoing setCmd, completeSetOptions), + ("seti", keepGoing setiCmd, completeSeti), + ("show", keepGoing showCmd, completeShowOptions), + ("showi", keepGoing showiCmd, completeShowiOptions), + ("sprint", keepGoing sprintCmd, completeExpression), + ("step", keepGoing stepCmd, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), + ("type", keepGoing' typeOfExpr, completeExpression), + ("trace", keepGoing traceCmd, completeExpression), + ("undef", keepGoing undefineMacro, completeMacro), + ("unset", keepGoing unsetOptions, completeSetOptions), + ("vhdl", keepGoingPaths makeVHDL, completeHomeModuleOrFile) + ] + + +-- We initialize readline (in the interactiveUI function) to use +-- word_break_chars as the default set of completion word break characters. +-- This can be overridden for a particular command (for example, filename +-- expansion shouldn't consider '/' to be a word break) by setting the third +-- entry in the Command tuple above. +-- +-- NOTE: in order for us to override the default correctly, any custom entry +-- must be a SUBSET of word_break_chars. +word_break_chars :: String +word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" + specials = "(),;[]`{}" + spaces = " \t\n" + in spaces ++ specials ++ symbols + +flagWordBreakChars :: String +flagWordBreakChars = " \t\n" + + +keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool) +keepGoing a str = keepGoing' (lift . a) str + +keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool +keepGoing' a str = a str >> return False + +keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool) +keepGoingPaths a str + = do case toArgs str of + Left err -> liftIO $ hPutStrLn stderr err + Right args -> a args + return False + +defShortHelpText :: String +defShortHelpText = "use :? for help.\n" + +defFullHelpText :: String +defFullHelpText = + " Commands available from the prompt:\n" ++ + "\n" ++ + " evaluate/run \n" ++ + " : repeat last command\n" ++ + " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ + " :add [*] ... add module(s) to the current target set\n" ++ + " :browse[!] [[*]] display the names defined by module \n" ++ + " (!: more details; *: all top-level names)\n" ++ + " :cd change directory to \n" ++ + " :cmd run the commands returned by ::IO String\n" ++ + " :complete [] list completions for partial input string\n" ++ + " :ctags[!] [] create tags file for Vi (default: \"tags\")\n" ++ + " (!: use regex instead of line number)\n" ++ + " :def define command : (later defined command has\n" ++ + " precedence, :: is always a builtin command)\n" ++ + " :edit edit file\n" ++ + " :edit edit last module\n" ++ + " :etags [] create tags file for Emacs (default: \"TAGS\")\n" ++ + " :help, :? display this list of commands\n" ++ + " :info[!] [ ...] display information about the given names\n" ++ + " (!: do not filter instances)\n" ++ + " :issafe [] display safe haskell information of module \n" ++ + " :kind[!] show the kind of \n" ++ + " (!: also print the normalised type)\n" ++ + " :load [*] ... load module(s) and their dependents\n" ++ + " :main [ ...] run the main function with the given arguments\n" ++ + " :module [+/-] [*] ... set the context for expression evaluation\n" ++ + " :quit exit GHCi\n" ++ + " :reload reload the current module set\n" ++ + " :run function [ ...] run the function with the given arguments\n" ++ + " :script run the script \n" ++ + " :type show the type of \n" ++ + " :undef undefine user-defined command :\n" ++ + " :! run the shell command \n" ++ + " :vhdl synthesize currently loaded module to vhdl\n" ++ + " :vhdl [] synthesize specified modules/files to vhdl\n" ++ + "\n" ++ + " -- Commands for debugging:\n" ++ + "\n" ++ + " :abandon at a breakpoint, abandon current computation\n" ++ + " :back go back in the history (after :trace)\n" ++ + " :break [] [] set a breakpoint at the specified location\n" ++ + " :break set a breakpoint on the specified function\n" ++ + " :continue resume after a breakpoint\n" ++ + " :delete delete the specified breakpoint\n" ++ + " :delete * delete all breakpoints\n" ++ + " :force print , forcing unevaluated parts\n" ++ + " :forward go forward in the history (after :back)\n" ++ + " :history [] after :trace, show the execution history\n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ + " :print [ ...] prints a value without forcing its computation\n" ++ + " :sprint [ ...] simplifed version of :print\n" ++ + " :step single-step after stopping at a breakpoint\n"++ + " :step single-step into \n"++ + " :steplocal single-step within the current top-level binding\n"++ + " :stepmodule single-step restricted to the current module\n"++ + " :trace trace after stopping at a breakpoint\n"++ + " :trace evaluate with tracing on (see :history)\n"++ + + "\n" ++ + " -- Commands for changing settings:\n" ++ + "\n" ++ + " :set