Make dataToQa aware of Data instances which use functions to implement toConstr
[ghc.git] / testsuite / tests / codeGen / should_compile / jmp_tbl.hs
1 {-# LANGUAGE NamedFieldPuns #-}
2
3 {-
4 This funny module was reduced from a failing build of stage2 using
5 the new code generator and the linear register allocator, with this bug:
6
7 "inplace/bin/ghc-stage1" -fPIC -dynamic -H32m -O -Wall -H64m -O0 -package-name ghc-7.1.20110414 -hide-all-packages -i -icompiler/basicTypes -icompiler/cmm -icompiler/codeGen -icompiler/coreSyn -icompiler/deSugar -icompiler/ghci -icompiler/hsSyn -icompiler/iface -icompiler/llvmGen -icompiler/main -icompiler/nativeGen -icompiler/parser -icompiler/prelude -icompiler/profiling -icompiler/rename -icompiler/simplCore -icompiler/simplStg -icompiler/specialise -icompiler/stgSyn -icompiler/stranal -icompiler/typecheck -icompiler/types -icompiler/utils -icompiler/vectorise -icompiler/stage2/build -icompiler/stage2/build/autogen -Icompiler/stage2/build -Icompiler/stage2/build/autogen -Icompiler/../libffi/build/include -Icompiler/stage2 -Icompiler/../libraries/base/cbits -Icompiler/../libraries/base/include -Icompiler/. -Icompiler/parser -Icompiler/utils -optP-DGHCI -optP-include -optPcompiler/stage2/build/autogen/cabal_macros.h -package Cabal-1.11.0 -package array-0.3.0.2 -package base-4.3.1.0 -package ghc-boot-0.0.0.0 -package bytestring-0.9.1.10 -package containers-0.4.0.0 -package directory-1.1.0.0 -package filepath-1.2.0.0 -package hoopl-3.8.7.0 -package hpc-0.5.0.6 -package old-time-1.0.0.6 -package process-1.0.1.4 -package template-haskell-2.5.0.0 -package unix-2.4.1.0 -Wall -fno-warn-name-shadowing -fno-warn-orphans -XHaskell98 -XNondecreasingIndentation -XCPP -XMagicHash -XUnboxedTuples -XPatternGuards -XForeignFunctionInterface -XEmptyDataDecls -XTypeSynonymInstances -XMultiParamTypeClasses -XFlexibleInstances -XRank2Types -XScopedTypeVariables -XDeriveDataTypeable -DGHCI_TABLES_NEXT_TO_CODE -DSTAGE=2 -O2 -O -DGHC_DEFAULT_NEW_CODEGEN -no-user-package-db -rtsopts -odir compiler/stage2/build -hidir compiler/stage2/build -stubdir compiler/stage2/build -hisuf dyn_hi -osuf dyn_o -hcsuf dyn_hc -c compiler/main/DriverPipeline.hs -o compiler/stage2/build/DriverPipeline.dyn_o -fforce-recomp -dno-debug-output -fno-warn-unused-binds
8
9 ghc-stage1: panic! (the 'impossible' happened)
10 (GHC version 7.1.20110414 for x86_64-unknown-linux):
11 Cannot patch JMP_TBL
12
13 This panic only appears to show up on x86-64 and with -fPIC. I wasn't
14 able to get the produced optimized C-- to crash the linear register
15 allocator. To see the bug, you need some extra patches for the new code
16 generator, in particular, this set (which can be acquired from the
17 jmp_tbl_bug tag at <https://github.com/ezyang/ghc>):
18
19 commit 7b275c93df7944f0a9b51034cf1f64e3e70582a5
20 Author: Edward Z. Yang <ezyang@mit.edu>
21 Date: Thu Apr 14 21:20:21 2011 +0100
22
23 Give manifestSP better information about the actual SP location.
24
25 This patch fixes silliness where the SP pointer is continually
26 bumped up and down.
27
28 Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
29
30 commit 5b5add4246d3997670ae995f7d2a028db92fff95
31 Author: Edward Z. Yang <ezyang@mit.edu>
32 Date: Wed Apr 13 11:16:36 2011 +0100
33
34 Generalized assignment rewriting pass.
35
36 This assignment rewriting pass subsumes the previous reload
37 sinking pass, and also performs basic inlining.
38
39 Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
40
41 The ostensible cause is that the linear register allocator is getting
42 really unlucky and needs to insert a fixup block after precisely one
43 jump in a jump table, because the block it jumps to was processed
44 already. As you can see, actually getting the linear register allocator
45 into this funk is /very/ difficult.
46
47 -}
48
49 module DriverPipeline (compileFile) where
50
51 import Control.Exception
52
53 import Control.Applicative (Applicative(..))
54 import Control.Monad (liftM, ap)
55
56 data Phase
57 = Unlit ()
58 | Ccpp
59 | Cc
60 | Cobjc
61 | HCc
62 | SplitAs
63 | As
64 | LlvmOpt
65 | LlvmLlc
66 | LlvmMangle
67 | MergeStub
68 | StopLn
69 deriving (Show)
70
71 data PipeState = PipeState {
72 stop_phase :: Phase,
73 src_basename :: String,
74 output_spec :: (),
75 hsc_env :: Maybe String,
76 maybe_loc :: Maybe String
77 }
78
79 newtype CompPipeline a = P { unP :: PipeState -> IO (PipeState, a) }
80
81 instance Functor CompPipeline where
82 fmap = liftM
83
84 instance Applicative CompPipeline where
85 pure = return
86 (<*>) = ap
87
88 instance Monad CompPipeline where
89 return a = P $ \state -> return (state, a)
90 P m >>= k = P $ \state -> do (state',a) <- m state
91 unP (k a) state'
92
93 eqPhase :: Phase -> Phase -> Bool
94 eqPhase (Unlit _) (Unlit _) = True
95 eqPhase Ccpp Ccpp = True
96 eqPhase Cc Cc = True
97 eqPhase HCc HCc = True
98 eqPhase SplitAs SplitAs = True
99 eqPhase As As = True
100 eqPhase LlvmOpt LlvmOpt = True
101 eqPhase LlvmLlc LlvmLlc = True
102 eqPhase LlvmMangle LlvmMangle = True
103 eqPhase MergeStub MergeStub = True
104 eqPhase StopLn StopLn = True
105 eqPhase _ _ = False
106
107 compileFile start_phase state = do
108 unP (pipeLoop start_phase) state
109 getOutputFilename undefined undefined undefined undefined undefined undefined
110
111 pipeLoop phase = do
112 dflags@PipeState{stop_phase} <- getPipeState
113 io $ evaluate (phase `eqPhase` stop_phase)
114 runPhase phase dflags
115 pipeLoop phase
116
117 getOutputFilename :: Phase -> () -> String -> Maybe String -> Phase -> Maybe String -> IO String
118 getOutputFilename p o b md p' ml
119 | p' `eqPhase` p, () <- o = undefined
120 | Just l <- ml = return l
121 | Just d <- md = return $ d ++ b
122 | otherwise = undefined
123
124 runPhase p _ | p `eqPhase` Cc || p `eqPhase` Ccpp || p `eqPhase` HCc || p `eqPhase` Cobjc = undefined
125 runPhase LlvmMangle _ = undefined
126 runPhase SplitAs _ = undefined
127 runPhase LlvmOpt _ = undefined
128 runPhase LlvmLlc dflags = phaseOutputFilename >> io (evaluate dflags) >> return undefined
129 runPhase MergeStub _ = phaseOutputFilename >> undefined
130 runPhase other _ = io (evaluate (show other)) >> undefined
131
132 phaseOutputFilename :: CompPipeline ()
133 phaseOutputFilename = do
134 PipeState{stop_phase, src_basename, output_spec, maybe_loc, hsc_env} <- getPipeState
135 io $ getOutputFilename stop_phase output_spec src_basename hsc_env StopLn maybe_loc
136
137 getPipeState = P $ \state -> return (state, state)
138 io m = P $ \state -> do a <- m; return (state, ())