clash-ghc (empty) → 0.2.1
raw patch · 39 files changed
+7123/−0 lines, 39 filesdep +Win32dep +arraydep +basesetup-changed
Dependencies added: Win32, array, base, bytestring, clash-lib, clash-prelude, directory, filepath, ghc, ghc-paths, hashable, haskeline, lens, mtl, process, text, transformers, unbound, unix, unordered-containers
Files
- LICENSE +22/−0
- README.md +1/−0
- Setup.hs +2/−0
- clash-ghc.cabal +117/−0
- primitives/clash.bit.json +26/−0
- primitives/clash.prelude.json +26/−0
- primitives/clash.promoted.nat.json +11/−0
- primitives/clash.signal.json +45/−0
- primitives/clash.sized.signed.json +190/−0
- primitives/clash.sized.unsigned.json +159/−0
- primitives/clash.sized.vector.json +424/−0
- primitives/ghc.base.json +16/−0
- primitives/ghc.classes.json +46/−0
- primitives/ghc.cstring.json +6/−0
- primitives/ghc.err.json +11/−0
- primitives/ghc.integer.type.json +99/−0
- primitives/ghc.prim.json +26/−0
- primitives/ghc.real.json +6/−0
- primitives/ghc.typelits.json +6/−0
- primitives/ghc.types.json +6/−0
- primitives/unsafe.coerce.json +6/−0
- src-bin/GhciMonad.hs +389/−0
- src-bin/GhciTags.hs +206/−0
- src-bin/HsVersions.h +44/−0
- src-bin/InteractiveUI.hs +3198/−0
- src-bin/Main.hs +890/−0
- src-bin/PosixSource.h +42/−0
- src-bin/hschooks.c +47/−0
- src-ghc/CLaSH/GHC/Compat/DynFlags.hs +37/−0
- src-ghc/CLaSH/GHC/Compat/FastString.hs +28/−0
- src-ghc/CLaSH/GHC/Compat/GHC.hs +20/−0
- src-ghc/CLaSH/GHC/Compat/Outputable.hs +25/−0
- src-ghc/CLaSH/GHC/Compat/PrelNames.hs +15/−0
- src-ghc/CLaSH/GHC/Compat/TyCon.hs +17/−0
- src-ghc/CLaSH/GHC/GHC2Core.hs +456/−0
- src-ghc/CLaSH/GHC/GenerateBindings.hs +76/−0
- src-ghc/CLaSH/GHC/LoadInterfaceFiles.hs +150/−0
- src-ghc/CLaSH/GHC/LoadModules.hs +170/−0
- src-ghc/CLaSH/GHC/NetlistTypes.hs +62/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,1 @@+http://christiaanb.github.io/clash2/
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ clash-ghc.cabal view
@@ -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 <christiaan.baaij@gmail.com>+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
+ primitives/clash.bit.json view
@@ -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]"+ }+ }+]
+ primitives/clash.prelude.json view
@@ -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;"+ }+ }+]
+ primitives/clash.promoted.nat.json view
@@ -0,0 +1,11 @@+[ { "BlackBox" :+ { "name" : "CLaSH.Promoted.Nat.SNat"+ , "templateE" : "~LIT[0]"+ }+ }+, { "BlackBox" :+ { "name" : "CLaSH.Promoted.Nat.fromSNat"+ , "templateE" : "~LIT[0]"+ }+ }+]
+ primitives/clash.signal.json view
@@ -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"+ }+ }+]
+ primitives/clash.sized.signed.json view
@@ -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])"+ }+ }+]
+ primitives/clash.sized.unsigned.json view
@@ -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])"+ }+ }+]
+ primitives/clash.sized.vector.json view
@@ -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;"+ }+ }+]
+ primitives/ghc.base.json view
@@ -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"+ }+ }+]
+ primitives/ghc.classes.json view
@@ -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]"+ }+ }+]
+ primitives/ghc.cstring.json view
@@ -0,0 +1,6 @@+[ { "Primitive" :+ { "name" : "GHC.CString.unpackCString#"+ , "primType" : "Function"+ }+ }+]
+ primitives/ghc.err.json view
@@ -0,0 +1,11 @@+[ { "BlackBox" :+ { "name" : "GHC.Err.divZeroError"+ , "templateE" : "~DEFAULTO"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Err.error"+ , "templateE" : "~DEFAULTO"+ }+ }+]
+ primitives/ghc.integer.type.json view
@@ -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]"+ }+ }+]
+ primitives/ghc.prim.json view
@@ -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]"+ }+ }+]
+ primitives/ghc.real.json view
@@ -0,0 +1,6 @@+[ { "BlackBox" :+ { "name" : "GHC.Real.divZeroError"+ , "templateE" : "~DEFAULTO"+ }+ }+]
+ primitives/ghc.typelits.json view
@@ -0,0 +1,6 @@+[ { "BlackBox" :+ { "name" : "GHC.TypeLits.natVal"+ , "templateE" : "~LIT[0]"+ }+ }+]
+ primitives/ghc.types.json view
@@ -0,0 +1,6 @@+[ { "Primitive" :+ { "name" : "GHC.Types.Eq#"+ , "primType" : "Constructor"+ }+ }+]
+ primitives/unsafe.coerce.json view
@@ -0,0 +1,6 @@+[ { "BlackBox" :+ { "name" : "Unsafe.Coerce.unsafeCoerce"+ , "templateE" : "~ARG[0]"+ }+ }+]
+ src-bin/GhciMonad.hs view
@@ -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)+
+ src-bin/GhciTags.hs view
@@ -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")+
+ src-bin/HsVersions.h view
@@ -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 */+
+ src-bin/InteractiveUI.hs view
@@ -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" +++ " <statement> evaluate/run <statement>\n" +++ " : repeat last command\n" +++ " :{\\n ..lines.. \\n:}\\n multiline command\n" +++ " :add [*]<module> ... add module(s) to the current target set\n" +++ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" +++ " (!: more details; *: all top-level names)\n" +++ " :cd <dir> change directory to <dir>\n" +++ " :cmd <expr> run the commands returned by <expr>::IO String\n" +++ " :complete <dom> [<rng>] <s> list completions for partial input string\n" +++ " :ctags[!] [<file>] create tags file for Vi (default: \"tags\")\n" +++ " (!: use regex instead of line number)\n" +++ " :def <cmd> <expr> define command :<cmd> (later defined command has\n" +++ " precedence, ::<cmd> is always a builtin command)\n" +++ " :edit <file> edit file\n" +++ " :edit edit last module\n" +++ " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" +++ " :help, :? display this list of commands\n" +++ " :info[!] [<name> ...] display information about the given names\n" +++ " (!: do not filter instances)\n" +++ " :issafe [<mod>] display safe haskell information of module <mod>\n" +++ " :kind[!] <type> show the kind of <type>\n" +++ " (!: also print the normalised type)\n" +++ " :load [*]<module> ... load module(s) and their dependents\n" +++ " :main [<arguments> ...] run the main function with the given arguments\n" +++ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" +++ " :quit exit GHCi\n" +++ " :reload reload the current module set\n" +++ " :run function [<arguments> ...] run the function with the given arguments\n" +++ " :script <filename> run the script <filename>\n" +++ " :type <expr> show the type of <expr>\n" +++ " :undef <cmd> undefine user-defined command :<cmd>\n" +++ " :!<command> run the shell command <command>\n" +++ " :vhdl synthesize currently loaded module to vhdl\n" +++ " :vhdl [<module>] 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 [<mod>] <l> [<col>] set a breakpoint at the specified location\n" +++ " :break <name> set a breakpoint on the specified function\n" +++ " :continue resume after a breakpoint\n" +++ " :delete <number> delete the specified breakpoint\n" +++ " :delete * delete all breakpoints\n" +++ " :force <expr> print <expr>, forcing unevaluated parts\n" +++ " :forward go forward in the history (after :back)\n" +++ " :history [<n>] after :trace, show the execution history\n" +++ " :list show the source code around current breakpoint\n" +++ " :list <identifier> show the source code for <identifier>\n" +++ " :list [<module>] <line> show the source code around line number <line>\n" +++ " :print [<name> ...] prints a value without forcing its computation\n" +++ " :sprint [<name> ...] simplifed version of :print\n" +++ " :step single-step after stopping at a breakpoint\n"+++ " :step <expr> single-step into <expr>\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 <expr> evaluate <expr> with tracing on (see :history)\n"++++ "\n" +++ " -- Commands for changing settings:\n" +++ "\n" +++ " :set <option> ... set options\n" +++ " :seti <option> ... set options for interactive evaluation only\n" +++ " :set args <arg> ... set the arguments returned by System.getArgs\n" +++ " :set prog <progname> set the value returned by System.getProgName\n" +++ " :set prompt <prompt> set the prompt used in GHCi\n" +++ " :set prompt2 <prompt> set the continuation prompt used in GHCi\n" +++ " :set editor <cmd> set the command used for :edit\n" +++ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" +++ " :unset <option> ... unset options\n" +++ "\n" +++ " Options for ':set' and ':unset':\n" +++ "\n" +++ " +m allow multiline commands\n" +++ " +r revert top-level expressions after each evaluation\n" +++ " +s print timing/memory stats after each evaluation\n" +++ " +t print type after evaluation\n" +++ " -<flags> most GHC command line flags can also be set here\n" +++ " (eg. -v2, -XFlexibleInstances, etc.)\n" +++ " for GHCi-specific flags, see User's Guide,\n"+++ " Flag reference, Interactive-mode options\n" +++ "\n" +++ " -- Commands for displaying information:\n" +++ "\n" +++ " :show bindings show the current bindings made at the prompt\n" +++ " :show breaks show the active breakpoints\n" +++ " :show context show the breakpoint context\n" +++ " :show imports show the current imports\n" +++ " :show linker show current linker state\n" +++ " :show modules show the currently loaded modules\n" +++ " :show packages show the currently active package flags\n" +++ " :show paths show the currently active search paths\n" +++ " :show language show the currently active language flags\n" +++ " :show <setting> show value of <setting>, which is one of\n" +++ " [args, prog, prompt, editor, stop]\n" +++ " :showi language show language flags for interactive evaluation\n" +++ "\n"++findEditor :: IO String+findEditor = do+ getEnv "EDITOR"+ `catchIO` \_ -> do+#if mingw32_HOST_OS+ win <- System.Win32.getWindowsDirectory+ return (win </> "notepad.exe")+#else+ return ""+#endif++foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt++default_progname, default_prompt, default_prompt2, default_stop :: String+default_progname = "<interactive>"+default_prompt = "%s> "+default_prompt2 = "%s| "+default_stop = ""++default_args :: [String]+default_args = []++interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]+ -> Ghc ()+interactiveUI config srcs maybe_exprs = do+ -- although GHCi compiles with -prof, it is not usable: the byte-code+ -- compiler and interpreter don't work with profiling. So we check for+ -- this up front and emit a helpful error message (#2197)+ i <- liftIO $ isProfiled+ when (i /= 0) $+ throwGhcException (InstallationError "GHCi cannot be used when compiled with -prof")++ -- HACK! If we happen to get into an infinite loop (eg the user+ -- types 'let x=x in x' at the prompt), then the thread will block+ -- on a blackhole, and become unreachable during GC. The GC will+ -- detect that it is unreachable and send it the NonTermination+ -- exception. However, since the thread is unreachable, everything+ -- it refers to might be finalized, including the standard Handles.+ -- This sounds like a bug, but we don't have a good solution right+ -- now.+ _ <- liftIO $ newStablePtr stdin+ _ <- liftIO $ newStablePtr stdout+ _ <- liftIO $ newStablePtr stderr++ -- Initialise buffering for the *interpreted* I/O system+ initInterpBuffering++ -- The initial set of DynFlags used for interactive evaluation is the same+ -- as the global DynFlags, plus -XExtendedDefaultRules and+ -- -XNoMonomorphismRestriction.+ dflags <- getDynFlags+ let dflags' = (`xopt_set` Opt_ExtendedDefaultRules)+ . (`xopt_unset` Opt_MonomorphismRestriction)+ $ dflags+ GHC.setInteractiveDynFlags dflags'++ liftIO $ when (isNothing maybe_exprs) $ do+ -- Only for GHCi (not runghc and ghc -e):++ -- Turn buffering off for the compiled program's stdout/stderr+ turnOffBuffering+ -- Turn buffering off for GHCi's stdout+ hFlush stdout+ hSetBuffering stdout NoBuffering+ -- We don't want the cmd line to buffer any input that might be+ -- intended for the program, so unbuffer stdin.+ hSetBuffering stdin NoBuffering+ hSetBuffering stderr NoBuffering+#if defined(mingw32_HOST_OS)+ -- On Unix, stdin will use the locale encoding. The IO library+ -- doesn't do this on Windows (yet), so for now we use UTF-8,+ -- for consistency with GHC 6.10 and to make the tests work.+ hSetEncoding stdin utf8+#endif++ default_editor <- liftIO $ findEditor++ startGHCi (runGHCi srcs maybe_exprs)+ GHCiState{ progname = default_progname,+ GhciMonad.args = default_args,+ prompt = defPrompt config,+ prompt2 = defPrompt2 config,+ stop = default_stop,+ editor = default_editor,+ options = [],+ line_number = 1,+ break_ctr = 0,+ breaks = [],+ tickarrays = emptyModuleEnv,+ ghci_commands = availableCommands config,+ last_command = Nothing,+ cmdqueue = [],+ remembered_ctx = [],+ transient_ctx = [],+ ghc_e = isJust maybe_exprs,+ short_help = shortHelpText config,+ long_help = fullHelpText config+ }++ return ()++withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a+withGhcAppData right left = do+ either_dir <- tryIO (getAppUserDataDirectory "ghc")+ case either_dir of+ Right dir ->+ do createDirectoryIfMissing False dir `catchIO` \_ -> return ()+ right dir+ _ -> left++runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+ dflags <- getDynFlags+ let+ read_dot_files = not (gopt Opt_IgnoreDotGhci dflags)++ current_dir = return (Just ".ghci")++ app_user_dir = liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "ghci.conf")))+ (return Nothing)++ home_dir = do+ either_dir <- liftIO $ tryIO (getEnv "HOME")+ case either_dir of+ Right home -> return (Just (home </> ".ghci"))+ _ -> return Nothing++ canonicalizePath' :: FilePath -> IO (Maybe FilePath)+ canonicalizePath' fp = liftM Just (canonicalizePath fp)+ `catchIO` \_ -> return Nothing++ sourceConfigFile :: FilePath -> GHCi ()+ sourceConfigFile file = do+ exists <- liftIO $ doesFileExist file+ when exists $ do+ dir_ok <- liftIO $ checkPerms (getDirectory file)+ file_ok <- liftIO $ checkPerms file+ when (dir_ok && file_ok) $ do+ either_hdl <- liftIO $ tryIO (openFile file ReadMode)+ case either_hdl of+ Left _e -> return ()+ -- NOTE: this assumes that runInputT won't affect the terminal;+ -- can we assume this will always be the case?+ -- This would be a good place for runFileInputT.+ Right hdl ->+ do runInputTWithPrefs defaultPrefs defaultSettings $+ runCommands $ fileLoop hdl+ liftIO (hClose hdl `catchIO` \_ -> return ())+ where+ getDirectory f = case takeDirectory f of "" -> "."; d -> d+ --++ setGHCContextFromGHCiState++ when (read_dot_files) $ do+ mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] ++ map (return . Just ) (ghciScripts dflags)+ mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)+ mapM_ sourceConfigFile $ nub $ catMaybes mcfgs+ -- nub, because we don't want to read .ghci twice if the+ -- CWD is $HOME.++ -- Perform a :load for files given on the GHCi command line+ -- When in -e mode, if the load fails then we want to stop+ -- immediately rather than going on to evaluate the expression.+ when (not (null paths)) $ do+ ok <- ghciHandle (\e -> do showException e; return Failed) $+ -- TODO: this is a hack.+ runInputTWithPrefs defaultPrefs defaultSettings $+ loadModule paths+ when (isJust maybe_exprs && failed ok) $+ liftIO (exitWith (ExitFailure 1))++ installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)++ -- if verbosity is greater than 0, or we are connected to a+ -- terminal, display the prompt in the interactive loop.+ is_tty <- liftIO (hIsTerminalDevice stdin)+ let show_prompt = verbosity dflags > 0 || is_tty++ -- reset line number+ getGHCiState >>= \st -> setGHCiState st{line_number=1}++ case maybe_exprs of+ Nothing ->+ do+ -- enter the interactive loop+ runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+ Just exprs -> do+ -- just evaluate the expression we were given+ enqueueCommands exprs+ let hdle e = do st <- getGHCiState+ -- flush the interpreter's stdout/stderr on exit (#3890)+ flushInterpBuffers+ -- Jump through some hoops to get the+ -- current progname in the exception text:+ -- <progname>: <exception>+ liftIO $ withProgName (progname st)+ $ topHandler e+ -- this used to be topHandlerFastExit, see #2228+ runInputTWithPrefs defaultPrefs defaultSettings $ do+ -- make `ghc -e` exit nonzero on invalid input, see Trac #7962+ runCommands' hdle (Just $ hdle (toException $ ExitFailure 1) >> return ()) (return Nothing)++ -- and finally, exit+ liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."++runGHCiInput :: InputT GHCi a -> GHCi a+runGHCiInput f = do+ dflags <- getDynFlags+ histFile <- if gopt Opt_GhciHistory dflags+ then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))+ (return Nothing)+ else return Nothing+ runInputT+ (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})+ f++-- | How to get the next input line from the user+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)+nextInputLine show_prompt is_tty+ | is_tty = do+ prmpt <- if show_prompt then lift mkPrompt else return ""+ r <- getInputLine prmpt+ incrementLineNo+ return r+ | otherwise = do+ when show_prompt $ lift mkPrompt >>= liftIO . putStr+ fileLoop stdin++-- NOTE: We only read .ghci files if they are owned by the current user,+-- and aren't world writable. Otherwise, we could be accidentally+-- running code planted by a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else. I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "." always refers to+-- the same directory while a process is running.++checkPerms :: String -> IO Bool+#ifdef mingw32_HOST_OS+checkPerms _ = return True+#else+checkPerms name =+ handleIO (\_ -> return False) $ do+ st <- getFileStatus name+ me <- getRealUserID+ if fileOwner st /= me then do+ putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"+ return False+ else do+ let mode = System.Posix.fileMode st+ if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))+ || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))+ then do+ putStrLn $ "*** WARNING: " ++ name +++ " is writable by someone else, IGNORING!"+ return False+ else return True+#endif++incrementLineNo :: InputT GHCi ()+incrementLineNo = do+ st <- lift $ getGHCiState+ let ln = 1+(line_number st)+ lift $ setGHCiState st{line_number=ln}++fileLoop :: Handle -> InputT GHCi (Maybe String)+fileLoop hdl = do+ l <- liftIO $ tryIO $ hGetLine hdl+ case l of+ Left e | isEOFError e -> return Nothing+ | -- as we share stdin with the program, the program+ -- might have already closed it, so we might get a+ -- handle-closed exception. We therefore catch that+ -- too.+ isIllegalOperation e -> return Nothing+ | InvalidArgument <- etype -> return Nothing+ | otherwise -> liftIO $ ioError e+ where etype = ioeGetErrorType e+ -- treat InvalidArgument in the same way as EOF:+ -- this can happen if the user closed stdin, or+ -- perhaps did getContents which closes stdin at+ -- EOF.+ Right l' -> do+ incrementLineNo+ return (Just l')++mkPrompt :: GHCi String+mkPrompt = do+ st <- getGHCiState+ imports <- GHC.getContext+ resumes <- GHC.getResumeContext++ context_bit <-+ case resumes of+ [] -> return empty+ r:_ -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (brackets (ppr (GHC.resumeSpan r)) <> space)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (brackets (ppr (negate ix) <> char ':'+ <+> ppr pan) <> space)+ let+ dots | _:rs <- resumes, not (null rs) = text "... "+ | otherwise = empty++ rev_imports = reverse imports -- rightmost are the most recent+ modules_bit =+ hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>+ hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ])++ -- use the 'as' name if there is one+ myIdeclName d | Just m <- ideclAs d = m+ | otherwise = unLoc (ideclName d)++ deflt_prompt = dots <> context_bit <> modules_bit++ f ('%':'l':xs) = ppr (1 + line_number st) <> f xs+ f ('%':'s':xs) = deflt_prompt <> f xs+ f ('%':'%':xs) = char '%' <> f xs+ f (x:xs) = char x <> f xs+ f [] = empty++ dflags <- getDynFlags+ return (showSDoc dflags (f (prompt st)))+++queryQueue :: GHCi (Maybe String)+queryQueue = do+ st <- getGHCiState+ case cmdqueue st of+ [] -> return Nothing+ c:cs -> do setGHCiState st{ cmdqueue = cs }+ return (Just c)++-- Reconfigurable pretty-printing Ticket #5461+installInteractivePrint :: Maybe String -> Bool -> GHCi ()+installInteractivePrint Nothing _ = return ()+installInteractivePrint (Just ipFun) exprmode = do+ ok <- trySuccess $ do+ (name:_) <- GHC.parseName ipFun+ modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name + in he{hsc_IC = new_ic})+ return Succeeded++ when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))++-- | The main read-eval-print loop+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands = runCommands' handler Nothing++runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+ -> Maybe (GHCi ()) -- ^ Source error handler+ -> InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands' eh sourceErrorHandler gCmd = do+ b <- ghandle (\e -> case fromException e of+ Just UserInterrupt -> return $ Just False+ _ -> case fromException e of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other ->+ liftIO (Exception.throwIO e))+ (runOneCommand eh gCmd)+ case b of+ Nothing -> return ()+ Just success -> do+ when (not success) $ maybe (return ()) lift sourceErrorHandler+ runCommands' eh sourceErrorHandler gCmd++-- | Evaluate a single line of user input (either :<command> or Haskell code)+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+runOneCommand eh gCmd = do+ -- run a previously queued command if there is one, otherwise get new+ -- input from user+ mb_cmd0 <- noSpace (lift queryQueue)+ mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0+ case mb_cmd1 of+ Nothing -> return Nothing+ Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $+ handleSourceError printErrorAndKeepGoing+ (doCommand c)+ -- source error's are handled by runStmt+ -- is the handler necessary here?+ where+ printErrorAndKeepGoing err = do+ GHC.printException err+ return $ Just True++ noSpace q = q >>= maybe (return Nothing)+ (\c -> case removeSpaces c of+ "" -> noSpace q+ ":{" -> multiLineCmd q+ _ -> return (Just c) )+ multiLineCmd q = do+ st <- lift getGHCiState+ let p = prompt st+ lift $ setGHCiState st{ prompt = prompt2 st }+ mb_cmd <- collectCommand q "" `GHC.gfinally` lift (getGHCiState >>= \st' -> setGHCiState st' { prompt = p })+ return mb_cmd+ -- we can't use removeSpaces for the sublines here, so+ -- multiline commands are somewhat more brittle against+ -- fileformat errors (such as \r in dos input on unix),+ -- we get rid of any extra spaces for the ":}" test;+ -- we also avoid silent failure if ":}" is not found;+ -- and since there is no (?) valid occurrence of \r (as+ -- opposed to its String representation, "\r") inside a+ -- ghci command, we replace any such with ' ' (argh:-(+ collectCommand q c = q >>=+ maybe (liftIO (ioError collectError))+ (\l->if removeSpaces l == ":}"+ then return (Just c)+ else collectCommand q (c ++ "\n" ++ map normSpace l))+ where normSpace '\r' = ' '+ normSpace x = x+ -- SDM (2007-11-07): is userError the one to use here?+ collectError = userError "unterminated multiline command :{ .. :}"++ -- | Handle a line of input+ doCommand :: String -> InputT GHCi (Maybe Bool)++ -- command+ doCommand stmt | (':' : cmd) <- removeSpaces stmt = do+ result <- specialCommand cmd+ case result of+ True -> return Nothing+ _ -> return $ Just True++ -- haskell+ doCommand stmt = do+ -- if 'stmt' was entered via ':{' it will contain '\n's+ let stmt_nl_cnt = length [ () | '\n' <- stmt ]+ ml <- lift $ isOptionSet Multiline+ if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input+ then do+ fst_line_num <- lift (line_number <$> getGHCiState)+ mb_stmt <- checkInputForLayout stmt gCmd+ case mb_stmt of+ Nothing -> return $ Just True+ Just ml_stmt -> do+ -- temporarily compensate line-number for multi-line input+ result <- timeIt $ lift $ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion+ return $ Just result+ else do -- single line input and :{-multiline input+ last_line_num <- lift (line_number <$> getGHCiState)+ -- reconstruct first line num from last line num and stmt+ let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)+ | otherwise = last_line_num -- single line input+ stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]+ stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines+ -- temporarily compensate line-number for multi-line input+ result <- timeIt $ lift $ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion+ return $ Just result++ -- runStmt wrapper for temporarily overridden line-number+ runStmtWithLineNum :: Int -> String -> SingleStep -> GHCi Bool+ runStmtWithLineNum lnum stmt step = do+ st0 <- getGHCiState+ setGHCiState st0 { line_number = lnum }+ result <- runStmt stmt step+ -- restore original line_number+ getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }+ return result++ -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'+ dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s+ , all isSpace l0 = dropLeadingWhiteLines r+ | otherwise = s+++-- #4316+-- lex the input. If there is an unclosed layout context, request input+checkInputForLayout :: String -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe String)+checkInputForLayout stmt getStmt = do+ dflags' <- lift $ getDynFlags+ let dflags = xopt_set dflags' Opt_AlternativeLayoutRule+ st0 <- lift $ getGHCiState+ let buf' = stringToStringBuffer stmt+ loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1+ pstate = Lexer.mkPState dflags buf' loc+ case Lexer.unP goToEnd pstate of+ (Lexer.POk _ False) -> return $ Just stmt+ _other -> do+ st1 <- lift getGHCiState+ let p = prompt st1+ lift $ setGHCiState st1{ prompt = prompt2 st1 }+ mb_stmt <- ghciHandle (\ex -> case fromException ex of+ Just UserInterrupt -> return Nothing+ _ -> case fromException ex of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other -> liftIO (Exception.throwIO ex))+ getStmt+ lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }+ -- the recursive call does not recycle parser state+ -- as we use a new string buffer+ case mb_stmt of+ Nothing -> return Nothing+ Just str -> if str == ""+ then return $ Just stmt+ else do+ checkInputForLayout (stmt++"\n"++str) getStmt+ where goToEnd = do+ eof <- Lexer.nextIsEOF+ if eof+ then Lexer.activeContext+ else Lexer.lexer return >> goToEnd++enqueueCommands :: [String] -> GHCi ()+enqueueCommands cmds = do+ st <- getGHCiState+ setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }++-- | If we one of these strings prefixes a command, then we treat it as a decl+-- rather than a stmt.+declPrefixes :: [String]+declPrefixes = ["class ","data ","newtype ","type ","instance ", "deriving ",+ "foreign ", "default ", "default("]++-- | Entry point to execute some haskell code from user+runStmt :: String -> SingleStep -> GHCi Bool+runStmt stmt step+ -- empty+ | null (filter (not.isSpace) stmt)+ = return False++ -- import+ | "import " `isPrefixOf` stmt+ = do addImportToContext stmt; return False++ -- data, class, newtype...+ | any (flip isPrefixOf stmt) declPrefixes+ = do _ <- liftIO $ tryIO $ hFlushAll stdin+ result <- GhciMonad.runDecls stmt+ afterRunStmt (const True) (GHC.RunOk result)++ | otherwise+ = do -- In the new IO library, read handles buffer data even if the Handle+ -- is set to NoBuffering. This causes problems for GHCi where there+ -- are really two stdin Handles. So we flush any bufferred data in+ -- GHCi's stdin Handle here (only relevant if stdin is attached to+ -- a file, otherwise the read buffer can't be flushed).+ _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runStmt stmt step+ case m_result of+ Nothing -> return False+ Just result -> afterRunStmt (const True) result++-- | Clean up the GHCi environment after a statement has run+afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool+afterRunStmt _ (GHC.RunException e) = liftIO $ Exception.throwIO e+afterRunStmt step_here run_result = do+ resumes <- GHC.getResumeContext+ case run_result of+ GHC.RunOk names -> do+ show_types <- isOptionSet ShowType+ when show_types $ printTypeOfNames names+ GHC.RunBreak _ names mb_info+ | isNothing mb_info ||+ step_here (GHC.resumeSpan $ head resumes) -> do+ mb_id_loc <- toBreakIdAndLocation mb_info+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+ if (null bCmd)+ then printStoppedAtBreakInfo (head resumes) names+ else enqueueCommands [bCmd]+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ return ()+ | otherwise -> resume step_here GHC.SingleStep >>=+ afterRunStmt step_here >> return ()+ _ -> return ()++ flushInterpBuffers+ liftIO installSignalHandlers+ b <- isOptionSet RevertCAFs+ when b revertCAFs++ return (case run_result of GHC.RunOk _ -> True; _ -> False)++toBreakIdAndLocation ::+ Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))+toBreakIdAndLocation Nothing = return Nothing+toBreakIdAndLocation (Just inf) = do+ let md = GHC.breakInfo_module inf+ nm = GHC.breakInfo_number inf+ st <- getGHCiState+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,+ breakModule loc == md,+ breakTick loc == nm ]++printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()+printStoppedAtBreakInfo res names = do+ printForUser $ ptext (sLit "Stopped at") <+>+ ppr (GHC.resumeSpan res)+ -- printTypeOfNames session names+ let namesSorted = sortBy compareNames names+ tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted+ docs <- mapM pprTypeAndContents [i | AnId i <- tythings]+ printForUserPartWay $ vcat docs++printTypeOfNames :: [Name] -> GHCi ()+printTypeOfNames names+ = mapM_ (printTypeOfName ) $ sortBy compareNames names++compareNames :: Name -> Name -> Ordering+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2+ where compareWith n = (getOccString n, getSrcSpan n)++printTypeOfName :: Name -> GHCi ()+printTypeOfName n+ = do maybe_tything <- GHC.lookupName n+ case maybe_tything of+ Nothing -> return ()+ Just thing -> printTyThing thing+++data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand++-- | Entry point for execution a ':<command>' input from user+specialCommand :: String -> InputT GHCi Bool+specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)+specialCommand str = do+ let (cmd,rest) = break isSpace str+ maybe_cmd <- lift $ lookupCommand cmd+ htxt <- lift $ short_help `fmap` getGHCiState+ case maybe_cmd of+ GotCommand (_,f,_) -> f (dropWhile isSpace rest)+ BadCommand ->+ do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"+ ++ htxt)+ return False+ NoLastCommand ->+ do liftIO $ hPutStr stdout ("there is no last command to perform\n"+ ++ htxt)+ return False++shellEscape :: String -> GHCi Bool+shellEscape str = liftIO (system str >> return False)++lookupCommand :: String -> GHCi (MaybeCommand)+lookupCommand "" = do+ st <- getGHCiState+ case last_command st of+ Just c -> return $ GotCommand c+ Nothing -> return NoLastCommand+lookupCommand str = do+ mc <- lookupCommand' str+ st <- getGHCiState+ setGHCiState st{ last_command = mc }+ return $ case mc of+ Just c -> GotCommand c+ Nothing -> BadCommand++lookupCommand' :: String -> GHCi (Maybe Command)+lookupCommand' ":" = return Nothing+lookupCommand' str' = do+ macros <- liftIO $ readIORef macros_ref+ ghci_cmds <- ghci_commands `fmap` getGHCiState+ let (str, xcmds) = case str' of+ ':' : rest -> (rest, []) -- "::" selects a builtin command+ _ -> (str', macros) -- otherwise include macros in lookup++ lookupExact s = find $ (s ==) . cmdName+ lookupPrefix s = find $ (s `isPrefixOf`) . cmdName++ builtinPfxMatch = lookupPrefix str ghci_cmds++ -- first, look for exact match (while preferring macros); then, look+ -- for first prefix match (preferring builtins), *unless* a macro+ -- overrides the builtin; see #8305 for motivation+ return $ lookupExact str xcmds <|>+ lookupExact str ghci_cmds <|>+ (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>+ builtinPfxMatch <|>+ lookupPrefix str xcmds++getCurrentBreakSpan :: GHCi (Maybe SrcSpan)+getCurrentBreakSpan = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (Just (GHC.resumeSpan r))+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (Just pan)++getCurrentBreakModule :: GHCi (Maybe Module)+getCurrentBreakModule = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ return $ Just $ GHC.getHistoryModule hist++-----------------------------------------------------------------------------+--+-- Commands+--+-----------------------------------------------------------------------------++noArgs :: GHCi () -> String -> GHCi ()+noArgs m "" = m+noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"++withSandboxOnly :: String -> GHCi () -> GHCi ()+withSandboxOnly cmd this = do+ dflags <- getDynFlags+ if not (gopt Opt_GhciSandbox dflags)+ then printForUser (text cmd <+>+ ptext (sLit "is not supported with -fno-ghci-sandbox"))+ else this++-----------------------------------------------------------------------------+-- :help++help :: String -> GHCi ()+help _ = do+ txt <- long_help `fmap` getGHCiState+ liftIO $ putStr txt++-----------------------------------------------------------------------------+-- :info++info :: Bool -> String -> InputT GHCi ()+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")+info allInfo s = handleSourceError GHC.printException $ do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ sdocs <- mapM (infoThing allInfo) (words s)+ mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs++infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc+infoThing allInfo str = do+ names <- GHC.parseName str+ mb_stuffs <- mapM (GHC.getInfo allInfo) names+ let filtered = filterOutChildren (\(t,_f,_ci,_fi) -> t) (catMaybes mb_stuffs)+ return $ vcat (intersperse (text "") $ map pprInfo filtered)++ -- Filter out names whose parent is also there Good+ -- example is '[]', which is both a type and data+ -- constructor in the same type+filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+ = filterOut has_parent xs+ where+ all_names = mkNameSet (map (getName . get_thing) xs)+ has_parent x = case tyThingParent_maybe (get_thing x) of+ Just p -> getName p `elemNameSet` all_names+ Nothing -> False++pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc+pprInfo (thing, fixity, cls_insts, fam_insts)+ = pprTyThingInContextLoc thing+ $$ show_fixity+ $$ vcat (map GHC.pprInstance cls_insts)+ $$ vcat (map GHC.pprFamInst fam_insts)+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)++-----------------------------------------------------------------------------+-- :main++runMain :: String -> GHCi ()+runMain s = case toArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args ->+ do dflags <- getDynFlags+ case mainFunIs dflags of+ Nothing -> doWithArgs args "main"+ Just f -> doWithArgs args f++-----------------------------------------------------------------------------+-- :run++runRun :: String -> GHCi ()+runRun s = case toCmdArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: [String] -> String -> GHCi ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++ show args ++ " (" ++ cmd ++ ")"]++-----------------------------------------------------------------------------+-- :cd++changeDirectory :: String -> InputT GHCi ()+changeDirectory "" = do+ -- :cd on its own changes to the user's home directory+ either_dir <- liftIO $ tryIO getHomeDirectory+ case either_dir of+ Left _e -> return ()+ Right dir -> changeDirectory dir+changeDirectory dir = do+ graph <- GHC.getModuleGraph+ when (not (null graph)) $+ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets+ lift $ setContextAfterLoad False []+ GHC.workingDirectoryChanged+ dir' <- expandPath dir+ liftIO $ setCurrentDirectory dir'++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+ handleSourceError (\e -> do GHC.printException e+ return Failed) $ do+ act++-----------------------------------------------------------------------------+-- :edit++editFile :: String -> InputT GHCi ()+editFile str =+ do file <- if null str then lift chooseEditFile else expandPath str+ st <- lift getGHCiState+ let cmd = editor st+ when (null cmd)+ $ throwGhcException (CmdLineError "editor not set, use :set editor")+ code <- liftIO $ system (cmd ++ ' ':file)+ when (code == ExitSuccess)+ $ reloadModule ""++-- The user didn't specify a file so we pick one for them.+-- Our strategy is to pick the first module that failed to load,+-- or otherwise the first target.+--+-- XXX: Can we figure out what happened if the depndecy analysis fails+-- (e.g., because the porgrammeer mistyped the name of a module)?+-- XXX: Can we figure out the location of an error to pass to the editor?+-- XXX: if we could figure out the list of errors that occured during the+-- last load/reaload, then we could start the editor focused on the first+-- of those.+chooseEditFile :: GHCi String+chooseEditFile =+ do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x++ graph <- GHC.getModuleGraph+ failed_graph <- filterM hasFailed graph+ let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing+ pick xs = case xs of+ x : _ -> GHC.ml_hs_file (GHC.ms_location x)+ _ -> Nothing++ case pick (order failed_graph) of+ Just file -> return file+ Nothing ->+ do targets <- GHC.getTargets+ case msum (map fromTarget targets) of+ Just file -> return file+ Nothing -> throwGhcException (CmdLineError "No files to edit.")++ where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f+ fromTarget _ = Nothing -- when would we get a module target?+++-----------------------------------------------------------------------------+-- :def++defineMacro :: Bool{-overwrite-} -> String -> GHCi ()+defineMacro _ (':':_) =+ liftIO $ putStrLn "macro name cannot start with a colon"+defineMacro overwrite s = do+ let (macro_name, definition) = break isSpace s+ macros <- liftIO (readIORef macros_ref)+ let defined = map cmdName macros+ if (null macro_name)+ then if null defined+ then liftIO $ putStrLn "no macros defined"+ else liftIO $ putStr ("the following macros are defined:\n" +++ unlines defined)+ else do+ if (not overwrite && macro_name `elem` defined)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is already defined"))+ else do++ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]++ -- give the expression a type signature, so we can be sure we're getting+ -- something of the right type.+ let new_expr = '(' : definition ++ ") :: String -> IO String"++ -- compile the expression+ handleSourceError (\e -> GHC.printException e) $+ do+ hv <- GHC.compileExpr new_expr+ liftIO (writeIORef macros_ref -- later defined macros have precedence+ ((macro_name, lift . runMacro hv, noCompletion) : filtered))++runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool+runMacro fun s = do+ str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s)+ -- make sure we force any exceptions in the result, while we are still+ -- inside the exception handler for commands:+ seqList str (return ())+ enqueueCommands (lines str)+ return False+++-----------------------------------------------------------------------------+-- :undef++undefineMacro :: String -> GHCi ()+undefineMacro str = mapM_ undef (words str)+ where undef macro_name = do+ cmds <- liftIO (readIORef macros_ref)+ if (macro_name `notElem` map cmdName cmds)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is not defined"))+ else do+ liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))+++-----------------------------------------------------------------------------+-- :cmd++cmdCmd :: String -> GHCi ()+cmdCmd str = do+ let expr = '(' : str ++ ") :: IO String"+ handleSourceError (\e -> GHC.printException e) $+ do+ hv <- GHC.compileExpr expr+ cmds <- liftIO $ (unsafeCoerce# hv :: IO String)+ enqueueCommands (lines cmds)+ return ()+++-----------------------------------------------------------------------------+-- :check++checkModule :: String -> InputT GHCi ()+checkModule m = do+ let modl = GHC.mkModuleName m+ ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl+ dflags <- getDynFlags+ liftIO $ putStrLn $ showSDoc dflags $+ case GHC.moduleInfo r of+ cm | Just scope <- GHC.modInfoTopLevelScope cm ->+ let+ (loc, glob) = ASSERT( all isExternalName scope )+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope+ in+ (text "global names: " <+> ppr glob) $$+ (text "local names: " <+> ppr loc)+ _ -> empty+ return True+ afterLoad (successIf ok) False+++-----------------------------------------------------------------------------+-- :load, :add, :reload++loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule fs = timeIt (loadModule' fs)++loadModule_ :: [FilePath] -> InputT GHCi ()+loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()++loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule' files = do+ let (filenames, phases) = unzip files+ exp_filenames <- mapM expandPath filenames+ let files' = zip exp_filenames phases+ targets <- mapM (uncurry GHC.guessTarget) files'++ -- NOTE: we used to do the dependency anal first, so that if it+ -- fails we didn't throw away the current set of modules. This would+ -- require some re-working of the GHC interface, so we'll leave it+ -- as a ToDo for now.++ -- unload first+ _ <- GHC.abandonAll+ lift discardActiveBreakPoints+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets++ GHC.setTargets targets+ doLoad False LoadAllTargets+++-- :add+addModule :: [FilePath] -> InputT GHCi ()+addModule files = do+ lift revertCAFs -- always revert CAFs on load/add.+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+ -- remove old targets with the same id; e.g. for :add *M+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]+ mapM_ GHC.addTarget targets+ _ <- doLoad False LoadAllTargets+ return ()+++-- :reload+reloadModule :: String -> InputT GHCi ()+reloadModule m = do+ _ <- doLoad True $+ if null m then LoadAllTargets+ else LoadUpTo (GHC.mkModuleName m)+ return ()+++doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag+doLoad retain_context howmuch = do+ -- turn off breakpoints before we load: we can't turn them off later, because+ -- the ModBreaks will have gone away.+ lift discardActiveBreakPoints++ -- Enable buffering stdout and stderr as we're compiling. Keeping these+ -- handles unbuffered will just slow the compilation down, especially when+ -- compiling in parallel.+ gbracket (liftIO $ do hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering)+ (\_ ->+ liftIO $ do hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering) $ \_ -> do+ ok <- trySuccess $ GHC.load howmuch+ afterLoad ok retain_context+ return ok+++afterLoad :: SuccessFlag+ -> Bool -- keep the remembered_ctx, as far as possible (:reload)+ -> InputT GHCi ()+afterLoad ok retain_context = do+ lift revertCAFs -- always revert CAFs on load.+ lift discardTickArrays+ loaded_mod_summaries <- getLoadedModules+ let loaded_mods = map GHC.ms_mod loaded_mod_summaries+ modulesLoadedMsg ok loaded_mods+ lift $ setContextAfterLoad retain_context loaded_mod_summaries+++setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()+setContextAfterLoad keep_ctxt [] = do+ setContextKeepingPackageModules keep_ctxt []+setContextAfterLoad keep_ctxt ms = do+ -- load a target if one is available, otherwise load the topmost module.+ targets <- GHC.getTargets+ case [ m | Just m <- map (findTarget ms) targets ] of+ [] ->+ let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in+ load_this (last graph')+ (m:_) ->+ load_this m+ where+ findTarget mds t+ = case filter (`matches` t) mds of+ [] -> Nothing+ (m:_) -> Just m++ summary `matches` Target (TargetModule m) _ _+ = GHC.ms_mod_name summary == m+ summary `matches` Target (TargetFile f _) _ _+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'+ _ `matches` _+ = False++ load_this summary | m <- GHC.ms_mod summary = do+ is_interp <- GHC.moduleIsInterpreted m+ dflags <- getDynFlags+ let star_ok = is_interp && not (safeLanguageOn dflags)+ -- We import the module with a * iff+ -- - it is interpreted, and+ -- - -XSafe is off (it doesn't allow *-imports)+ let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]+ | otherwise = [mkIIDecl (GHC.moduleName m)]+ setContextKeepingPackageModules keep_ctxt new_ctx+++-- | Keep any package modules (except Prelude) when changing the context.+setContextKeepingPackageModules+ :: Bool -- True <=> keep all of remembered_ctx+ -- False <=> just keep package imports+ -> [InteractiveImport] -- new context+ -> GHCi ()++setContextKeepingPackageModules keep_ctx trans_ctx = do++ st <- getGHCiState+ let rem_ctx = remembered_ctx st+ new_rem_ctx <- if keep_ctx then return rem_ctx+ else keepPackageImports rem_ctx+ setGHCiState st{ remembered_ctx = new_rem_ctx,+ transient_ctx = filterSubsumed new_rem_ctx trans_ctx }+ setGHCContextFromGHCiState+++keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]+keepPackageImports = filterM is_pkg_import+ where+ is_pkg_import :: InteractiveImport -> GHCi Bool+ is_pkg_import (IIModule _) = return False+ is_pkg_import (IIDecl d)+ = do e <- gtry $ GHC.findModule mod_name (ideclPkgQual d)+ case e :: Either SomeException Module of+ Left _ -> return False+ Right m -> return (not (isHomeModule m))+ where+ mod_name = unLoc (ideclName d)+++modulesLoadedMsg :: SuccessFlag -> [Module] -> InputT GHCi ()+modulesLoadedMsg ok mods = do+ dflags <- getDynFlags+ unqual <- GHC.getPrintUnqual+ let mod_commas+ | null mods = text "none."+ | otherwise = hsep (+ punctuate comma (map ppr mods)) <> text "."+ status = case ok of+ Failed -> text "Failed"+ Succeeded -> text "Ok"++ msg = status <> text ", modules loaded:" <+> mod_commas++ when (verbosity dflags > 0) $+ liftIO $ putStrLn $ showSDocForUser dflags unqual msg++makeVHDL :: [FilePath] -> InputT GHCi ()+makeVHDL [] = do+ modGraph <- GHC.getModuleGraph+ let sortedGraph = GHC.topSortModuleGraph False modGraph Nothing+ case (reverse sortedGraph) of+ (AcyclicSCC top):_ -> do+ let loc = (GHC.ml_hs_file . GHC.ms_location) top+ 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+ ) 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+ ) srcs++-----------------------------------------------------------------------------+-- :type++typeOfExpr :: String -> InputT GHCi ()+typeOfExpr str+ = handleSourceError GHC.printException+ $ do+ ty <- GHC.exprType str+ printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)]++-----------------------------------------------------------------------------+-- :kind++kindOfType :: Bool -> String -> InputT GHCi ()+kindOfType norm str+ = handleSourceError GHC.printException+ $ do+ (ty, kind) <- GHC.typeKind norm str+ printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind+ , ppWhen norm $ equals <+> ppr ty ]+++-----------------------------------------------------------------------------+-- :quit++quit :: String -> InputT GHCi Bool+quit _ = return True+++-----------------------------------------------------------------------------+-- :script++-- running a script file #1363++scriptCmd :: String -> InputT GHCi ()+scriptCmd ws = do+ case words ws of+ [s] -> runScript s+ _ -> throwGhcException (CmdLineError "syntax: :script <filename>")++runScript :: String -- ^ filename+ -> InputT GHCi ()+runScript filename = do+ filename' <- expandPath filename+ either_script <- liftIO $ tryIO (openFile filename' ReadMode)+ case either_script of+ Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "+ ++(ioeGetErrorString _err))+ Right script -> do+ st <- lift $ getGHCiState+ let prog = progname st+ line = line_number st+ lift $ setGHCiState st{progname=filename',line_number=0}+ scriptLoop script+ liftIO $ hClose script+ new_st <- lift $ getGHCiState+ lift $ setGHCiState new_st{progname=prog,line_number=line}+ where scriptLoop script = do+ res <- runOneCommand handler $ fileLoop script+ case res of+ Nothing -> return ()+ Just s -> if s+ then scriptLoop script+ else return ()++-----------------------------------------------------------------------------+-- :issafe++-- Displaying Safe Haskell properties of a module++isSafeCmd :: String -> InputT GHCi ()+isSafeCmd m =+ case words m of+ [s] | looksLikeModuleName s -> do+ md <- lift $ lookupModule s+ isSafeModule md+ [] -> do md <- guessCurrentModule "issafe"+ isSafeModule md+ _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")++isSafeModule :: Module -> InputT GHCi ()+isSafeModule m = do+ mb_mod_info <- GHC.getModuleInfo m+ when (isNothing mb_mod_info)+ (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)++ dflags <- getDynFlags+ let iface = GHC.modInfoIface $ fromJust mb_mod_info+ when (isNothing iface)+ (throwGhcException $ CmdLineError $ "can't load interface file for module: " +++ (GHC.moduleNameString $ GHC.moduleName m))++ (msafe, pkgs) <- GHC.moduleTrustReqs m+ let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface+ pkg = if packageTrusted dflags m then "trusted" else "untrusted"+ (good, bad) = tallyPkgs dflags pkgs++ -- print info to user...+ liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"+ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")+ when (not $ null good)+ (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " +++ (intercalate ", " $ map packageIdString good))+ case msafe && null bad of+ True -> liftIO $ putStrLn $ mname ++ " is trusted!"+ False -> do+ when (not $ null bad)+ (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "+ ++ (intercalate ", " $ map packageIdString bad))+ liftIO $ putStrLn $ mname ++ " is NOT trusted!"++ where+ mname = GHC.moduleNameString $ GHC.moduleName m++ packageTrusted dflags md+ | thisPackage dflags == modulePackageId md = True+ | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackageId md)++ tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])+ | otherwise = partition part deps+ where state = pkgState dflags+ part pkg = trusted $ getPackageDetails state pkg++-----------------------------------------------------------------------------+-- :browse++-- Browsing a module's contents++browseCmd :: Bool -> String -> InputT GHCi ()+browseCmd bang m =+ case words m of+ ['*':s] | looksLikeModuleName s -> do+ md <- lift $ wantInterpretedModule s+ browseModule bang md False+ [s] | looksLikeModuleName s -> do+ md <- lift $ lookupModule s+ browseModule bang md True+ [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")+ browseModule bang md True+ _ -> throwGhcException (CmdLineError "syntax: :browse <module>")++guessCurrentModule :: String -> InputT GHCi Module+-- Guess which module the user wants to browse. Pick+-- modules that are interpreted first. The most+-- recently-added module occurs last, it seems.+guessCurrentModule cmd+ = do imports <- GHC.getContext+ when (null imports) $ throwGhcException $+ CmdLineError (':' : cmd ++ ": no current module")+ case (head imports) of+ IIModule m -> GHC.findModule m Nothing+ IIDecl d -> GHC.findModule (unLoc (ideclName d)) (ideclPkgQual d)++-- without bang, show items in context of their parents and omit children+-- with bang, show class methods and data constructors separately, and+-- indicate import modules, to aid qualifying unqualified names+-- with sorted, sort items alphabetically+browseModule :: Bool -> Module -> Bool -> InputT GHCi ()+browseModule bang modl exports_only = do+ -- :browse reports qualifiers wrt current context+ unqual <- GHC.getPrintUnqual++ mb_mod_info <- GHC.getModuleInfo modl+ case mb_mod_info of+ Nothing -> throwGhcException (CmdLineError ("unknown module: " +++ GHC.moduleNameString (GHC.moduleName modl)))+ Just mod_info -> do+ dflags <- getDynFlags+ let names+ | exports_only = GHC.modInfoExports mod_info+ | otherwise = GHC.modInfoTopLevelScope mod_info+ `orElse` []++ -- sort alphabetically name, but putting locally-defined+ -- identifiers first. We would like to improve this; see #1799.+ sorted_names = loc_sort local ++ occ_sort external+ where+ (local,external) = ASSERT( all isExternalName names )+ partition ((==modl) . nameModule) names+ occ_sort = sortBy (compare `on` nameOccName)+ -- try to sort by src location. If the first name in our list+ -- has a good source location, then they all should.+ loc_sort ns+ | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)+ = sortBy (compare `on` nameSrcSpan) ns+ | otherwise+ = occ_sort ns++ mb_things <- mapM GHC.lookupName sorted_names+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)++ rdr_env <- GHC.getGRE++ let things | bang = catMaybes mb_things+ | otherwise = filtered_things+ pretty | bang = pprTyThing+ | otherwise = pprTyThingInContext++ labels [] = text "-- not currently imported"+ labels l = text $ intercalate "\n" $ map qualifier l++ qualifier :: Maybe [ModuleName] -> String+ qualifier = maybe "-- defined locally"+ (("-- imported via "++) . intercalate ", "+ . map GHC.moduleNameString)+ importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env++ modNames :: [[Maybe [ModuleName]]]+ modNames = map (importInfo . GHC.getName) things++ -- annotate groups of imports with their import modules+ -- the default ordering is somewhat arbitrary, so we group+ -- by header and sort groups; the names themselves should+ -- really come in order of source appearance.. (trac #1799)+ annotate mts = concatMap (\(m,ts)->labels m:ts)+ $ sortBy cmpQualifiers $ grp mts+ where cmpQualifiers =+ compare `on` (map (fmap (map moduleNameFS)) . fst)+ grp [] = []+ grp mts@((m,_):_) = (m,map snd g) : grp ng+ where (g,ng) = partition ((==m).fst) mts++ let prettyThings, prettyThings' :: [SDoc]+ prettyThings = map pretty things+ prettyThings' | bang = annotate $ zip modNames prettyThings+ | otherwise = prettyThings+ liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')+ -- ToDo: modInfoInstances currently throws an exception for+ -- package modules. When it works, we can do this:+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))+++-----------------------------------------------------------------------------+-- :module++-- Setting the module context. For details on context handling see+-- "remembered_ctx" and "transient_ctx" in GhciMonad.++moduleCmd :: String -> GHCi ()+moduleCmd str+ | all sensible strs = cmd+ | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")+ where+ (cmd, strs) =+ case str of+ '+':stuff -> rest addModulesToContext stuff+ '-':stuff -> rest remModulesFromContext stuff+ stuff -> rest setContext stuff++ rest op stuff = (op as bs, stuffs)+ where (as,bs) = partitionWith starred stuffs+ stuffs = words stuff++ sensible ('*':m) = looksLikeModuleName m+ sensible m = looksLikeModuleName m++ starred ('*':m) = Left (GHC.mkModuleName m)+ starred m = Right (GHC.mkModuleName m)+++-- -----------------------------------------------------------------------------+-- Four ways to manipulate the context:+-- (a) :module +<stuff>: addModulesToContext+-- (b) :module -<stuff>: remModulesFromContext+-- (c) :module <stuff>: setContext+-- (d) import <module>...: addImportToContext++addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext starred unstarred = restoreContextOnFailure $ do+ addModulesToContext_ starred unstarred++addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext_ starred unstarred = do+ mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)+ setGHCContextFromGHCiState++remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()+remModulesFromContext starred unstarred = do+ -- we do *not* call restoreContextOnFailure here. If the user+ -- is trying to fix up a context that contains errors by removing+ -- modules, we don't want GHC to silently put them back in again.+ mapM_ rm (starred ++ unstarred)+ setGHCContextFromGHCiState+ where+ rm :: ModuleName -> GHCi ()+ rm str = do+ m <- moduleName <$> lookupModuleName str+ let filt = filter ((/=) m . iiModuleName)+ modifyGHCiState $ \st ->+ st { remembered_ctx = filt (remembered_ctx st)+ , transient_ctx = filt (transient_ctx st) }++setContext :: [ModuleName] -> [ModuleName] -> GHCi ()+setContext starred unstarred = restoreContextOnFailure $ do+ modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }+ -- delete the transient context+ addModulesToContext_ starred unstarred++addImportToContext :: String -> GHCi ()+addImportToContext str = restoreContextOnFailure $ do+ idecl <- GHC.parseImportDecl str+ addII (IIDecl idecl) -- #5836+ setGHCContextFromGHCiState++-- Util used by addImportToContext and addModulesToContext+addII :: InteractiveImport -> GHCi ()+addII iidecl = do+ checkAdd iidecl+ modifyGHCiState $ \st ->+ st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)+ , transient_ctx = filter (not . (iidecl `iiSubsumes`))+ (transient_ctx st)+ }++-- Sometimes we can't tell whether an import is valid or not until+-- we finally call 'GHC.setContext'. e.g.+--+-- import System.IO (foo)+--+-- will fail because System.IO does not export foo. In this case we+-- don't want to store the import in the context permanently, so we+-- catch the failure from 'setGHCContextFromGHCiState' and set the+-- context back to what it was.+--+-- See #6007+--+restoreContextOnFailure :: GHCi a -> GHCi a+restoreContextOnFailure do_this = do+ st <- getGHCiState+ let rc = remembered_ctx st; tc = transient_ctx st+ do_this `gonException` (modifyGHCiState $ \st' ->+ st' { remembered_ctx = rc, transient_ctx = tc })++-- -----------------------------------------------------------------------------+-- Validate a module that we want to add to the context++checkAdd :: InteractiveImport -> GHCi ()+checkAdd ii = do+ dflags <- getDynFlags + let safe = safeLanguageOn dflags+ case ii of+ IIModule modname+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"+ | otherwise -> wantInterpretedModuleName modname >> return ()++ IIDecl d -> do+ let modname = unLoc (ideclName d)+ pkgqual = ideclPkgQual d+ m <- GHC.lookupModule modname pkgqual+ when safe $ do+ t <- GHC.isModuleTrusted m+ when (not t) $ throwGhcException $ ProgramError $ ""++-- -----------------------------------------------------------------------------+-- Update the GHC API's view of the context++-- | Sets the GHC context from the GHCi state. The GHC context is+-- always set this way, we never modify it incrementally.+--+-- We ignore any imports for which the ModuleName does not currently+-- exist. This is so that the remembered_ctx can contain imports for+-- modules that are not currently loaded, perhaps because we just did+-- a :reload and encountered errors.+--+-- Prelude is added if not already present in the list. Therefore to+-- override the implicit Prelude import you can say 'import Prelude ()'+-- at the prompt, just as in Haskell source.+--+setGHCContextFromGHCiState :: GHCi ()+setGHCContextFromGHCiState = do+ st <- getGHCiState+ -- re-use checkAdd to check whether the module is valid. If the+ -- module does not exist, we do *not* want to print an error+ -- here, we just want to silently keep the module in the context+ -- until such time as the module reappears again. So we ignore+ -- the actual exception thrown by checkAdd, using tryBool to+ -- turn it into a Bool.+ iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)+ dflags <- GHC.getSessionDynFlags+ GHC.setContext $+ if xopt Opt_ImplicitPrelude dflags && not (any isPreludeImport iidecls)+ then iidecls ++ [implicitPreludeImport,implicitCLaSHPreludeImport]+ else iidecls+ -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up.+++-- -----------------------------------------------------------------------------+-- Utils on InteractiveImport++mkIIModule :: ModuleName -> InteractiveImport+mkIIModule = IIModule++mkIIDecl :: ModuleName -> InteractiveImport+mkIIDecl = IIDecl . simpleImportDecl++iiModules :: [InteractiveImport] -> [ModuleName]+iiModules is = [m | IIModule m <- is]++iiModuleName :: InteractiveImport -> ModuleName+iiModuleName (IIModule m) = m+iiModuleName (IIDecl d) = unLoc (ideclName d)++preludeModuleName :: ModuleName+preludeModuleName = GHC.mkModuleName "Prelude"++clashPreludeModuleName :: ModuleName+clashPreludeModuleName = GHC.mkModuleName "CLaSH.Prelude"++implicitPreludeImport :: InteractiveImport+implicitPreludeImport = IIDecl (simpleImportDecl preludeModuleName)++implicitCLaSHPreludeImport :: InteractiveImport+implicitCLaSHPreludeImport = IIDecl (simpleImportDecl clashPreludeModuleName)++isPreludeImport :: InteractiveImport -> Bool+isPreludeImport (IIModule {}) = True+isPreludeImport (IIDecl d) = unLoc (ideclName d) == preludeModuleName++addNotSubsumed :: InteractiveImport+ -> [InteractiveImport] -> [InteractiveImport]+addNotSubsumed i is+ | any (`iiSubsumes` i) is = is+ | otherwise = i : filter (not . (i `iiSubsumes`)) is++-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed+-- by any of @is@.+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]+ -> [InteractiveImport]+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js++-- | Returns True if the left import subsumes the right one. Doesn't+-- need to be 100% accurate, conservatively returning False is fine.+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in+-- plusProv will ensue (#5904))+--+-- Note that an IIModule does not necessarily subsume an IIDecl,+-- because e.g. a module might export a name that is only available+-- qualified within the module itself.+--+-- Note that 'import M' does not necessarily subsume 'import M(foo)',+-- because M might not export foo and we want an error to be produced+-- in that case.+--+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2+iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude+ = unLoc (ideclName d1) == unLoc (ideclName d2)+ && ideclAs d1 == ideclAs d2+ && (not (ideclQualified d1) || ideclQualified d2)+ && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)+ where+ _ `hidingSubsumes` Just (False,[]) = True+ Just (False, xs) `hidingSubsumes` Just (False,ys) = all (`elem` xs) ys+ h1 `hidingSubsumes` h2 = h1 == h2+iiSubsumes _ _ = False+++----------------------------------------------------------------------------+-- :set++-- set options in the interpreter. Syntax is exactly the same as the+-- ghc command line, except that certain options aren't available (-C,+-- -E etc.)+--+-- This is pretty fragile: most options won't work as expected. ToDo:+-- figure out which ones & disallow them.++setCmd :: String -> GHCi ()+setCmd "" = showOptions False+setCmd "-a" = showOptions True+setCmd str+ = case getCmd str of+ Right ("args", rest) ->+ case toArgs rest of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args -> setArgs args+ Right ("prog", rest) ->+ case toArgs rest of+ Right [prog] -> setProg prog+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")+ Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest+ Right ("prompt2", rest) -> setPrompt2 $ dropWhile isSpace rest+ Right ("editor", rest) -> setEditor $ dropWhile isSpace rest+ Right ("stop", rest) -> setStop $ dropWhile isSpace rest+ _ -> case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> setOptions wds++setiCmd :: String -> GHCi ()+setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str =+ case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> newDynFlags True wds++showOptions :: Bool -> GHCi ()+showOptions show_all+ = do st <- getGHCiState+ dflags <- getDynFlags+ let opts = options st+ liftIO $ putStrLn (showSDoc dflags (+ text "options currently set: " <>+ if null opts+ then text "none."+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)+ ))+ getDynFlags >>= liftIO . showDynFlags show_all+++showDynFlags :: Bool -> DynFlags -> IO ()+showDynFlags show_all dflags = do+ showLanguages' show_all dflags+ putStrLn $ showSDoc dflags $+ text "GHCi-specific dynamic flag settings:" $$+ nest 2 (vcat (map (setting gopt) ghciFlags))+ putStrLn $ showSDoc dflags $+ text "other dynamic, non-language, flag settings:" $$+ nest 2 (vcat (map (setting gopt) others))+ putStrLn $ showSDoc dflags $+ text "warning settings:" $$+ nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags))+ where+ setting test (str, f, _)+ | quiet = empty+ | is_on = fstr str+ | otherwise = fnostr str+ where is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags = defaultDynFlags (settings dflags)++ fstr str = text "-f" <> text str+ fnostr str = text "-fno-" <> text str++ (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flgs)+ DynFlags.fFlags+ flgs = [ Opt_PrintExplicitForalls+ , Opt_PrintExplicitKinds+ , Opt_PrintBindResult+ , Opt_BreakOnException+ , Opt_BreakOnError+ , Opt_PrintEvldWithShow+ ]++setArgs, setOptions :: [String] -> GHCi ()+setProg, setEditor, setStop :: String -> GHCi ()++setArgs args = do+ st <- getGHCiState+ setGHCiState st{ GhciMonad.args = args }++setProg prog = do+ st <- getGHCiState+ setGHCiState st{ progname = prog }++setEditor cmd = do+ st <- getGHCiState+ setGHCiState st{ editor = cmd }++setStop str@(c:_) | isDigit c+ = do let (nm_str,rest) = break (not.isDigit) str+ nm = read nm_str+ st <- getGHCiState+ let old_breaks = breaks st+ if all ((/= nm) . fst) old_breaks+ then printForUser (text "Breakpoint" <+> ppr nm <+>+ text "does not exist")+ else do+ let new_breaks = map fn old_breaks+ fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })+ | otherwise = (i,loc)+ setGHCiState st{ breaks = new_breaks }+setStop cmd = do+ st <- getGHCiState+ setGHCiState st{ stop = cmd }++setPrompt :: String -> GHCi ()+setPrompt = setPrompt_ f err+ where+ f v st = st { prompt = v }+ err st = "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""++setPrompt2 :: String -> GHCi ()+setPrompt2 = setPrompt_ f err+ where+ f v st = st { prompt2 = v }+ err st = "syntax: :set prompt2 <prompt>, currently \"" ++ prompt2 st ++ "\""++setPrompt_ :: (String -> GHCiState -> GHCiState) -> (GHCiState -> String) -> String -> GHCi ()+setPrompt_ f err value = do+ st <- getGHCiState+ if null value+ then liftIO $ hPutStrLn stderr $ err st+ else case value of+ '\"' : _ -> case reads value of+ [(value', xs)] | all isSpace xs ->+ setGHCiState $ f value' st+ _ ->+ liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."+ _ -> setGHCiState $ f value st++setOptions wds =+ do -- first, deal with the GHCi opts (+s, +t, etc.)+ let (plus_opts, minus_opts) = partitionWith isPlus wds+ mapM_ setOpt plus_opts+ -- then, dynamic flags+ newDynFlags False minus_opts++newDynFlags :: Bool -> [String] -> GHCi ()+newDynFlags interactive_only minus_opts = do+ let lopts = map noLoc minus_opts++ idflags0 <- GHC.getInteractiveDynFlags+ (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts++ liftIO $ handleFlagWarnings idflags1 warns+ when (not $ null leftovers)+ (throwGhcException . CmdLineError+ $ "Some flags have not been recognized: "+ ++ (concat . intersperse ", " $ map unLoc leftovers))++ when (interactive_only &&+ packageFlags idflags1 /= packageFlags idflags0) $ do+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"+ GHC.setInteractiveDynFlags idflags1+ installInteractivePrint (interactivePrint idflags1) False++ dflags0 <- getDynFlags+ when (not interactive_only) $ do+ (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts+ new_pkgs <- GHC.setProgramDynFlags dflags1++ -- if the package flags changed, reset the context and link+ -- the new packages.+ dflags2 <- getDynFlags+ when (packageFlags dflags2 /= packageFlags dflags0) $ do+ when (verbosity dflags2 > 0) $+ liftIO . putStrLn $+ "package flags have changed, resetting and loading new packages..."+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets+ liftIO $ linkPackages dflags2 new_pkgs+ -- package flags changed, we can't re-use any of the old context+ setContextAfterLoad False []+ -- and copy the package state to the interactive DynFlags+ idflags <- GHC.getInteractiveDynFlags+ GHC.setInteractiveDynFlags+ idflags{ pkgState = pkgState dflags2+ , pkgDatabase = pkgDatabase dflags2+ , packageFlags = packageFlags dflags2 }++ return ()+++unsetOptions :: String -> GHCi ()+unsetOptions str+ = -- first, deal with the GHCi opts (+s, +t, etc.)+ let opts = words str+ (minus_opts, rest1) = partition isMinus opts+ (plus_opts, rest2) = partitionWith isPlus rest1+ (other_opts, rest3) = partition (`elem` map fst defaulters) rest2++ defaulters =+ [ ("args" , setArgs default_args)+ , ("prog" , setProg default_progname)+ , ("prompt" , setPrompt default_prompt)+ , ("prompt2", setPrompt2 default_prompt2)+ , ("editor" , liftIO findEditor >>= setEditor)+ , ("stop" , setStop default_stop)+ ]++ no_flag ('-':'f':rest) = return ("-fno-" ++ rest)+ no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))++ in if (not (null rest3))+ then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))+ else do+ mapM_ (fromJust.flip lookup defaulters) other_opts++ mapM_ unsetOpt plus_opts++ no_flags <- mapM no_flag minus_opts+ newDynFlags False no_flags++isMinus :: String -> Bool+isMinus ('-':_) = True+isMinus _ = False++isPlus :: String -> Either String String+isPlus ('+':opt) = Left opt+isPlus other = Right other++setOpt, unsetOpt :: String -> GHCi ()++setOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> setOption o++unsetOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> unsetOption o++strToGHCiOpt :: String -> (Maybe GHCiOption)+strToGHCiOpt "m" = Just Multiline+strToGHCiOpt "s" = Just ShowTiming+strToGHCiOpt "t" = Just ShowType+strToGHCiOpt "r" = Just RevertCAFs+strToGHCiOpt _ = Nothing++optToStr :: GHCiOption -> String+optToStr Multiline = "m"+optToStr ShowTiming = "s"+optToStr ShowType = "t"+optToStr RevertCAFs = "r"+++-- ---------------------------------------------------------------------------+-- :show++showCmd :: String -> GHCi ()+showCmd "" = showOptions False+showCmd "-a" = showOptions True+showCmd str = do+ st <- getGHCiState+ case words str of+ ["args"] -> liftIO $ putStrLn (show (GhciMonad.args st))+ ["prog"] -> liftIO $ putStrLn (show (progname st))+ ["prompt"] -> liftIO $ putStrLn (show (prompt st))+ ["prompt2"] -> liftIO $ putStrLn (show (prompt2 st))+ ["editor"] -> liftIO $ putStrLn (show (editor st))+ ["stop"] -> liftIO $ putStrLn (show (stop st))+ ["imports"] -> showImports+ ["modules" ] -> showModules+ ["bindings"] -> showBindings+ ["linker"] ->+ do dflags <- getDynFlags+ liftIO $ showLinkerState dflags+ ["breaks"] -> showBkptTable+ ["context"] -> showContext+ ["packages"] -> showPackages+ ["paths"] -> showPaths+ ["languages"] -> showLanguages -- backwards compat+ ["language"] -> showLanguages+ ["lang"] -> showLanguages -- useful abbreviation+ _ -> throwGhcException (CmdLineError ("syntax: :show [ args | prog | prompt | prompt2 | editor | stop | modules\n" +++ " | bindings | breaks | context | packages | language ]"))++showiCmd :: String -> GHCi ()+showiCmd str = do+ case words str of+ ["languages"] -> showiLanguages -- backwards compat+ ["language"] -> showiLanguages+ ["lang"] -> showiLanguages -- useful abbreviation+ _ -> throwGhcException (CmdLineError ("syntax: :showi language"))++showImports :: GHCi ()+showImports = do+ st <- getGHCiState+ dflags <- getDynFlags+ let rem_ctx = reverse (remembered_ctx st)+ trans_ctx = transient_ctx st++ show_one (IIModule star_m)+ = ":module +*" ++ moduleNameString star_m+ show_one (IIDecl imp) = showPpr dflags imp++ prel_imp+ | any isPreludeImport (rem_ctx ++ trans_ctx) = []+ | not (xopt Opt_ImplicitPrelude dflags) = []+ | otherwise = ["import Prelude -- implicit"]++ trans_comment s = s ++ " -- added automatically"+ --+ liftIO $ mapM_ putStrLn (prel_imp ++ map show_one rem_ctx+ ++ map (trans_comment . show_one) trans_ctx)++showModules :: GHCi ()+showModules = do+ loaded_mods <- getLoadedModules+ -- we want *loaded* modules only, see #1734+ let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)+ mapM_ show_one loaded_mods++getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]+getLoadedModules = do+ graph <- GHC.getModuleGraph+ filterM (GHC.isLoaded . GHC.ms_mod_name) graph++showBindings :: GHCi ()+showBindings = do+ bindings <- GHC.getBindings+ (insts, finsts) <- GHC.getInsts+ docs <- mapM makeDoc (reverse bindings)+ -- reverse so the new ones come last+ let idocs = map GHC.pprInstanceHdr insts+ fidocs = map GHC.pprFamInst finsts+ mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)+ where+ makeDoc (AnId i) = pprTypeAndContents i+ makeDoc tt = do+ mb_stuff <- GHC.getInfo False (getName tt)+ return $ maybe (text "") pprTT mb_stuff++ pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc+ pprTT (thing, fixity, _cls_insts, _fam_insts)+ = pprTyThing thing+ $$ show_fixity+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> ppr (GHC.getName thing)+++printTyThing :: TyThing -> GHCi ()+printTyThing tyth = printForUser (pprTyThing tyth)++showBkptTable :: GHCi ()+showBkptTable = do+ st <- getGHCiState+ printForUser $ prettyLocations (breaks st)++showContext :: GHCi ()+showContext = do+ resumes <- GHC.getResumeContext+ printForUser $ vcat (map pp_resume (reverse resumes))+ where+ pp_resume res =+ ptext (sLit "--> ") <> text (GHC.resumeStmt res)+ $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res))++showPackages :: GHCi ()+showPackages = do+ dflags <- getDynFlags+ let pkg_flags = packageFlags dflags+ liftIO $ putStrLn $ showSDoc dflags $ vcat $+ text ("active package flags:"++if null pkg_flags then " none" else "")+ : map showFlag pkg_flags+ where showFlag (ExposePackage p) = text $ " -package " ++ p+ showFlag (HidePackage p) = text $ " -hide-package " ++ p+ showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p+ showFlag (ExposePackageId p) = text $ " -package-id " ++ p+ showFlag (TrustPackage p) = text $ " -trust " ++ p+ showFlag (DistrustPackage p) = text $ " -distrust " ++ p++showPaths :: GHCi ()+showPaths = do+ dflags <- getDynFlags+ liftIO $ do+ cwd <- getCurrentDirectory+ putStrLn $ showSDoc dflags $+ text "current working directory: " $$+ nest 2 (text cwd)+ let ipaths = importPaths dflags+ putStrLn $ showSDoc dflags $+ text ("module import search paths:"++if null ipaths then " none" else "") $$+ nest 2 (vcat (map text ipaths))++showLanguages :: GHCi ()+showLanguages = getDynFlags >>= liftIO . showLanguages' False++showiLanguages :: GHCi ()+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False++showLanguages' :: Bool -> DynFlags -> IO ()+showLanguages' show_all dflags =+ putStrLn $ showSDoc dflags $ vcat+ [ text "base language is: " <>+ case language dflags of+ Nothing -> text "Haskell2010"+ Just Haskell98 -> text "Haskell98"+ Just Haskell2010 -> text "Haskell2010"+ , (if show_all then text "all active language options:"+ else text "with the following modifiers:") $$+ nest 2 (vcat (map (setting xopt) DynFlags.xFlags))+ ]+ where+ setting test (str, f, _)+ | quiet = empty+ | is_on = text "-X" <> text str+ | otherwise = text "-XNo" <> text str+ where is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags =+ defaultDynFlags (settings dflags) `lang_set`+ case language dflags of+ Nothing -> Just Haskell2010+ other -> other++-- -----------------------------------------------------------------------------+-- Completion++completeCmd :: String -> GHCi ()+completeCmd argLine0 = case parseLine argLine0 of+ Just ("repl", resultRange, left) -> do+ (unusedLine,compls) <- ghciCompleteWord (reverse left,"")+ let compls' = takeRange resultRange compls+ liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]+ forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do+ liftIO $ print r+ _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")+ where+ parseLine argLine+ | null argLine = Nothing+ | null rest1 = Nothing+ | otherwise = (,,) dom <$> resRange <*> s+ where+ (dom, rest1) = breakSpace argLine+ (rng, rest2) = breakSpace rest1+ resRange | head rest1 == '"' = parseRange ""+ | otherwise = parseRange rng+ s | head rest1 == '"' = readMaybe rest1 :: Maybe String+ | otherwise = readMaybe rest2+ breakSpace = fmap (dropWhile isSpace) . break isSpace++ takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub++ -- syntax: [n-][m] with semantics "drop (n-1) . take m"+ parseRange :: String -> Maybe (Maybe Int,Maybe Int)+ parseRange s = case span isDigit s of+ (_, "") ->+ -- upper limit only+ Just (Nothing, bndRead s)+ (s1, '-' : s2)+ | all isDigit s2 ->+ Just (bndRead s1, bndRead s2)+ _ ->+ Nothing+ where+ bndRead x = if null x then Nothing else Just (read x)++++completeGhciCommand, completeMacro, completeIdentifier, completeModule,+ completeSetModule, completeSeti, completeShowiOptions,+ completeHomeModule, completeSetOptions, completeShowOptions,+ completeHomeModuleOrFile, completeExpression+ :: CompletionFunc GHCi++ghciCompleteWord :: CompletionFunc GHCi+ghciCompleteWord line@(left,_) = case firstWord of+ ':':cmd | null rest -> completeGhciCommand line+ | otherwise -> do+ completion <- lookupCompletion cmd+ completion line+ "import" -> completeModule line+ _ -> completeExpression line+ where+ (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left+ lookupCompletion ('!':_) = return completeFilename+ lookupCompletion c = do+ maybe_cmd <- lookupCommand' c+ case maybe_cmd of+ Just (_,_,f) -> return f+ Nothing -> return completeFilename++completeGhciCommand = wrapCompleter " " $ \w -> do+ macros <- liftIO $ readIORef macros_ref+ cmds <- ghci_commands `fmap` getGHCiState+ let macro_names = map (':':) . map cmdName $ macros+ let command_names = map (':':) . map cmdName $ cmds+ let{ candidates = case w of+ ':' : ':' : _ -> map (':':) command_names+ _ -> nub $ macro_names ++ command_names }+ return $ filter (w `isPrefixOf`) candidates++completeMacro = wrapIdentCompleter $ \w -> do+ cmds <- liftIO $ readIORef macros_ref+ return (filter (w `isPrefixOf`) (map cmdName cmds))++completeIdentifier = wrapIdentCompleter $ \w -> do+ rdrs <- GHC.getRdrNamesInScope+ dflags <- GHC.getSessionDynFlags+ return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))++completeModule = wrapIdentCompleter $ \w -> do+ dflags <- GHC.getSessionDynFlags+ let pkg_mods = allExposedModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) $ loaded_mods ++ pkg_mods++completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do+ dflags <- GHC.getSessionDynFlags+ modules <- case m of+ Just '-' -> do+ imports <- GHC.getContext+ return $ map iiModuleName imports+ _ -> do+ let pkg_mods = allExposedModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ loaded_mods ++ pkg_mods+ return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules++completeHomeModule = wrapIdentCompleter listHomeModules++listHomeModules :: String -> GHCi [String]+listHomeModules w = do+ g <- GHC.getModuleGraph+ let home_mods = map GHC.ms_mod_name g+ dflags <- getDynFlags+ return $ sort $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) home_mods++completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = "args":"prog":"prompt":"prompt2":"editor":"stop":flagList+ flagList = map head $ group $ sort allFlags++completeSeti = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) flagList)+ where flagList = map head $ group $ sort allFlags++completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = ["args", "prog", "prompt", "prompt2", "editor", "stop",+ "modules", "bindings", "linker", "breaks",+ "context", "packages", "paths", "language", "imports"]++completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) ["language"])++completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars+ $ unionComplete (fmap (map simpleCompletion) . listHomeModules)+ listFiles++unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]+unionComplete f1 f2 line = do+ cs1 <- f1 line+ cs2 <- f2 line+ return (cs1 ++ cs2)++wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi+wrapCompleter breakChars fun = completeWord Nothing breakChars+ $ fmap (map simpleCompletion) . fmap sort . fun++wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleter = wrapCompleter word_break_chars++wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars+ $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest)+ where+ getModifier = find (`elem` modifChars)++allExposedModules :: DynFlags -> [ModuleName]+allExposedModules dflags+ = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))+ where+ pkg_db = pkgIdMap (pkgState dflags)++completeExpression = completeQuotedWord (Just '\\') "\"" listFiles+ completeIdentifier+++-- -----------------------------------------------------------------------------+-- commands for debugger++sprintCmd, printCmd, forceCmd :: String -> GHCi ()+sprintCmd = pprintCommand False False+printCmd = pprintCommand True False+forceCmd = pprintCommand False True++pprintCommand :: Bool -> Bool -> String -> GHCi ()+pprintCommand bind force str = do+ pprintClosureCommand bind force str++stepCmd :: String -> GHCi ()+stepCmd arg = withSandboxOnly ":step" $ step arg+ where+ step [] = doContinue (const True) GHC.SingleStep+ step expression = runStmt expression GHC.SingleStep >> return ()++stepLocalCmd :: String -> GHCi ()+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just loc -> do+ Just md <- getCurrentBreakModule+ current_toplevel_decl <- enclosingTickSpan md loc+ doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep++stepModuleCmd :: String -> GHCi ()+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just pan -> do+ let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span+ doContinue f GHC.SingleStep++-- | Returns the span of the largest tick containing the srcspan given+enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"+enclosingTickSpan md (RealSrcSpan src) = do+ ticks <- getTickArray md+ let line = srcSpanStartLine src+ ASSERT(inRange (bounds ticks) line) do+ let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"+ toRealSrcSpan (RealSrcSpan s) = s+ enclosing_spans = [ pan | (_,pan) <- ticks ! line+ , realSrcSpanEnd (toRealSrcSpan pan) >= realSrcSpanEnd src]+ return . head . sortBy leftmost_largest $ enclosing_spans++traceCmd :: String -> GHCi ()+traceCmd arg+ = withSandboxOnly ":trace" $ tr arg+ where+ tr [] = doContinue (const True) GHC.RunAndLogSteps+ tr expression = runStmt expression GHC.RunAndLogSteps >> return ()++continueCmd :: String -> GHCi ()+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion++-- doContinue :: SingleStep -> GHCi ()+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()+doContinue pre step = do+ runResult <- resume pre step+ _ <- afterRunStmt pre runResult+ return ()++abandonCmd :: String -> GHCi ()+abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do+ b <- GHC.abandon -- the prompt will change to indicate the new context+ when (not b) $ liftIO $ putStrLn "There is no computation running."++deleteCmd :: String -> GHCi ()+deleteCmd argLine = withSandboxOnly ":delete" $ do+ deleteSwitch $ words argLine+ where+ deleteSwitch :: [String] -> GHCi ()+ deleteSwitch [] =+ liftIO $ putStrLn "The delete command requires at least one argument."+ -- delete all break points+ deleteSwitch ("*":_rest) = discardActiveBreakPoints+ deleteSwitch idents = do+ mapM_ deleteOneBreak idents+ where+ deleteOneBreak :: String -> GHCi ()+ deleteOneBreak str+ | all isDigit str = deleteBreak (read str)+ | otherwise = return ()++historyCmd :: String -> GHCi ()+historyCmd arg+ | null arg = history 20+ | all isDigit arg = history (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :history [num]"+ where+ history num = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> liftIO $ putStrLn "Not stopped at a breakpoint"+ (r:_) -> do+ let hist = GHC.resumeHistory r+ (took,rest) = splitAt num hist+ case hist of+ [] -> liftIO $ putStrLn $+ "Empty history. Perhaps you forgot to use :trace?"+ _ -> do+ pans <- mapM GHC.getHistorySpan took+ let nums = map (printf "-%-3d:") [(1::Int)..]+ names = map GHC.historyEnclosingDecls took+ printForUser (vcat(zipWith3+ (\x y z -> x <+> y <+> z)+ (map text nums)+ (map (bold . hcat . punctuate colon . map text) names)+ (map (parens . ppr) pans)))+ liftIO $ putStrLn $ if null rest then "<end of history>" else "..."++bold :: SDoc -> SDoc+bold c | do_bold = text start_bold <> c <> text end_bold+ | otherwise = c++backCmd :: String -> GHCi ()+backCmd = noArgs $ withSandboxOnly ":back" $ do+ (names, _, pan) <- GHC.back+ printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++forwardCmd :: String -> GHCi ()+forwardCmd = noArgs $ withSandboxOnly ":forward" $ do+ (names, ix, pan) <- GHC.forward+ printForUser $ (if (ix == 0)+ then ptext (sLit "Stopped at")+ else ptext (sLit "Logged breakpoint at")) <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++-- handle the "break" command+breakCmd :: String -> GHCi ()+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine++breakSwitch :: [String] -> GHCi ()+breakSwitch [] = do+ liftIO $ putStrLn "The break command requires at least one argument."+breakSwitch (arg1:rest)+ | looksLikeModuleName arg1 && not (null rest) = do+ md <- wantInterpretedModule arg1+ breakByModule md rest+ | all isDigit arg1 = do+ imports <- GHC.getContext+ case iiModules imports of+ (mn : _) -> do+ md <- lookupModuleName mn+ breakByModuleLine md (read arg1) rest+ [] -> do+ liftIO $ putStrLn "No modules are loaded with debugging support."+ | otherwise = do -- try parsing it as an identifier+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+ case loc of+ RealSrcLoc l ->+ ASSERT( isExternalName name )+ findBreakAndSet (GHC.nameModule name) $+ findBreakByCoord (Just (GHC.srcLocFile l))+ (GHC.srcLocLine l,+ GHC.srcLocCol l)+ UnhelpfulLoc _ ->+ noCanDo name $ text "can't find its location: " <> ppr loc+ where+ noCanDo n why = printForUser $+ text "cannot set breakpoint on " <> ppr n <> text ": " <> why++breakByModule :: Module -> [String] -> GHCi ()+breakByModule md (arg1:rest)+ | all isDigit arg1 = do -- looks like a line number+ breakByModuleLine md (read arg1) rest+breakByModule _ _+ = breakSyntax++breakByModuleLine :: Module -> Int -> [String] -> GHCi ()+breakByModuleLine md line args+ | [] <- args = findBreakAndSet md $ findBreakByLine line+ | [col] <- args, all isDigit col =+ findBreakAndSet md $ findBreakByCoord Nothing (line, read col)+ | otherwise = breakSyntax++breakSyntax :: a+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")++findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()+findBreakAndSet md lookupTickTree = do+ dflags <- getDynFlags+ tickArray <- getTickArray md+ (breakArray, _) <- getModBreak md+ case lookupTickTree tickArray of+ Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location."+ Just (tick, pan) -> do+ success <- liftIO $ setBreakFlag dflags True breakArray tick+ if success+ then do+ (alreadySet, nm) <-+ recordBreak $ BreakLocation+ { breakModule = md+ , breakLoc = pan+ , breakTick = tick+ , onBreakCmd = ""+ }+ printForUser $+ text "Breakpoint " <> ppr nm <>+ if alreadySet+ then text " was already set at " <> ppr pan+ else text " activated at " <> ppr pan+ else do+ printForUser $ text "Breakpoint could not be activated at"+ <+> ppr pan++-- When a line number is specified, the current policy for choosing+-- the best breakpoint is this:+-- - the leftmost complete subexpression on the specified line, or+-- - the leftmost subexpression starting on the specified line, or+-- - the rightmost subexpression enclosing the specified line+--+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)+findBreakByLine line arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (leftmost_largest `on` snd) comp) `mplus`+ listToMaybe (sortBy (leftmost_smallest `on` snd) incomp) `mplus`+ listToMaybe (sortBy (rightmost `on` snd) ticks)+ where+ ticks = arr ! line++ starts_here = [ tick | tick@(_,pan) <- ticks,+ GHC.srcSpanStartLine (toRealSpan pan) == line ]++ (comp, incomp) = partition ends_here starts_here+ where ends_here (_,pan) = GHC.srcSpanEndLine (toRealSpan pan) == line+ toRealSpan (RealSrcSpan pan) = pan+ toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan"++findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray+ -> Maybe (BreakIndex,SrcSpan)+findBreakByCoord mb_file (line, col) arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (rightmost `on` snd) contains +++ sortBy (leftmost_smallest `on` snd) after_here)+ where+ ticks = arr ! line++ -- the ticks that span this coordinate+ contains = [ tick | tick@(_,pan) <- ticks, pan `spans` (line,col),+ is_correct_file pan ]++ is_correct_file pan+ | Just f <- mb_file = GHC.srcSpanFile (toRealSpan pan) == f+ | otherwise = True++ after_here = [ tick | tick@(_,pan) <- ticks,+ let pan' = toRealSpan pan,+ GHC.srcSpanStartLine pan' == line,+ GHC.srcSpanStartCol pan' >= col ]++ toRealSpan (RealSrcSpan pan) = pan+ toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan"++-- For now, use ANSI bold on terminals that we know support it.+-- Otherwise, we add a line of carets under the active expression instead.+-- In particular, on Windows and when running the testsuite (which sets+-- TERM to vt100 for other reasons) we get carets.+-- We really ought to use a proper termcap/terminfo library.+do_bold :: Bool+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]+ where mTerm = System.Environment.getEnv "TERM"+ `catchIO` \_ -> return "TERM not set"++start_bold :: String+start_bold = "\ESC[1m"+end_bold :: String+end_bold = "\ESC[0m"+++-----------------------------------------------------------------------------+-- :list++listCmd :: String -> InputT GHCi ()+listCmd c = listCmd' c++listCmd' :: String -> InputT GHCi ()+listCmd' "" = do+ mb_span <- lift getCurrentBreakSpan+ case mb_span of+ Nothing ->+ printForUser $ text "Not stopped at a breakpoint; nothing to list"+ Just (RealSrcSpan pan) ->+ listAround pan True+ Just pan@(UnhelpfulSpan _) ->+ do resumes <- GHC.getResumeContext+ case resumes of+ [] -> panic "No resumes"+ (r:_) ->+ do let traceIt = case GHC.resumeHistory r of+ [] -> text "rerunning with :trace,"+ _ -> empty+ doWhat = traceIt <+> text ":back then :list"+ printForUser (text "Unable to list source for" <+>+ ppr pan+ $$ text "Try" <+> doWhat)+listCmd' str = list2 (words str)++list2 :: [String] -> InputT GHCi ()+list2 [arg] | all isDigit arg = do+ imports <- GHC.getContext+ case iiModules imports of+ [] -> liftIO $ putStrLn "No module to list"+ (mn : _) -> do+ md <- lift $ lookupModuleName mn+ listModuleLine md (read arg)+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do+ md <- wantInterpretedModule arg1+ listModuleLine md (read arg2)+list2 [arg] = do+ wantNameFromInterpretedModule noCanDo arg $ \name -> do+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+ case loc of+ RealSrcLoc l ->+ do tickArray <- ASSERT( isExternalName name )+ lift $ getTickArray (GHC.nameModule name)+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))+ (GHC.srcLocLine l, GHC.srcLocCol l)+ tickArray+ case mb_span of+ Nothing -> listAround (realSrcLocSpan l) False+ Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan"+ Just (_, RealSrcSpan pan) -> listAround pan False+ UnhelpfulLoc _ ->+ noCanDo name $ text "can't find its location: " <>+ ppr loc+ where+ noCanDo n why = printForUser $+ text "cannot list source code for " <> ppr n <> text ": " <> why+list2 _other =+ liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"++listModuleLine :: Module -> Int -> InputT GHCi ()+listModuleLine modl line = do+ graph <- GHC.getModuleGraph+ let this = filter ((== modl) . GHC.ms_mod) graph+ case this of+ [] -> panic "listModuleLine"+ summ:_ -> do+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))+ loc = mkRealSrcLoc (mkFastString (filename)) line 0+ listAround (realSrcLocSpan loc) False++-- | list a section of a source file around a particular SrcSpan.+-- If the highlight flag is True, also highlight the span using+-- start_bold\/end_bold.++-- GHC files are UTF-8, so we can implement this by:+-- 1) read the file in as a BS and syntax highlight it as before+-- 2) convert the BS to String using utf-string, and write it out.+-- It would be better if we could convert directly between UTF-8 and the+-- console encoding, of course.+listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()+listAround pan do_highlight = do+ contents <- liftIO $ BS.readFile (unpackFS file)+ let ls = BS.split '\n' contents+ ls' = take (line2 - line1 + 1 + pad_before + pad_after) $+ drop (line1 - 1 - pad_before) $ ls+ fst_line = max 1 (line1 - pad_before)+ line_nos = [ fst_line .. ]++ highlighted | do_highlight = zipWith highlight line_nos ls'+ | otherwise = [\p -> BS.concat[p,l] | l <- ls']++ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]+ prefixed = zipWith ($) highlighted bs_line_nos+ output = BS.intercalate (BS.pack "\n") prefixed++ utf8Decoded <- liftIO $ BS.useAsCStringLen output+ $ \(p,n) -> utf8DecodeString (castPtr p) n+ liftIO $ putStrLn utf8Decoded+ where+ file = GHC.srcSpanFile pan+ line1 = GHC.srcSpanStartLine pan+ col1 = GHC.srcSpanStartCol pan - 1+ line2 = GHC.srcSpanEndLine pan+ col2 = GHC.srcSpanEndCol pan - 1++ pad_before | line1 == 1 = 0+ | otherwise = 1+ pad_after = 1++ highlight | do_bold = highlight_bold+ | otherwise = highlight_carets++ highlight_bold no line prefix+ | no == line1 && no == line2+ = let (a,r) = BS.splitAt col1 line+ (b,c) = BS.splitAt (col2-col1) r+ in+ BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]+ | no == line1+ = let (a,b) = BS.splitAt col1 line in+ BS.concat [prefix, a, BS.pack start_bold, b]+ | no == line2+ = let (a,b) = BS.splitAt col2 line in+ BS.concat [prefix, a, BS.pack end_bold, b]+ | otherwise = BS.concat [prefix, line]++ highlight_carets no line prefix+ | no == line1 && no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',+ BS.replicate (col2-col1) '^']+ | no == line1+ = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,+ prefix, line]+ | no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',+ BS.pack "^^"]+ | otherwise = BS.concat [prefix, line]+ where+ indent = BS.pack (" " ++ replicate (length (show no)) ' ')+ nl = BS.singleton '\n'+++-- --------------------------------------------------------------------------+-- Tick arrays++getTickArray :: Module -> GHCi TickArray+getTickArray modl = do+ st <- getGHCiState+ let arrmap = tickarrays st+ case lookupModuleEnv arrmap modl of+ Just arr -> return arr+ Nothing -> do+ (_breakArray, ticks) <- getModBreak modl+ let arr = mkTickArray (assocs ticks)+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}+ return arr++discardTickArrays :: GHCi ()+discardTickArrays = do+ st <- getGHCiState+ setGHCiState st{tickarrays = emptyModuleEnv}++mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray+mkTickArray ticks+ = accumArray (flip (:)) [] (1, max_line)+ [ (line, (nm,pan)) | (nm,pan) <- ticks,+ let pan' = toRealSpan pan,+ line <- srcSpanLines pan' ]+ where+ max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks)+ srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]+ toRealSpan (RealSrcSpan pan) = pan+ toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan"++-- don't reset the counter back to zero?+discardActiveBreakPoints :: GHCi ()+discardActiveBreakPoints = do+ st <- getGHCiState+ mapM_ (turnOffBreak.snd) (breaks st)+ setGHCiState $ st { breaks = [] }++deleteBreak :: Int -> GHCi ()+deleteBreak identity = do+ st <- getGHCiState+ let oldLocations = breaks st+ (this,rest) = partition (\loc -> fst loc == identity) oldLocations+ if null this+ then printForUser (text "Breakpoint" <+> ppr identity <+>+ text "does not exist")+ else do+ mapM_ (turnOffBreak.snd) this+ setGHCiState $ st { breaks = rest }++turnOffBreak :: BreakLocation -> GHCi Bool+turnOffBreak loc = do+ dflags <- getDynFlags+ (arr, _) <- getModBreak (breakModule loc)+ liftIO $ setBreakFlag dflags False arr (breakTick loc)++getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)+getModBreak m = do+ Just mod_info <- GHC.getModuleInfo m+ let modBreaks = GHC.modInfoModBreaks mod_info+ let arr = GHC.modBreaks_flags modBreaks+ let ticks = GHC.modBreaks_locs modBreaks+ return (arr, ticks)++setBreakFlag :: DynFlags -> Bool -> GHC.BreakArray -> Int -> IO Bool+setBreakFlag dflags toggle arr i+ | toggle = GHC.setBreakOn dflags arr i+ | otherwise = GHC.setBreakOff dflags arr i+++-- ---------------------------------------------------------------------------+-- User code exception handling++-- This is the exception handler for exceptions generated by the+-- user's code and exceptions coming from children sessions;+-- it normally just prints out the exception. The+-- handler must be recursive, in case showing the exception causes+-- more exceptions to be raised.+--+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,+-- raising another exception. We therefore don't put the recursive+-- handler arond the flushing operation, so if stderr is closed+-- GHCi will just die gracefully rather than going into an infinite loop.+handler :: SomeException -> GHCi Bool++handler exception = do+ flushInterpBuffers+ liftIO installSignalHandlers+ ghciHandle handler (showException exception >> return False)++showException :: SomeException -> GHCi ()+showException se =+ liftIO $ case fromException se of+ -- omit the location for CmdLineError:+ Just (CmdLineError s) -> putException s+ -- ditto:+ Just ph@(PhaseFailed {}) -> putException (showGhcException ph "")+ Just other_ghc_ex -> putException (show other_ghc_ex)+ Nothing ->+ case fromException se of+ Just UserInterrupt -> putException "Interrupted."+ _ -> putException ("*** Exception: " ++ show se)+ where+ putException = hPutStrLn stderr+++-----------------------------------------------------------------------------+-- recursive exception handlers++-- Don't forget to unblock async exceptions in the handler, or if we're+-- in an exception loop (eg. let a = error a in a) the ^C exception+-- may never be delivered. Thanks to Marcin for pointing out the bug.++ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a+ghciHandle h m = gmask $ \restore -> do+ dflags <- getDynFlags+ gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)++ghciTry :: GHCi a -> GHCi (Either SomeException a)+ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)++tryBool :: GHCi a -> GHCi Bool+tryBool m = do+ r <- ghciTry m+ case r of+ Left _ -> return False+ Right _ -> return True++-- ----------------------------------------------------------------------------+-- Utils++lookupModule :: GHC.GhcMonad m => String -> m Module+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)++lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module+lookupModuleName mName = GHC.lookupModule mName Nothing++isHomeModule :: Module -> Bool+isHomeModule m = GHC.modulePackageId m == mainPackageId++-- TODO: won't work if home dir is encoded.+-- (changeDirectory may not work either in that case.)+expandPath :: MonadIO m => String -> InputT m String+expandPath = liftIO . expandPathIO++expandPathIO :: String -> IO String+expandPathIO p =+ case dropWhile isSpace p of+ ('~':d) -> do+ tilde <- getHomeDirectory -- will fail if HOME not defined+ return (tilde ++ '/':d)+ other ->+ return other++wantInterpretedModule :: GHC.GhcMonad m => String -> m Module+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)++wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module+wantInterpretedModuleName modname = do+ modl <- lookupModuleName modname+ let str = moduleNameString modname+ dflags <- getDynFlags+ when (GHC.modulePackageId modl /= thisPackage dflags) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))+ is_interpreted <- GHC.moduleIsInterpreted modl+ when (not is_interpreted) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))+ return modl++wantNameFromInterpretedModule :: GHC.GhcMonad m+ => (Name -> SDoc -> m ())+ -> String+ -> (Name -> m ())+ -> m ()+wantNameFromInterpretedModule noCanDo str and_then =+ handleSourceError GHC.printException $ do+ names <- GHC.parseName str+ case names of+ [] -> return ()+ (n:_) -> do+ let modl = ASSERT( isExternalName n ) GHC.nameModule n+ if not (GHC.isExternalName n)+ then noCanDo n $ ppr n <>+ text " is not defined in an interpreted module"+ else do+ is_interpreted <- GHC.moduleIsInterpreted modl+ if not is_interpreted+ then noCanDo n $ text "module " <> ppr modl <>+ text " is not interpreted"+ else and_then n
+ src-bin/Main.hs view
@@ -0,0 +1,890 @@+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Main (main) where++-- The official GHC API+import qualified GHC+import GHC ( -- DynFlags(..), HscTarget(..),+ -- GhcMode(..), GhcLink(..),+ Ghc, GhcMonad(..),+ LoadHowMuch(..) )+import CmdLineParser++-- Implementations of the various modes (--show-iface, mkdependHS. etc.)+import LoadIface ( showIface )+import HscMain ( newHscEnv )+import DriverPipeline ( oneShot, compileFile )+import DriverMkDepend ( doMkDependHS )+#ifdef GHCI+import InteractiveUI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )+#endif+++-- Various other random stuff that we need+import Config+import Constants+import HscTypes+import Packages ( dumpPackages )+import DriverPhases+import BasicTypes ( failed )+import StaticFlags+import DynFlags+import ErrUtils+import FastString+import Outputable+import SrcLoc+import Util+import Panic+import MonadUtils ( liftIO )++-- Imports for --abi-hash+import LoadIface ( loadUserInterface )+import Module ( mkModuleName )+import Finder ( findImportedModule, cannotFindInterface )+import TcRnMonad ( initIfaceCheck )+import Binary ( openBinMem, put_, fingerprintBinMem )++-- Standard Haskell libraries+import System.IO+import System.Environment+import System.Exit+import System.FilePath+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe++-- clash additions+#ifdef STANDALONE+import System.Process (runInteractiveCommand, waitForProcess)+import qualified Control.Exception as Exception+#else+import qualified GHC.Paths+import Paths_clash_ghc+#endif+import Exception (gcatch)+import Control.Exception (ErrorCall (..))+import qualified CLaSH.Driver+import CLaSH.GHC.GenerateBindings+import CLaSH.GHC.NetlistTypes+import qualified CLaSH.Primitives.Util+import CLaSH.Rewrite.Types (DebugLevel(..))++#ifdef STANDALONE+ghcLibDir :: IO FilePath+ghcLibDir = do (libDir,exitCode) <- getProcessOutput "ghc --print-libdir"+ case exitCode of+ ExitSuccess -> return libDir+ ExitFailure i -> error $ "Calling GHC failed with: " ++ show i++getProcessOutput :: String -> IO (String, ExitCode)+getProcessOutput command =+ -- Create the process+ do (_, pOut, _, handle) <- runInteractiveCommand command+ -- Wait for the process to finish and store its exit code+ exitCode <- waitForProcess handle+ -- Get the standard output.+ output <- hGetLine pOut+ -- return both the output and the exit code.+ return (output, exitCode)++getDefPrimDir :: IO FilePath+getDefPrimDir = catchIO (getEnv "CLASH_PRIMDIR") (error "Environment variable \"CLASH_PRIMDIR\" undefined")++catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+catchIO = Exception.catch+#else+ghcLibDir :: IO FilePath+ghcLibDir = return GHC.Paths.libdir++getDefPrimDir :: IO FilePath+getDefPrimDir = getDataFileName "primitives"+#endif+++-----------------------------------------------------------------------------+-- ToDo:++-- time commands when run with -v+-- user ways+-- Win32 support: proper signal handling+-- reading the package configuration file is too slow+-- -K<size>++-----------------------------------------------------------------------------+-- GHC's command-line interface++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering+ GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+ -- 1. extract the -B flag from the args+ argv0 <- getArgs+ libDir <- ghcLibDir++ let argv1 = map (mkGeneralLocated "on the commandline") argv0+ (argv2, staticFlagWarnings) <- parseStaticFlags argv1++ -- 2. Parse the "mode" flags (--make, --interactive etc.)+ (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2++ let flagWarnings = staticFlagWarnings ++ modeFlagWarnings++ -- If all we want to do is something like showing the version number+ -- then do it now, before we start a GHC session etc. This makes+ -- getting basic information much more resilient.++ -- In particular, if we wait until later before giving the version+ -- number then bootstrapping gets confused, as it tries to find out+ -- what version of GHC it's using before package.conf exists, so+ -- starting the session fails.+ case mode of+ Left preStartupMode ->+ do case preStartupMode of+ ShowSupportedExtensions -> showSupportedExtensions+ ShowVersion -> showVersion+ ShowNumVersion -> putStrLn cProjectVersion+ ShowOptions -> showOptions+ Right postStartupMode ->+ -- start our GHC session+ GHC.runGhc (Just libDir) $ do++ dflags <- GHC.getSessionDynFlags+ let dflagsExtra = foldl DynFlags.xopt_set+ dflags+ [ DynFlags.Opt_TemplateHaskell+ , DynFlags.Opt_Arrows+ , DynFlags.Opt_DataKinds+ ]++ case postStartupMode of+ Left preLoadMode ->+ liftIO $ do+ case preLoadMode of+ ShowInfo -> showInfo dflags+ ShowGhcUsage -> showGhcUsage dflags+ ShowGhciUsage -> showGhciUsage dflags+ PrintWithDynFlags f -> putStrLn (f dflags)+ Right postLoadMode ->+ main' postLoadMode dflagsExtra argv3 flagWarnings++main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]+ -> Ghc ()+main' postLoadMode dflags0 args flagWarnings = do+ -- set the default GhcMode, HscTarget and GhcLink. The HscTarget+ -- can be further adjusted on a module by module basis, using only+ -- the -fvia-C and -fasm flags. If the default HscTarget is not+ -- HscC or HscAsm, -fvia-C and -fasm have no effect.+ let dflt_target = hscTarget dflags0+ (mode, lang, link)+ = case postLoadMode of+ DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)+ DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)+ DoMake -> (CompManager, dflt_target, LinkBinary)+ DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)+ DoAbiHash -> (OneShot, dflt_target, LinkBinary)+ DoVHDL -> (CompManager, dflt_target, LinkInMemory)+ _ -> (OneShot, dflt_target, LinkBinary)++ let dflags1 = case lang of+ HscInterpreted ->+ let platform = targetPlatform dflags0+ dflags0a = updateWays $ dflags0 { ways = interpWays }+ dflags0b = foldl gopt_set dflags0a+ $ concatMap (wayGeneralFlags platform)+ interpWays+ dflags0c = foldl gopt_unset dflags0b+ $ concatMap (wayUnsetGeneralFlags platform)+ interpWays+ in dflags0c+ _ ->+ dflags0+ dflags2 = dflags1{ ghcMode = mode,+ hscTarget = lang,+ ghcLink = link,+ verbosity = case postLoadMode of+ DoEval _ -> 0+ _other -> 1+ }++ -- turn on -fimplicit-import-qualified for GHCi now, so that it+ -- can be overriden from the command-line+ -- XXX: this should really be in the interactive DynFlags, but+ -- we don't set that until later in interactiveUI+ dflags3 | DoInteractive <- postLoadMode = imp_qual_enabled+ | DoEval _ <- postLoadMode = imp_qual_enabled+ | otherwise = dflags2+ where imp_qual_enabled = dflags2 `gopt_set` Opt_ImplicitImportQualified++ -- The rest of the arguments are "dynamic"+ -- Leftover ones are presumably files+ (dflags4, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags3 args++ GHC.prettyPrintGhcErrors dflags4 $ do++ let flagWarnings' = flagWarnings ++ dynamicFlagWarnings++ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ liftIO $ handleFlagWarnings dflags4 flagWarnings'++ -- make sure we clean up after ourselves+ GHC.defaultCleanupHandler dflags4 $ do++ liftIO $ showBanner postLoadMode dflags4++ let+ -- To simplify the handling of filepaths, we normalise all filepaths right+ -- away - e.g., for win32 platforms, backslashes are converted+ -- into forward slashes.+ normal_fileish_paths = map (normalise . unLoc) fileish_args+ (srcs, objs) = partition_args normal_fileish_paths [] []++ dflags5 = dflags4 { ldInputs = map (FileOption "") objs+ ++ ldInputs dflags4 }++ -- we've finished manipulating the DynFlags, update the session+ _ <- GHC.setSessionDynFlags dflags5+ dflags6 <- GHC.getSessionDynFlags+ hsc_env <- GHC.getSession++ ---------------- Display configuration -----------+ when (verbosity dflags6 >= 4) $+ liftIO $ dumpPackages dflags6++ when (verbosity dflags6 >= 3) $ do+ liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)++ ---------------- Final sanity checking -----------+ liftIO $ checkOptions postLoadMode dflags6 srcs objs++ ---------------- Do the business -----------+ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ case postLoadMode of+ ShowInterface f -> liftIO $ doShowIface dflags6 f+ DoMake -> doMake srcs+ DoMkDependHS -> doMkDependHS (map fst srcs)+ StopBefore p -> liftIO (oneShot hsc_env p srcs)+ DoInteractive -> ghciUI srcs Nothing+ DoEval exprs -> ghciUI srcs $ Just $ reverse exprs+ DoAbiHash -> abiHash srcs+ DoVHDL -> gcatch (doVHDL srcs) (\(ErrorCall e) -> throwOneError $ mkPlainErrMsg dflags6 noSrcSpan (text ("CLaSH Error:\n" ++ e)))++ liftIO $ dumpFinalStats dflags6++ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()+#ifndef GHCI+ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use")+#else+ghciUI = interactiveUI defaultGhciSettings+#endif++-- -----------------------------------------------------------------------------+-- Splitting arguments into source files and object files. This is where we+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source+-- file indicating the phase specified by the -x option in force, if any.++partition_args :: [String] -> [(String, Maybe Phase)] -> [String]+ -> ([(String, Maybe Phase)], [String])+partition_args [] srcs objs = (reverse srcs, reverse objs)+partition_args ("-x":suff:args) srcs objs+ | "none" <- suff = partition_args args srcs objs+ | StopLn <- phase = partition_args args srcs (slurp ++ objs)+ | otherwise = partition_args rest (these_srcs ++ srcs) objs+ where phase = startPhase suff+ (slurp,rest) = break (== "-x") args+ these_srcs = zip slurp (repeat (Just phase))+partition_args (arg:args) srcs objs+ | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs+ | otherwise = partition_args args srcs (arg:objs)++ {-+ We split out the object files (.o, .dll) and add them+ to ldInputs for use by the linker.++ The following things should be considered compilation manager inputs:++ - haskell source files (strings ending in .hs, .lhs or other+ haskellish extension),++ - module names (not forgetting hierarchical module names),++ - things beginning with '-' are flags that were not recognised by+ the flag parser, and we want them to generate errors later in+ checkOptions, so we class them as source files (#5921)++ - and finally we consider everything not containing a '.' to be+ a comp manager input, as shorthand for a .hs or .lhs filename.++ Everything else is considered to be a linker object, and passed+ straight through to the linker.+ -}+looks_like_an_input :: String -> Bool+looks_like_an_input m = isSourceFilename m+ || looksLikeModuleName m+ || "-" `isPrefixOf` m+ || '.' `notElem` m++-- -----------------------------------------------------------------------------+-- Option sanity checks++-- | Ensure sanity of options.+--+-- Throws 'UsageError' or 'CmdLineError' if not.+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()+ -- Final sanity checking before kicking off a compilation (pipeline).+checkOptions mode dflags srcs objs = do+ -- Complain about any unknown flags+ let unknown_opts = [ f | (f@('-':_), _) <- srcs ]+ when (notNull unknown_opts) (unknownFlagsErr unknown_opts)++ when (notNull (filter wayRTSOnly (ways dflags))+ && isInterpretiveMode mode) $+ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")++ -- -prof and --interactive are not a good combination+ when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)+ && isInterpretiveMode mode) $+ do throwGhcException (UsageError+ "--interactive can't be used with -prof or -unreg.")+ -- -ohi sanity check+ if (isJust (outputHi dflags) &&+ (isCompManagerMode mode || srcs `lengthExceeds` 1))+ then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")+ else do++ -- -o sanity checking+ if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)+ && not (isLinkMode mode))+ then throwGhcException (UsageError "can't apply -o to multiple source files")+ else do++ let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)++ when (not_linking && not (null objs)) $+ hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)++ -- Check that there are some input files+ -- (except in the interactive case)+ if null srcs && (null objs || not_linking) && needsInputsMode mode+ then throwGhcException (UsageError "no input files")+ else do++ -- Verify that output files point somewhere sensible.+ verifyOutputFiles dflags+++-- Compiler output options++-- called to verify that the output files & directories+-- point somewhere valid.+--+-- The assumption is that the directory portion of these output+-- options will have to exist by the time 'verifyOutputFiles'+-- is invoked.+--+verifyOutputFiles :: DynFlags -> IO ()+verifyOutputFiles dflags = do+ -- not -odir: we create the directory for -odir if it doesn't exist (#2278).+ let ofile = outputFile dflags+ when (isJust ofile) $ do+ let fn = fromJust ofile+ flg <- doesDirNameExist fn+ when (not flg) (nonExistentDir "-o" fn)+ let ohi = outputHi dflags+ when (isJust ohi) $ do+ let hi = fromJust ohi+ flg <- doesDirNameExist hi+ when (not flg) (nonExistentDir "-ohi" hi)+ where+ nonExistentDir flg dir =+ throwGhcException (CmdLineError ("error: directory portion of " +++ show dir ++ " does not exist (used with " +++ show flg ++ " option.)"))++-----------------------------------------------------------------------------+-- GHC modes of operation++type Mode = Either PreStartupMode PostStartupMode+type PostStartupMode = Either PreLoadMode PostLoadMode++data PreStartupMode+ = ShowVersion -- ghc -V/--version+ | ShowNumVersion -- ghc --numeric-version+ | ShowSupportedExtensions -- ghc --supported-extensions+ | ShowOptions -- ghc --show-options++showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode+showVersionMode = mkPreStartupMode ShowVersion+showNumVersionMode = mkPreStartupMode ShowNumVersion+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions+showOptionsMode = mkPreStartupMode ShowOptions++mkPreStartupMode :: PreStartupMode -> Mode+mkPreStartupMode = Left++isShowVersionMode :: Mode -> Bool+isShowVersionMode (Left ShowVersion) = True+isShowVersionMode _ = False++isShowNumVersionMode :: Mode -> Bool+isShowNumVersionMode (Left ShowNumVersion) = True+isShowNumVersionMode _ = False++data PreLoadMode+ = ShowGhcUsage -- ghc -?+ | ShowGhciUsage -- ghci -?+ | ShowInfo -- ghc --info+ | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo++showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode+showGhcUsageMode = mkPreLoadMode ShowGhcUsage+showGhciUsageMode = mkPreLoadMode ShowGhciUsage+showInfoMode = mkPreLoadMode ShowInfo++printSetting :: String -> Mode+printSetting k = mkPreLoadMode (PrintWithDynFlags f)+ where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))+ $ lookup k (compilerInfo dflags)++mkPreLoadMode :: PreLoadMode -> Mode+mkPreLoadMode = Right . Left++isShowGhcUsageMode :: Mode -> Bool+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True+isShowGhcUsageMode _ = False++isShowGhciUsageMode :: Mode -> Bool+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True+isShowGhciUsageMode _ = False++data PostLoadMode+ = ShowInterface FilePath -- ghc --show-iface+ | DoMkDependHS -- ghc -M+ | StopBefore Phase -- ghc -E | -C | -S+ -- StopBefore StopLn is the default+ | DoMake -- ghc --make+ | DoInteractive -- ghc --interactive+ | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]+ | DoAbiHash -- ghc --abi-hash+ | DoVHDL -- ghc --vhdl++doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode, doVHDLMode :: Mode+doMkDependHSMode = mkPostLoadMode DoMkDependHS+doMakeMode = mkPostLoadMode DoMake+doInteractiveMode = mkPostLoadMode DoInteractive+doAbiHashMode = mkPostLoadMode DoAbiHash+doVHDLMode = mkPostLoadMode DoVHDL++showInterfaceMode :: FilePath -> Mode+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)++stopBeforeMode :: Phase -> Mode+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)++doEvalMode :: String -> Mode+doEvalMode str = mkPostLoadMode (DoEval [str])++mkPostLoadMode :: PostLoadMode -> Mode+mkPostLoadMode = Right . Right++isDoInteractiveMode :: Mode -> Bool+isDoInteractiveMode (Right (Right DoInteractive)) = True+isDoInteractiveMode _ = False++isStopLnMode :: Mode -> Bool+isStopLnMode (Right (Right (StopBefore StopLn))) = True+isStopLnMode _ = False++isDoMakeMode :: Mode -> Bool+isDoMakeMode (Right (Right DoMake)) = True+isDoMakeMode _ = False++#ifdef GHCI+isInteractiveMode :: PostLoadMode -> Bool+isInteractiveMode DoInteractive = True+isInteractiveMode _ = False+#endif++-- isInterpretiveMode: byte-code compiler involved+isInterpretiveMode :: PostLoadMode -> Bool+isInterpretiveMode DoInteractive = True+isInterpretiveMode (DoEval _) = True+isInterpretiveMode _ = False++needsInputsMode :: PostLoadMode -> Bool+needsInputsMode DoMkDependHS = True+needsInputsMode (StopBefore _) = True+needsInputsMode DoMake = True+needsInputsMode DoVHDL = True+needsInputsMode _ = False++-- True if we are going to attempt to link in this mode.+-- (we might not actually link, depending on the GhcLink flag)+isLinkMode :: PostLoadMode -> Bool+isLinkMode (StopBefore StopLn) = True+isLinkMode DoMake = True+isLinkMode DoInteractive = True+isLinkMode (DoEval _) = True+isLinkMode DoVHDL = True+isLinkMode _ = False++isCompManagerMode :: PostLoadMode -> Bool+isCompManagerMode DoMake = True+isCompManagerMode DoInteractive = True+isCompManagerMode (DoEval _) = True+isCompManagerMode DoVHDL = True+isCompManagerMode _ = False++-- -----------------------------------------------------------------------------+-- Parsing the mode flag++parseModeFlags :: [Located String]+ -> IO (Mode,+ [Located String],+ [Located String])+parseModeFlags args = do+ let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =+ runCmdLine (processArgs mode_flags args)+ (Nothing, [], [])+ mode = case mModeFlag of+ Nothing -> doMakeMode+ Just (m, _) -> m+ errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2+ when (not (null errs)) $ throwGhcException $ errorsToGhcException errs+ return (mode, flags' ++ leftover, warns)++type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])+ -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)+ -- so we collect the new ones and return them.++mode_flags :: [Flag ModeM]+mode_flags =+ [ ------- help / version ----------------------------------------------+ Flag "?" (PassFlag (setMode showGhcUsageMode))+ , Flag "-help" (PassFlag (setMode showGhcUsageMode))+ , Flag "V" (PassFlag (setMode showVersionMode))+ , Flag "-version" (PassFlag (setMode showVersionMode))+ , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))+ , Flag "-info" (PassFlag (setMode showInfoMode))+ , Flag "-show-options" (PassFlag (setMode showOptionsMode))+ , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))+ , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))+ ] +++ [ Flag k' (PassFlag (setMode (printSetting k)))+ | k <- ["Project version",+ "Booter version",+ "Stage",+ "Build platform",+ "Host platform",+ "Target platform",+ "Have interpreter",+ "Object splitting supported",+ "Have native code generator",+ "Support SMP",+ "Unregisterised",+ "Tables next to code",+ "RTS ways",+ "Leading underscore",+ "Debug on",+ "LibDir",+ "Global Package DB",+ "C compiler flags",+ "Gcc Linker flags",+ "Ld Linker flags"],+ let k' = "-print-" ++ map (replaceSpace . toLower) k+ replaceSpace ' ' = '-'+ replaceSpace c = c+ ] +++ ------- interfaces ----------------------------------------------------+ [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)+ "--show-iface"))++ ------- primary modes ------------------------------------------------+ , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f+ addFlag "-no-link" f))+ , Flag "M" (PassFlag (setMode doMkDependHSMode))+ , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))+ , Flag "C" (PassFlag (setMode (stopBeforeMode HCc)))+ , Flag "S" (PassFlag (setMode (stopBeforeMode As)))+ , Flag "-make" (PassFlag (setMode doMakeMode))+ , Flag "-interactive" (PassFlag (setMode doInteractiveMode))+ , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))+ , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))+ , Flag "-vhdl" (PassFlag (setMode doVHDLMode))+ ]++setMode :: Mode -> String -> EwM ModeM ()+setMode newMode newFlag = liftEwM $ do+ (mModeFlag, errs, flags') <- getCmdLineState+ let (modeFlag', errs') =+ case mModeFlag of+ Nothing -> ((newMode, newFlag), errs)+ Just (oldMode, oldFlag) ->+ case (oldMode, newMode) of+ -- -c/--make are allowed together, and mean --make -no-link+ _ | isStopLnMode oldMode && isDoMakeMode newMode+ || isStopLnMode newMode && isDoMakeMode oldMode ->+ ((doMakeMode, "--make"), [])++ -- If we have both --help and --interactive then we+ -- want showGhciUsage+ _ | isShowGhcUsageMode oldMode &&+ isDoInteractiveMode newMode ->+ ((showGhciUsageMode, oldFlag), [])+ | isShowGhcUsageMode newMode &&+ isDoInteractiveMode oldMode ->+ ((showGhciUsageMode, newFlag), [])+ -- Otherwise, --help/--version/--numeric-version always win+ | isDominantFlag oldMode -> ((oldMode, oldFlag), [])+ | isDominantFlag newMode -> ((newMode, newFlag), [])+ -- We need to accumulate eval flags like "-e foo -e bar"+ (Right (Right (DoEval esOld)),+ Right (Right (DoEval [eNew]))) ->+ ((Right (Right (DoEval (eNew : esOld))), oldFlag),+ errs)+ -- Saying e.g. --interactive --interactive is OK+ _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)+ -- Otherwise, complain+ _ -> let err = flagMismatchErr oldFlag newFlag+ in ((oldMode, oldFlag), err : errs)+ putCmdLineState (Just modeFlag', errs', flags')+ where isDominantFlag f = isShowGhcUsageMode f ||+ isShowGhciUsageMode f ||+ isShowVersionMode f ||+ isShowNumVersionMode f++flagMismatchErr :: String -> String -> String+flagMismatchErr oldFlag newFlag+ = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"++addFlag :: String -> String -> EwM ModeM ()+addFlag s flag = liftEwM $ do+ (m, e, flags') <- getCmdLineState+ putCmdLineState (m, e, mkGeneralLocated loc s : flags')+ where loc = "addFlag by " ++ flag ++ " on the commandline"++-- ----------------------------------------------------------------------------+-- Run --make mode++doMake :: [(String,Maybe Phase)] -> Ghc ()+doMake srcs = do+ let (hs_srcs, non_hs_srcs) = partition haskellish srcs++ haskellish (f,Nothing) =+ looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f+ haskellish (_,Just phase) =+ phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]++ hsc_env <- GHC.getSession++ -- if we have no haskell sources from which to do a dependency+ -- analysis, then just do one-shot compilation and/or linking.+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as+ -- we expect.+ if (null hs_srcs)+ then liftIO (oneShot hsc_env StopLn srcs)+ else do++ o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)+ non_hs_srcs+ dflags <- GHC.getSessionDynFlags+ let dflags' = dflags { ldInputs = map (FileOption "") o_files+ ++ ldInputs dflags }+ _ <- GHC.setSessionDynFlags dflags'++ targets <- mapM (uncurry GHC.guessTarget) hs_srcs+ GHC.setTargets targets+ ok_flag <- GHC.load LoadAllTargets++ when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))+ return ()+++-- ---------------------------------------------------------------------------+-- --show-iface mode++doShowIface :: DynFlags -> FilePath -> IO ()+doShowIface dflags file = do+ hsc_env <- newHscEnv dflags+ showIface hsc_env file++-- ---------------------------------------------------------------------------+-- Various banners and verbosity output.++showBanner :: PostLoadMode -> DynFlags -> IO ()+showBanner _postLoadMode dflags = do+ let verb = verbosity dflags++#ifdef GHCI+ -- Show the GHCi banner+ when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg+#endif++ -- Display details of the configuration in verbose mode+ when (verb >= 2) $+ do hPutStr stderr "Glasgow Haskell Compiler, Version "+ hPutStr stderr cProjectVersion+ hPutStr stderr ", stage "+ hPutStr stderr cStage+ hPutStr stderr " booted by GHC version "+ hPutStrLn stderr cBooterVersion++-- We print out a Read-friendly string, but a prettier one than the+-- Show instance gives us+showInfo :: DynFlags -> IO ()+showInfo dflags = do+ let sq x = " [" ++ x ++ "\n ]"+ putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags++showSupportedExtensions :: IO ()+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions++showVersion :: IO ()+showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)++showOptions :: IO ()+showOptions = putStr (unlines availableOptions)+ where+ availableOptions = map ((:) '-') $+ getFlagNames mode_flags +++ getFlagNames flagsDynamic +++ (filterUnwantedStatic . getFlagNames $ flagsStatic) +++ flagsStaticNames+ getFlagNames opts = map getFlagName opts+ getFlagName (Flag name _) = name+ -- this is a hack to get rid of two unwanted entries that get listed+ -- as static flags. Hopefully this hack will disappear one day together+ -- with static flags+ filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"]))++showGhcUsage :: DynFlags -> IO ()+showGhcUsage = showUsage False++showGhciUsage :: DynFlags -> IO ()+showGhciUsage = showUsage True++showUsage :: Bool -> DynFlags -> IO ()+showUsage ghci dflags = do+ let usage_path = if ghci then ghciUsagePath dflags+ else ghcUsagePath dflags+ usage <- readFile usage_path+ dump usage+ where+ dump "" = return ()+ dump ('$':'$':s) = putStr progName >> dump s+ dump (c:s) = putChar c >> dump s++dumpFinalStats :: DynFlags -> IO ()+dumpFinalStats dflags =+ when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags++dumpFastStringStats :: DynFlags -> IO ()+dumpFastStringStats dflags = do+ buckets <- getFastStringTable+ let (entries, longest, has_z) = countFS 0 0 0 buckets+ msg = text "FastString stats:" $$+ nest 4 (vcat [text "size: " <+> int (length buckets),+ text "entries: " <+> int entries,+ text "longest chain: " <+> int longest,+ text "has z-encoding: " <+> (has_z `pcntOf` entries)+ ])+ -- we usually get more "has z-encoding" than "z-encoded", because+ -- when we z-encode a string it might hash to the exact same string,+ -- which will is not counted as "z-encoded". Only strings whose+ -- Z-encoding is different from the original string are counted in+ -- the "z-encoded" total.+ putMsg dflags msg+ where+ x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'++countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)+countFS entries longest has_z [] = (entries, longest, has_z)+countFS entries longest has_z (b:bs) =+ let+ len = length b+ longest' = max len longest+ entries' = entries + len+ has_zs = length (filter hasZEncoding b)+ in+ countFS entries' longest' (has_z + has_zs) bs++-- -----------------------------------------------------------------------------+-- ABI hash support++{-+ ghc --abi-hash Data.Foo System.Bar++Generates a combined hash of the ABI for modules Data.Foo and+System.Bar. The modules must already be compiled, and appropriate -i+options may be necessary in order to find the .hi files.++This is used by Cabal for generating the InstalledPackageId for a+package. The InstalledPackageId must change when the visible ABI of+the package chagnes, so during registration Cabal calls ghc --abi-hash+to get a hash of the package's ABI.+-}++abiHash :: [(String, Maybe Phase)] -> Ghc ()+abiHash strs = do+ hsc_env <- getSession+ let dflags = hsc_dflags hsc_env++ liftIO $ do++ let find_it str = do+ let modname = mkModuleName str+ r <- findImportedModule hsc_env modname Nothing+ case r of+ Found _ m -> return m+ _error -> throwGhcException $ CmdLineError $ showSDoc dflags $+ cannotFindInterface dflags modname r++ mods <- mapM find_it (map fst strs)++ let get_iface modl = loadUserInterface False (text "abiHash") modl+ ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods++ bh <- openBinMem (3*1024) -- just less than a block+ put_ bh hiVersion+ -- package hashes change when the compiler version changes (for now)+ -- see #5328+ mapM_ (put_ bh . mi_mod_hash) ifaces+ f <- fingerprintBinMem bh++ putStrLn (showPpr dflags f)++-- -----------------------------------------------------------------------------+-- VHDL Generation++doVHDL :: [(String,Maybe Phase)] -> Ghc ()+doVHDL [] = throwGhcException (CmdLineError "No input files")+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+ ) srcs++-- -----------------------------------------------------------------------------+-- Util++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs+ where+ oneError f =+ "unrecognised flag: " ++ f ++ "\n" +++ (case fuzzyMatch f (nub allFlags) of+ [] -> ""+ suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))
+ src-bin/PosixSource.h view
@@ -0,0 +1,42 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2005+ *+ * Include this file into sources which should not need any non-Posix services.+ * That includes most RTS C sources.+ * ---------------------------------------------------------------------------*/++#ifndef POSIXSOURCE_H+#define POSIXSOURCE_H++#include <ghcplatform.h>++#if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS)+#define _POSIX_C_SOURCE 200112L+#define _XOPEN_SOURCE 600+#else+#define _POSIX_SOURCE 1+#define _POSIX_C_SOURCE 199506L+#define _XOPEN_SOURCE 500+// FreeBSD takes a different approach to _ISOC99_SOURCE: on FreeBSD it+// means "I want *just* C99 things", whereas on GNU libc and Solaris+// it means "I also want C99 things". +//+// On both GNU libc and FreeBSD, _ISOC99_SOURCE is implied by+// _XOPEN_SOURCE==600, but on Solaris it is an error to omit it.+#define _ISOC99_SOURCE+// Defining __USE_MINGW_ANSI_STDIO is the most portable way to tell+// mingw that we want to use the standard %lld style format specifiers,+// rather than the Windows %I64d style+#define __USE_MINGW_ANSI_STDIO 1+#endif++#if defined(darwin_HOST_OS)+/* If we don't define this the including sysctl breaks with things like+ /usr/include/bsm/audit.h:224:0:+ error: syntax error before 'u_char'+*/+#define _DARWIN_C_SOURCE 1+#endif++#endif /* POSIXSOURCE_H */
+ src-bin/hschooks.c view
@@ -0,0 +1,47 @@+/*+These routines customise the error messages+for various bits of the RTS. They are linked+in instead of the defaults.+*/++#include "PosixSource.h"+#include "Rts.h"++#include "HsFFI.h"++#include <string.h>++#ifdef HAVE_UNISTD_H+#include <unistd.h>+#endif++void+defaultsHook (void)+{+#if __GLASGOW_HASKELL__ >= 707+ // This helps particularly with large compiles, but didn't work+ // very well with earlier GHCs because it caused large amounts of+ // fragmentation. See rts/sm/BlockAlloc.c:allocLargeChunk().+ RtsFlags.GcFlags.heapSizeSuggestionAuto = rtsTrue;+#else+ RtsFlags.GcFlags.heapSizeSuggestion = 6*1024*1024 / BLOCK_SIZE;+#endif++ RtsFlags.GcFlags.maxStkSize = 512*1024*1024 / sizeof(W_);+ RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS;++ // See #3408: the default idle GC time of 0.3s is too short on+ // Windows where we receive console events once per second or so.+#if __GLASGOW_HASKELL__ >= 703+ RtsFlags.GcFlags.idleGCDelayTime = SecondsToTime(5);+#else+ RtsFlags.GcFlags.idleGCDelayTime = 5*1000;+#endif+}++void+StackOverflowHook (StgWord stack_size) /* in bytes */+{+ fprintf(stderr, "GHC stack-space overflow: current limit is %zu bytes.\nUse the `-K<size>' option to increase it.\n", (size_t)stack_size);+}+
+ src-ghc/CLaSH/GHC/Compat/DynFlags.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+module CLaSH.GHC.Compat.DynFlags where++#if __GLASGOW_HASKELL__ >= 707+import DynFlags (DynFlags,GeneralFlag)+#else+import DynFlags (DynFlags,DynFlag)+#endif+import qualified DynFlags++dopt_unset ::+ DynFlags+#if __GLASGOW_HASKELL__ >= 707+ -> GeneralFlag+#else+ -> DynFlag+#endif+ -> DynFlags+#if __GLASGOW_HASKELL__ >= 707+dopt_unset = DynFlags.gopt_unset+#else+dopt_unset = DynFlags.dopt_unset+#endif++dopt_set ::+ DynFlags+#if __GLASGOW_HASKELL__ >= 707+ -> GeneralFlag+#else+ -> DynFlag+#endif+ -> DynFlags+#if __GLASGOW_HASKELL__ >= 707+dopt_set = DynFlags.gopt_set+#else+dopt_set = DynFlags.dopt_set+#endif
+ src-ghc/CLaSH/GHC/Compat/FastString.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE CPP #-}+module CLaSH.GHC.Compat.FastString+ ( unpackFS+ , unpackFB+ )+where++import qualified FastString++#if __GLASGOW_HASKELL__ >= 707+import Data.ByteString+import Data.ByteString.Char8 as Char8 (unpack)+#endif++#if __GLASGOW_HASKELL__ == 706+unpackFS :: FastString.FastBytes -> String+unpackFS = FastString.unpackFS+ . FastString.mkFastStringByteList+ . FastString.bytesFB+#endif++#if __GLASGOW_HASKELL__ >= 707+unpackFS :: FastString.FastString -> String+unpackFS = FastString.unpackFS++unpackFB :: ByteString -> String+unpackFB = Char8.unpack+#endif
+ src-ghc/CLaSH/GHC/Compat/GHC.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}+module CLaSH.GHC.Compat.GHC+ ( defaultErrorHandler+ )+where++import qualified DynFlags+import qualified Exception+import qualified GHC+import qualified MonadUtils++defaultErrorHandler ::+ (Exception.ExceptionMonad m, MonadUtils.MonadIO m)+ => m a+ -> m a+#if __GLASGOW_HASKELL__ >= 706+defaultErrorHandler = GHC.defaultErrorHandler DynFlags.defaultFatalMessager DynFlags.defaultFlushOut+#else+defaultErrorHandler = GHC.defaultErrorHandler DynFlags.defaultLogAction+#endif
+ src-ghc/CLaSH/GHC/Compat/Outputable.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}+module CLaSH.GHC.Compat.Outputable+ ( showPpr, showSDoc )+where++#if __GLASGOW_HASKELL__ >= 707+import qualified DynFlags (unsafeGlobalDynFlags)+#elif __GLASGOW_HASKELL__ >= 706+import qualified DynFlags (tracingDynFlags)+#endif+import qualified Outputable (Outputable, SDoc, showPpr, showSDoc)++showSDoc :: Outputable.SDoc -> String+#if __GLASGOW_HASKELL__ >= 707+showSDoc = Outputable.showSDoc DynFlags.unsafeGlobalDynFlags+#endif++showPpr :: (Outputable.Outputable a) => a -> String+#if __GLASGOW_HASKELL__ >= 707+showPpr = Outputable.showPpr DynFlags.unsafeGlobalDynFlags+#elif __GLASGOW_HASKELL__ >= 706+showPpr = Outputable.showPpr DynFlags.tracingDynFlags+#else+showPpr = Outputable.showPpr+#endif
+ src-ghc/CLaSH/GHC/Compat/PrelNames.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP #-}+module CLaSH.GHC.Compat.PrelNames+ ( tySuperKindTyConKey+ )+where++import qualified Unique+import qualified PrelNames++tySuperKindTyConKey :: Unique.Unique+#if __GLASGOW_HASKELL__ >= 706+tySuperKindTyConKey = PrelNames.superKindTyConKey+#else+tySuperKindTyConKey = PrelNames.tySuperKindTyConKey+#endif
+ src-ghc/CLaSH/GHC/Compat/TyCon.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE CPP #-}+module CLaSH.GHC.Compat.TyCon+ (isSuperKindTyCon+ )+where++import qualified TyCon+#if __GLASGOW_HASKELL__ >= 706+import qualified Kind+#endif++isSuperKindTyCon :: TyCon.TyCon -> Bool+#if __GLASGOW_HASKELL__ >= 706+isSuperKindTyCon = Kind.isSuperKindTyCon+#else+isSuperKindTyCon = TyCon.isSuperKindTyCon+#endif
+ src-ghc/CLaSH/GHC/GHC2Core.hs view
@@ -0,0 +1,456 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module CLaSH.GHC.GHC2Core+ ( GHC2CoreState+ , coreToTerm+ , coreToId+ , makeAllTyCons+ , emptyGHC2CoreState+ )+where++-- External Modules+import Control.Lens ((^.), (%~), (&), (%=))+import Control.Monad.State (State)+import qualified Control.Monad.State.Lazy as State+import Data.Hashable (Hashable (..))+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.HashMap.Strict as HSM+import Data.Maybe (fromMaybe)+import Data.Text (pack)+import qualified Data.Traversable as T+import Unbound.LocallyNameless (Rep, bind, embed, rebind, rec,+ runFreshM, string2Name, unbind,+ unembed)+import qualified Unbound.LocallyNameless as Unbound++-- GHC API+import CLaSH.GHC.Compat.FastString (unpackFB, unpackFS)+import CLaSH.GHC.Compat.Outputable (showPpr)+import CLaSH.GHC.Compat.TyCon (isSuperKindTyCon)+-- import Coercion (coercionKind, coercionType)+import Coercion (coercionType)+import CoreFVs (exprSomeFreeVars)+import CoreSyn (AltCon (..), Bind (..), CoreExpr,+ Expr (..), rhssOfAlts)+import DataCon (DataCon, dataConExTyVars,+ dataConName, dataConRepArgTys,+ dataConTag, dataConTyCon,+ dataConUnivTyVars, dataConWorkId,+ dataConWrapId_maybe)+import Id (isDataConId_maybe)+import IdInfo (IdDetails (..))+import Literal (Literal (..))+import Module (moduleName, moduleNameString)+import Name (Name, nameModule_maybe,+ nameOccName, nameUnique)+import OccName (occNameString)+-- import Pair (Pair (..))+import TyCon (AlgTyConRhs (..), PrimRep (..),+ SynTyConRhs (..), TyCon,+ algTyConRhs, isAlgTyCon,+ isFunTyCon, isNewTyCon,+ isPrimTyCon,+ isSynTyCon, isTupleTyCon,+ synTyConRhs_maybe, tyConArity,+ tyConDataCons, tyConKind,+ tyConName, tyConPrimRep,+ tyConUnique)+import Type (tcView)+import TypeRep (TyLit (..), Type (..))+import Unique (Uniquable (..), Unique, getKey)+import Var (Id, TyVar, Var, idDetails,+ isTyVar, varName, varType,+ varUnique)+import VarSet (isEmptyVarSet)++-- Local imports+import qualified CLaSH.Core.DataCon as C+import qualified CLaSH.Core.Literal as C+import qualified CLaSH.Core.Term as C+import qualified CLaSH.Core.TyCon as C+import qualified CLaSH.Core.Type as C+import qualified CLaSH.Core.Var as C+import CLaSH.Primitives.Types+import CLaSH.Util++instance Hashable Name where+ hashWithSalt s = hashWithSalt s . getKey . nameUnique++data GHC2CoreState+ = GHC2CoreState+ { _tyConMap :: HashMap C.TyConName TyCon+ , _nameMap :: HashMap Name String+ }++makeLenses ''GHC2CoreState++emptyGHC2CoreState :: GHC2CoreState+emptyGHC2CoreState = GHC2CoreState HSM.empty HSM.empty++makeAllTyCons :: GHC2CoreState+ -> HashMap C.TyConName C.TyCon+makeAllTyCons hm = go hm hm+ where+ go old new+ | HSM.null (new ^. tyConMap) = HSM.empty+ | otherwise = tcm `HSM.union` tcm'+ where+ (tcm,old') = State.runState (T.mapM makeTyCon (new ^. tyConMap)) old+ tcm' = go old' (old' & tyConMap %~ (`HSM.difference` (old ^. tyConMap)))++makeTyCon :: TyCon+ -> State GHC2CoreState C.TyCon+makeTyCon tc = tycon+ where+ tycon+ | isTupleTyCon tc = mkTupleTyCon+ | isAlgTyCon tc = mkAlgTyCon+ | isSynTyCon tc = mkVoidTyCon+ | isPrimTyCon tc = mkPrimTyCon+ | isSuperKindTyCon tc = mkSuperKindTyCon+ | otherwise = mkVoidTyCon+ where+ tcArity = tyConArity tc++ mkAlgTyCon = do+ tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+ tcKind <- coreToType (tyConKind tc)+ tcRhsM <- makeAlgTyConRhs $ algTyConRhs tc+ case tcRhsM of+ Just tcRhs ->+ return+ C.AlgTyCon+ { C.tyConName = tcName+ , C.tyConKind = tcKind+ , C.tyConArity = tcArity+ , C.algTcRhs = tcRhs+ }+ Nothing -> return (C.PrimTyCon tcName tcKind tcArity C.VoidRep)++ mkTupleTyCon = do+ tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+ tcKind <- coreToType (tyConKind tc)+ tcDc <- fmap (C.DataTyCon . (:[])) . coreToDataCon False . head . tyConDataCons $ tc+ return+ C.AlgTyCon+ { C.tyConName = tcName+ , C.tyConKind = tcKind+ , C.tyConArity = tcArity+ , C.algTcRhs = tcDc+ }++ mkPrimTyCon = do+ tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+ tcKind <- coreToType (tyConKind tc)+ return+ C.PrimTyCon+ { C.tyConName = tcName+ , C.tyConKind = tcKind+ , C.tyConArity = tcArity+ , C.primTyConRep = coreToPrimRep (tyConPrimRep tc)+ }++ mkSuperKindTyCon = do+ tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+ return C.SuperKindTyCon+ { C.tyConName = tcName+ }++ mkVoidTyCon = do+ tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+ tcKind <- coreToType (tyConKind tc)+ return (C.PrimTyCon tcName tcKind tcArity C.VoidRep)++ coreToPrimRep :: PrimRep+ -> C.PrimRep+ coreToPrimRep p = case p of+ VoidRep -> C.VoidRep+ IntRep -> C.IntRep+ AddrRep -> C.VoidRep+ PtrRep -> C.VoidRep+ WordRep -> C.VoidRep+ DoubleRep -> C.VoidRep+ _ -> error $ $(curLoc) ++ "Can't convert PrimRep: " ++ showPpr p ++ " in tycon: " ++ showPpr tc++makeAlgTyConRhs :: AlgTyConRhs+ -> State GHC2CoreState (Maybe C.AlgTyConRhs)+makeAlgTyConRhs algTcRhs = case algTcRhs of+ DataTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM (coreToDataCon False) dcs+ NewTyCon dc _ (rhsTvs,rhsEtad) _ -> Just <$> (C.NewTyCon <$> coreToDataCon False dc+ <*> ((,) <$> mapM coreToVar rhsTvs+ <*> coreToType rhsEtad+ )+ )+ AbstractTyCon _ -> return Nothing+ DataFamilyTyCon -> return Nothing++coreToTerm :: PrimMap+ -> [Var]+ -> CoreExpr+ -> State GHC2CoreState C.Term+coreToTerm primMap unlocs coreExpr = term coreExpr+ where+ term (Var x) = var x+ term (Lit l) = return $ C.Literal (coreToLiteral l)+ term (App eFun (Type tyArg)) = C.TyApp <$> term eFun <*> coreToType tyArg+ term (App eFun eArg) = C.App <$> term eFun <*> term eArg+ term (Lam x e) | isTyVar x = C.TyLam <$> (bind <$> coreToTyVar x <*> term e)+ | otherwise = C.Lam <$> (bind <$> coreToId x <*> term e)+ term (Let (NonRec x e1) e2) = do+ x' <- coreToId x+ e1' <- term e1+ e2' <- term e2+ return $ C.Letrec $ bind (rec [(x', embed e1')]) e2'++ term (Let (Rec xes) e) = do+ xes' <- mapM+ ( firstM coreToId <=<+ secondM ((return . embed) <=< term)+ ) xes+ e' <- term e+ return $ C.Letrec $ bind (rec xes') e'++ term (Case _ _ ty []) = C.Prim (pack "EmptyCase") <$> coreToType ty+ term (Case e b _ alts) = do+ let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (`elem` [b]))+ $ rhssOfAlts alts+ b' <- coreToId b+ e' <- term e+ let caseTerm v = C.Case v <$> mapM alt alts+ if usesBndr+ then do+ ct <- caseTerm (C.Var (unembed $ C.varType b') (C.varName b'))+ return $ C.Letrec $ bind (rec [(b',embed e')]) ct+ else caseTerm e'++ -- term j@(Cast e co) = traceIf True ("CAST: " ++ showPpr j) $ case coercionKind co of+ -- Pair ty1 ty2 -> do+ -- ty1C <- coreToType ty1+ -- ty2C <- coreToType ty2+ -- eC <- term e+ -- let caTy = C.mkFunTy ty1C ty2C+ -- ca = C.Prim (string2Name "_CAST_") caTy+ -- return (C.App ca eC)+ term (Cast e _) = term e+ term (Tick _ e) = term e+ term (Type t) = C.Prim (pack "_TY_") <$> coreToType t+ term (Coercion co) = C.Prim (pack "_CO_") <$> coreToType (coercionType co)++ var x = do+ xVar <- coreToVar x+ xPrim <- coreToPrimVar x+ let xNameS = pack $ Unbound.name2String xPrim+ xType <- coreToType (varType x)+ case isDataConId_maybe x of+ Just dc -> case HashMap.lookup xNameS primMap of+ Just _ -> return $ C.Prim xNameS xType+ 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)+ Just (BlackBox {}) ->+ return (C.Prim xNameS xType)+ Nothing+ | x `elem` unlocs -> return (C.Prim xNameS xType)+ | otherwise -> return (C.Var xType xVar)++ alt (DEFAULT , _ , e) = bind C.DefaultPat <$> term e+ alt (LitAlt l , _ , e) = bind (C.LitPat . embed $ coreToLiteral l) <$> term e+ alt (DataAlt dc, xs, e) = case span isTyVar xs of+ (tyvs,tmvs) -> bind <$> (C.DataPat . embed <$>+ coreToDataCon False dc <*>+ (rebind <$>+ mapM coreToTyVar tyvs <*>+ mapM coreToId tmvs)) <*>+ term e++ coreToLiteral :: Literal+ -> C.Literal+ coreToLiteral l = case l of+ MachStr fs -> C.StringLiteral (unpackFB fs)+ MachChar c -> C.StringLiteral [c]+ MachInt i -> C.IntegerLiteral i+ MachInt64 i -> C.IntegerLiteral i+ MachWord i -> C.IntegerLiteral i+ MachWord64 i -> C.IntegerLiteral i+ LitInteger i _ -> C.IntegerLiteral i+ MachFloat r -> C.RationalLiteral r+ MachDouble r -> C.RationalLiteral r+ MachNullAddr -> C.StringLiteral []+ _ -> error $ $(curLoc) ++ "Can't convert literal: " ++ showPpr l ++ " in expression: " ++ showPpr coreExpr++coreToDataCon :: Bool+ -> DataCon+ -> State GHC2CoreState C.DataCon+coreToDataCon mkWrap dc = do+ repTys <- mapM coreToType (dataConRepArgTys dc)+ dcTy <- if mkWrap+ then case dataConWrapId_maybe dc of+ Just wrapId -> coreToType (varType wrapId)+ Nothing -> error $ $(curLoc) ++ "DataCon Wrapper: " ++ showPpr dc ++ " not found"+ else coreToType (varType $ dataConWorkId dc)+ mkDc dcTy repTys+ where+ mkDc dcTy repTys = do+ nm <- coreToName dataConName getUnique nameString dc+ uTvs <- mapM coreToVar (dataConUnivTyVars dc)+ eTvs <- mapM coreToVar (dataConExTyVars dc)+ return $ C.MkData+ { C.dcName = nm+ , C.dcTag = dataConTag dc+ , C.dcType = dcTy+ , C.dcArgTys = repTys+ , C.dcUnivTyVars = uTvs+ , C.dcExtTyVars = eTvs+ }++coreToType :: Type+ -> State GHC2CoreState C.Type+coreToType ty = coreToType' $ fromMaybe ty (tcView ty)++coreToType' :: Type+ -> State GHC2CoreState C.Type+coreToType' (TyVarTy tv) = C.VarTy <$> coreToType (varType tv) <*> (coreToVar tv)+coreToType' (TyConApp (synTyConRhs_maybe -> Just (SynonymTyCon ty)) args) =+ foldl C.AppTy <$> coreToType ty <*> mapM coreToType args+coreToType' (TyConApp tc args)+ | isFunTyCon tc = foldl C.AppTy (C.ConstTy C.Arrow) <$> mapM coreToType args+ | otherwise = do tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+ tyConMap %= (HSM.insert tcName tc)+ C.mkTyConApp <$> (pure tcName) <*> mapM coreToType args+coreToType' (FunTy ty1 ty2) = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2+coreToType' (ForAllTy tv ty) = C.ForAllTy <$>+ (bind <$> coreToTyVar tv <*> coreToType ty)+coreToType' (LitTy tyLit) = return $ C.LitTy (coreToTyLit tyLit)+coreToType' (AppTy ty1 ty2) = C.AppTy <$> coreToType ty1 <*> coreToType' ty2++coreToTyLit :: TyLit+ -> C.LitTy+coreToTyLit (NumTyLit i) = C.NumTy (fromInteger i)+coreToTyLit (StrTyLit s) = C.SymTy (unpackFS s)++coreToTyVar :: TyVar+ -> State GHC2CoreState C.TyVar+coreToTyVar tv =+ C.TyVar <$> (coreToVar tv) <*> (embed <$> coreToType (varType tv))++coreToId :: Id+ -> State GHC2CoreState C.Id+coreToId i =+ C.Id <$> (coreToVar i) <*> (embed <$> coreToType (varType i))++coreToVar :: Rep a+ => Var+ -> State GHC2CoreState (Unbound.Name a)+coreToVar = coreToName varName varUnique qualfiedNameStringM++coreToPrimVar :: Var+ -> State GHC2CoreState (Unbound.Name C.Term)+coreToPrimVar = coreToName varName varUnique qualfiedNameString++coreToName :: Rep a+ => (b -> Name)+ -> (b -> Unique)+ -> (Name -> State GHC2CoreState String)+ -> b+ -> State GHC2CoreState (Unbound.Name a)+coreToName toName toUnique toString v = do+ ns <- toString (toName v)+ return (Unbound.makeName ns (toInteger . getKey . toUnique $ v))++nameString :: Name+ -> State GHC2CoreState String+nameString n = makeCached n nameMap (return (occNameString $ nameOccName n))++qualfiedNameString :: Name+ -> State GHC2CoreState String+qualfiedNameString n = makeCached n nameMap+ $ return (fromMaybe "_INTERNAL_" (modNameM n) ++ ('.':occName))+ where+ occName = occNameString $ nameOccName n++qualfiedNameStringM :: Name+ -> State GHC2CoreState String+qualfiedNameStringM n = makeCached n nameMap+ $ return (maybe occName (\modName -> modName ++ ('.':occName)) (modNameM n))+ where+ occName = occNameString $ nameOccName n++modNameM :: Name+ -> Maybe String+modNameM n = do+ module_ <- nameModule_maybe n+ let moduleNm = moduleName module_+ return (moduleNameString moduleNm)++mapSyncTerm :: C.Type+ -> C.Term+mapSyncTerm (C.ForAllTy tvATy) =+ let (aTV,bTV,C.tyView -> C.FunTy _ (C.tyView -> C.FunTy aTy bTy)) = runFreshM $ do+ { (aTV',C.ForAllTy tvBTy) <- unbind tvATy+ ; (bTV',funTy) <- unbind tvBTy+ ; return (aTV',bTV',funTy) }+ fName = string2Name "f"+ xName = string2Name "x"+ fTy = C.mkFunTy aTy bTy+ fId = C.Id fName (embed fTy)+ xId = C.Id xName (embed aTy)+ in C.TyLam $ bind aTV $+ C.TyLam $ bind bTV $+ C.Lam $ bind fId $+ C.Lam $ bind xId $+ C.App (C.Var fTy fName) (C.Var aTy xName)++mapSyncTerm ty = error $ $(curLoc) ++ show ty++syncTerm :: C.Type+ -> C.Term+syncTerm (C.ForAllTy tvTy) =+ let (aTV,C.tyView -> C.FunTy _ aTy) = runFreshM $ unbind tvTy+ xName = string2Name "x"+ xId = C.Id xName (embed aTy)+ in C.TyLam $ bind aTV $+ C.Lam $ bind xId $+ C.Var aTy xName++syncTerm ty = error $ $(curLoc) ++ show ty++splitCombineTerm :: Bool+ -> C.Type+ -> C.Term+splitCombineTerm b (C.ForAllTy tvTy) =+ let (aTV,C.tyView -> C.FunTy dictTy (C.tyView -> C.FunTy inpTy outpTy)) = runFreshM $ unbind tvTy+ dictName = string2Name "splitCombineDict"+ xName = string2Name "x"+ nTy = if b then inpTy else outpTy+ dId = C.Id dictName (embed dictTy)+ xId = C.Id xName (embed nTy)+ newExpr = C.TyLam $ bind aTV $+ C.Lam $ bind dId $+ C.Lam $ bind xId $+ C.Var nTy xName+ in newExpr++splitCombineTerm _ ty = error $ $(curLoc) ++ show ty++dollarAppTerm :: C.Type+ -> C.Term+dollarAppTerm = mapSyncTerm++isDataConWrapId :: Id -> Bool+isDataConWrapId v = case idDetails v of+ DataConWrapId {} -> True+ _ -> False
+ src-ghc/CLaSH/GHC/GenerateBindings.hs view
@@ -0,0 +1,76 @@+module CLaSH.GHC.GenerateBindings+ (generateBindings)+where++import Control.Monad.State (State)+import qualified Control.Monad.State as State+import Data.Either (lefts, rights)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Unbound.LocallyNameless (runFreshM, unembed)++import qualified CoreSyn as GHC++import CLaSH.Core.Term (Term, TmName)+import CLaSH.Core.Type (Type, splitFunForallTy)+import CLaSH.Core.TyCon (TyCon, TyConName)+import CLaSH.Core.TysPrim (tysPrimMap)+import CLaSH.Core.Util (mkLams, mkTyLams)+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.Primitives.Types (PrimMap)+import CLaSH.Rewrite.Util (mkInternalVar, mkSelectorCase)+import CLaSH.Util ((***),first)++generateBindings ::+ PrimMap+ -> String+ -> IO (BindingMap,HashMap TyConName TyCon)+generateBindings primMap modName = do+ (bindings,clsOps,unlocatable) <- loadModules modName+ let ((bindingsMap,clsVMap),tcMap) = State.runState (mkBindings primMap bindings clsOps unlocatable) emptyGHC2CoreState+ tcCache = makeAllTyCons tcMap+ allTcCache = tysPrimMap `HashMap.union` tcCache+ clsMap = HashMap.map (\(ty,i) -> (ty,mkClassSelector allTcCache ty i)) clsVMap+ allBindings = bindingsMap `HashMap.union` clsMap+ return (allBindings,allTcCache)++mkBindings :: PrimMap+ -> [(GHC.CoreBndr, GHC.CoreExpr)] -- Binders+ -> [(GHC.CoreBndr,Int)] -- Class operations+ -> [GHC.CoreBndr] -- Unlocatable Expressions+ -> State GHC2CoreState+ ( BindingMap+ , HashMap TmName (Type,Int)+ )+mkBindings primMap bindings clsOps unlocatable = do+ bindingsList <- mapM (\(v,e) -> do+ tm <- coreToTerm primMap unlocatable e+ v' <- coreToId v+ return (varName v', (unembed (varType v'), tm))+ ) bindings+ clsOpList <- mapM (\(v,i) -> do+ v' <- coreToId v+ let ty = unembed $ varType v'+ return (varName v', (ty,i))+ ) clsOps++ return (HashMap.fromList bindingsList, HashMap.fromList clsOpList)++mkClassSelector :: HashMap TyConName TyCon+ -> Type+ -> Int+ -> Term+mkClassSelector tcm ty sel = newExpr+ where+ ((tvs,dictTy:_),_) = first (lefts *** rights)+ $ 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)
+ src-ghc/CLaSH/GHC/LoadInterfaceFiles.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+module CLaSH.GHC.LoadInterfaceFiles+ (loadExternalExprs)+where++-- External Modules+import Data.Either (partitionEithers)+import Data.List (elemIndex, partition)+import Data.Maybe (isJust, isNothing)++-- GHC API+import qualified BasicTypes+import CLaSH.GHC.Compat.Outputable (showPpr, showSDoc)+import qualified Class+import qualified CoreFVs+import qualified CoreSyn+import qualified GHC+import qualified Id+import qualified IdInfo+import qualified IfaceSyn+import qualified LoadIface+import qualified Maybes+import qualified MkCore+import qualified MonadUtils+import qualified Name+import Outputable (text)+import qualified TcIface+import qualified TcRnMonad+import qualified TcRnTypes+import qualified UniqFM+import qualified Var+import qualified VarSet++-- Internal Modules+import CLaSH.Util (curLoc, traceIf)++runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a+runIfl modName action = do+ hscEnv <- GHC.getSession+ let localEnv = TcRnTypes.IfLclEnv modName (text "runIfl")+ UniqFM.emptyUFM UniqFM.emptyUFM+ let globalEnv = TcRnTypes.IfGblEnv Nothing+ MonadUtils.liftIO $ TcRnMonad.initTcRnIf 'r' hscEnv globalEnv+ localEnv action++loadDecl :: IfaceSyn.IfaceDecl -> TcRnTypes.IfL GHC.TyThing+loadDecl = TcIface.tcIfaceDecl False++loadIface :: GHC.Module -> TcRnTypes.IfL (Maybe GHC.ModIface)+loadIface foundMod = do+ ifaceFailM <- LoadIface.findAndReadIface (Outputable.text "loadIface") foundMod False+ case ifaceFailM of+ Maybes.Succeeded (modInfo,_) -> return (Just modInfo)+ Maybes.Failed msg -> traceIf True ($(curLoc) ++ "Failed to load interface for module: " ++ showPpr foundMod ++ "\nReason: " ++ showSDoc msg) $ return Nothing++loadExternalExprs ::+ GHC.GhcMonad m+ => [CoreSyn.CoreExpr]+ -> [CoreSyn.CoreBndr]+ -> m ( [(CoreSyn.CoreBndr,CoreSyn.CoreExpr)] -- Binders+ , [(CoreSyn.CoreBndr,Int)] -- Class Ops+ , [CoreSyn.CoreBndr] -- Unlocatable+ )+loadExternalExprs [] _ = return ([],[],[])+loadExternalExprs (expr:exprs) visited = do+ let fvs = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars+ (\v -> Var.isId v &&+ isNothing (Id.isDataConId_maybe v) &&+ v `notElem` visited+ ) expr++ let (clsOps,fvs') = partition (isJust . Id.isClassOpId_maybe) fvs++ (locatedExprs,unlocated) <- fmap partitionEithers+ $ mapM loadExprFromIface fvs'++ let visited' = concat [ map fst locatedExprs+ , unlocated+ , clsOps+ , visited+ ]++ (locatedExprs', clsOps', unlocated') <-+ loadExternalExprs+ (exprs ++ map snd locatedExprs)+ visited'++ let clsOps'' = map+ ( \v -> flip (maybe (error $ $(curLoc) ++ "Not a class op")) (Id.isClassOpId_maybe v) $ \c ->+ let clsIds = Class.classAllSelIds c+ in maybe (error $ $(curLoc) ++ "Index not found")+ (v,)+ (elemIndex v clsIds)+ ) clsOps++ return ( locatedExprs ++ locatedExprs'+ , clsOps'' ++ clsOps'+ , unlocated ++ unlocated'+ )++loadExprFromIface ::+ GHC.GhcMonad m+ => CoreSyn.CoreBndr+ -> m (Either+ (CoreSyn.CoreBndr,CoreSyn.CoreExpr)+ CoreSyn.CoreBndr+ )+loadExprFromIface bndr = do+ let moduleM = Name.nameModule_maybe $ Var.varName bndr+ case moduleM of+ Just nameMod -> runIfl nameMod $ do+ ifaceM <- loadIface nameMod+ case ifaceM of+ Nothing -> return (Right bndr)+ Just iface -> do+ let decls = map snd (GHC.mi_decls iface)+ let nameFun = GHC.getOccName $ Var.varName bndr+ let declM = filter ((== nameFun) . IfaceSyn.ifName) decls+ case declM of+ [namedDecl] -> do+ tyThing <- loadDecl namedDecl+ return $ loadExprFromTyThing bndr tyThing+ _ -> return (Right bndr)+ Nothing -> return (Right bndr)++loadExprFromTyThing :: CoreSyn.CoreBndr+ -> GHC.TyThing+ -> Either+ (CoreSyn.CoreBndr,CoreSyn.CoreExpr) -- Located Binder+ CoreSyn.CoreBndr -- unlocatable Var+loadExprFromTyThing bndr tyThing = case tyThing of+ GHC.AnId _id | Var.isId _id ->+ let unfolding = IdInfo.unfoldingInfo $ Var.idInfo _id+ inlineInfo = IdInfo.inlinePragInfo $ Var.idInfo _id+ in case unfolding of+ (CoreSyn.CoreUnfolding {}) ->+ case (BasicTypes.inl_inline inlineInfo,BasicTypes.inl_act inlineInfo) of+ (BasicTypes.NoInline,BasicTypes.AlwaysActive) -> Right bndr+ (BasicTypes.NoInline,BasicTypes.NeverActive) -> Right bndr+ (BasicTypes.NoInline,_) -> Left (bndr, CoreSyn.unfoldingTemplate unfolding)+ _ -> Left (bndr, CoreSyn.unfoldingTemplate unfolding)+ (CoreSyn.DFunUnfolding dfbndrs dc es) ->+ let dcApp = MkCore.mkCoreConApps dc es+ dfExpr = MkCore.mkCoreLams dfbndrs dcApp+ in Left (bndr,dfExpr)+ _ -> Right bndr+ _ -> Right bndr
+ src-ghc/CLaSH/GHC/LoadModules.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module CLaSH.GHC.LoadModules+ ( loadModules+ )+where++-- External Modules+#ifdef STANDALONE+import System.Exit (ExitCode (..))+import System.IO (hGetLine)+import System.Process (runInteractiveCommand,+ waitForProcess)+#else+import qualified GHC.Paths+#endif++-- GHC API+-- import qualified CorePrep+import CLaSH.GHC.Compat.DynFlags (dopt_set, dopt_unset)+import CLaSH.GHC.Compat.GHC (defaultErrorHandler)+import qualified CoreSyn+import DynFlags (GeneralFlag (..))+import qualified DynFlags+import qualified GHC+-- import qualified HscMain+import qualified HscTypes+import qualified MonadUtils+import qualified Panic+import qualified TidyPgm+-- import qualified TyCons++-- Internal Modules+import CLaSH.GHC.LoadInterfaceFiles+import CLaSH.Util (curLoc)++#ifdef STANDALONE+ghcLibDir :: IO FilePath+ghcLibDir = do (libDir,exitCode) <- getProcessOutput "ghc --print-libdir"+ case exitCode of+ ExitSuccess -> return libDir+ ExitFailure i -> error $ "Calling GHC failed with: " ++ show i++getProcessOutput :: String -> IO (String, ExitCode)+getProcessOutput command =+ -- Create the process+ do (_, pOut, _, handle) <- runInteractiveCommand command+ -- Wait for the process to finish and store its exit code+ exitCode <- waitForProcess handle+ -- Get the standard output.+ output <- hGetLine pOut+ -- return both the output and the exit code.+ return (output, exitCode)+#else+ghcLibDir :: IO FilePath+ghcLibDir = return GHC.Paths.libdir+#endif++loadModules ::+ String+ -> IO ( [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- Binders+ , [(CoreSyn.CoreBndr,Int)] -- Class operations+ , [CoreSyn.CoreBndr] -- Unlocatable Expressions+ )+loadModules modName = defaultErrorHandler $ do+ libDir <- MonadUtils.liftIO ghcLibDir++ GHC.runGhc (Just libDir) $ do+ dflags <- GHC.getSessionDynFlags+ let ghcDynamic = case lookup "GHC Dynamic" (DynFlags.compilerInfo dflags) of+ Just "YES" -> True+ _ -> False+ let dflags1 = foldl DynFlags.xopt_set+ (dflags+ { DynFlags.ctxtStkDepth = 1000+ , DynFlags.optLevel = 2+ , DynFlags.ghcMode = GHC.CompManager+ } )+ [DynFlags.Opt_TemplateHaskell,DynFlags.Opt_Arrows,DynFlags.Opt_DataKinds]+ let dflags2 = wantedOptimizationFlags dflags1+ let dflags3 = if ghcDynamic then DynFlags.gopt_set dflags2 DynFlags.Opt_BuildDynamicToo+ else dflags2+ _ <- GHC.setSessionDynFlags dflags3+ target <- GHC.guessTarget modName Nothing+ GHC.setTargets [target]+ ldRes <- GHC.load GHC.LoadAllTargets+ case ldRes of+ GHC.Succeeded -> do+ modGraph <- GHC.getModuleGraph+ let modGraph' = map disableOptimizationsFlags modGraph+ tidiedMods <- mapM (\m -> do { pMod <- parseModule m+ ; tcMod <- GHC.typecheckModule pMod+ ; dsMod <- fmap GHC.coreModule $ GHC.desugarModule tcMod+ ; hsc_env <- GHC.getSession+ -- ; simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env dsMod+ ; (tidy_guts,_) <- MonadUtils.liftIO $ TidyPgm.tidyProgram hsc_env dsMod+ -- ; let tycons = HscTypes.cg_tycons tidy_guts+ ; let pgm = HscTypes.cg_binds tidy_guts+ -- ; let pgm = HscTypes.mg_binds dsMod+ -- ; let dataTyCons = filter TyCon.isDataTyCon tycons+ -- ; dflags'' <- GHC.getSessionDynFlags+ -- ; prepBinders <- MonadUtils.liftIO $ CorePrep.corePrepPgm dflags'' hsc_env pgm dataTyCons+ ; return (CoreSyn.flattenBinds pgm)+ }+ ) modGraph'++ let binders = concat tidiedMods++ (externalBndrs,clsOps,unlocatable) <- loadExternalExprs+ (map snd binders)+ (map fst binders)++ return (binders ++ externalBndrs,clsOps,unlocatable)+ GHC.Failed -> Panic.pgmError $ $(curLoc) ++ "failed to load module: " ++ modName++parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule+parseModule modSum = do+ (GHC.ParsedModule pmModSum pmParsedSource extraSrc) <-+ GHC.parseModule modSum+ return (GHC.ParsedModule+ (disableOptimizationsFlags pmModSum)+ pmParsedSource extraSrc)++disableOptimizationsFlags :: GHC.ModSummary -> GHC.ModSummary+disableOptimizationsFlags ms@(GHC.ModSummary {..})+ = ms {GHC.ms_hspp_opts = dflags}+ where+ dflags = wantedOptimizationFlags (ms_hspp_opts+ {DynFlags.optLevel = 2, DynFlags.ctxtStkDepth = 1000})++wantedOptimizationFlags :: GHC.DynFlags -> GHC.DynFlags+wantedOptimizationFlags df = foldl dopt_unset (foldl dopt_set df wanted) unwanted+ where+ wanted = [ Opt_Strictness -- [Wanted?] don't care about strictness+ , Opt_CSE -- CSE+ , Opt_FullLaziness -- Floats let-bindings outside enclosing lambdas+ , Opt_Specialise -- Specialise on types, specialise type-class-overloaded function defined in this module for the types+ , Opt_DoLambdaEtaExpansion -- We need eta-expansion anyway, so the more GHC does, the better+ , Opt_CaseMerge -- We want fewer case-statements+ , Opt_DictsCheap -- Makes dictionaries seem cheap to optimizer: hopefully inline+ , Opt_SimpleListLiterals -- Avoids 'build' rule+ , Opt_ExposeAllUnfoldings -- We need all the unfoldings we can get+ , Opt_ForceRecomp -- Force recompilation: never bad+ ]++ unwanted = [ Opt_FloatIn -- Moves let-bindings inwards: defeats the normal-form with a single top-level let-binding+ , Opt_StaticArgumentTransformation -- [Wanted?] Turn on the static argument transformation, which turns a recursive function into a non-recursive one with a local recursive loop.+ , Opt_LiberateCase -- Perform unrolling of recursive RHS: avoid+ , Opt_SpecConstr -- Creates local-functions: avoid+ , Opt_IgnoreAsserts -- We don't care about assertions+ , Opt_DoEtaReduction -- We want eta-expansion+ , Opt_UnboxStrictFields -- Unboxed types are not handled properly: avoid+ , Opt_UnboxSmallStrictFields -- Unboxed types are not handled properly: avoid+ , Opt_EnableRewriteRules -- Intermediate data-structures take up no space+ , Opt_Vectorise -- Don't care+ , Opt_VectorisationAvoidance -- Don't care+ , Opt_RegsGraph -- Don't care+ , Opt_RegsGraph -- Don't care+ , Opt_PedanticBottoms -- Stops eta-expansion through case: avoid+ , Opt_LlvmTBAA -- Don't care+ , Opt_CmmSink -- Don't care+ , Opt_CmmElimCommonBlocks -- Don't care+ , Opt_OmitYields -- Don't care+ , Opt_IgnoreInterfacePragmas -- We need all the unfoldings we can get+ , Opt_OmitInterfacePragmas -- We need all the unfoldings we can get+ , Opt_SimplPreInlining -- Does inlining, which destroys function hierarchy: avoid+ , Opt_IrrefutableTuples -- Introduce irrefuntPatError: avoid+ ]
+ src-ghc/CLaSH/GHC/NetlistTypes.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+module CLaSH.GHC.NetlistTypes+ (ghcTypeToHWType)+where++import Data.HashMap.Strict (HashMap)+import Control.Monad.Trans.Error (ErrorT(..))+import Unbound.LocallyNameless (name2String)++import CLaSH.Core.Pretty (showDoc)+import CLaSH.Core.TyCon (TyCon, TyConName)+import CLaSH.Core.Type (LitTy (..), Type (..), TypeView (..), tyView)+import CLaSH.Netlist.Util (coreTypeToHWType)+import CLaSH.Netlist.Types (HWType(..))+import CLaSH.Util++ghcTypeToHWType :: HashMap TyConName TyCon+ -> Type+ -> Maybe (Either String HWType)+ghcTypeToHWType m ty@(tyView -> TyConApp tc args) = runErrorT $+ case name2String tc of+ "Int" -> return Integer+ "GHC.Integer.Type.Integer" -> return Integer+ "GHC.Prim.Int#" -> return Integer+ "GHC.Types.Int" -> return Integer+ "GHC.Prim.ByteArray#" -> fail $ "Can't translate type: " ++ showDoc ty+ "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.Sized.Signed.Signed" -> Signed <$> tyNatSize (head args)+ "CLaSH.Sized.Unsigned.Unsigned" -> Unsigned <$> tyNatSize (head args)+ "CLaSH.Sized.Vector.Vec" -> do+ let [szTy,elTy] = args+ sz <- tyNatSize szTy+ elHWTy <- ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m elTy+ return $ Vector sz elHWTy+ _ -> ErrorT Nothing++ghcTypeToHWType _ _ = Nothing++tyNatSize ::+ Type+ -> ErrorT String Maybe Int+tyNatSize (LitTy (NumTy i)) = return i+tyNatSize (tyView -> TyConApp tc [ty1,ty2]) = case name2String tc of+ "GHC.TypeLits.+" -> (+) <$> tyNatSize ty1 <*> tyNatSize ty2+ "GHC.TypeLits.*" -> (*) <$> tyNatSize ty1 <*> tyNatSize ty2+ "GHC.TypeLits.^" -> (^) <$> tyNatSize ty1 <*> tyNatSize ty2+ "GHC.TypeLits.-" -> (-) <$> tyNatSize ty1 <*> tyNatSize ty2+ "CLaSH.Promoted.Ord.Max" -> max <$> tyNatSize ty1 <*> tyNatSize ty2+ "CLaSH.Promoted.Ord.Min" -> min <$> tyNatSize ty1 <*> tyNatSize ty2+ _ -> fail $ $(curLoc) ++ "Can't convert tyNatOp: " ++ show tc+-- TODO: Remove this conversion+-- The current problem is that type-functions are not reduced by the GHC -> Core+-- transformation process, and so end up here. Once a fix has been found for+-- this problem remove this dirty hack.+tyNatSize (tyView -> TyConApp _ [ty1]) = tyNatSize ty1+tyNatSize t = fail $ $(curLoc) ++ "Can't convert tyNat: " ++ show t