jmp_tbl.hs 6.29 KB
Newer Older
Edward Z. Yang's avatar
Edward Z. Yang committed
1 2 3 4 5 6
{-# LANGUAGE NamedFieldPuns #-}

{-
This funny module was reduced from a failing build of stage2 using
the new code generator and the linear register allocator, with this bug:

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 bin-package-db-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
Edward Z. Yang's avatar
Edward Z. Yang committed
8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52

ghc-stage1: panic! (the 'impossible' happened)
  (GHC version 7.1.20110414 for x86_64-unknown-linux):
        Cannot patch JMP_TBL

This panic only appears to show up on x86-64 and with -fPIC.  I wasn't
able to get the produced optimized C-- to crash the linear register
allocator.  To see the bug, you need some extra patches for the new code
generator, in particular, this set (which can be acquired from the
jmp_tbl_bug tag at <https://github.com/ezyang/ghc>):

    commit 7b275c93df7944f0a9b51034cf1f64e3e70582a5
    Author: Edward Z. Yang <ezyang@mit.edu>
    Date:   Thu Apr 14 21:20:21 2011 +0100

        Give manifestSP better information about the actual SP location.

        This patch fixes silliness where the SP pointer is continually
        bumped up and down.

        Signed-off-by: Edward Z. Yang <ezyang@mit.edu>

    commit 5b5add4246d3997670ae995f7d2a028db92fff95
    Author: Edward Z. Yang <ezyang@mit.edu>
    Date:   Wed Apr 13 11:16:36 2011 +0100

        Generalized assignment rewriting pass.

        This assignment rewriting pass subsumes the previous reload
        sinking pass, and also performs basic inlining.

        Signed-off-by: Edward Z. Yang <ezyang@mit.edu>

The ostensible cause is that the linear register allocator is getting
really unlucky and needs to insert a fixup block after precisely one
jump in a jump table, because the block it jumps to was processed
already.  As you can see, actually getting the linear register allocator
into this funk is /very/ difficult.

-}

module DriverPipeline (compileFile) where

import Control.Exception

thoughtpolice's avatar
thoughtpolice committed
53 54 55
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)

Edward Z. Yang's avatar
Edward Z. Yang committed
56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
data Phase
        = Unlit ()
        | Ccpp
        | Cc
        | Cobjc
        | HCc
        | SplitAs
        | As
        | LlvmOpt
        | LlvmLlc
        | LlvmMangle
        | MergeStub
        | StopLn
  deriving (Show)

data PipeState = PipeState {
       stop_phase   :: Phase,
       src_basename :: String,
       output_spec  :: (),
       hsc_env      :: Maybe String,
       maybe_loc    :: Maybe String
  }

newtype CompPipeline a = P { unP :: PipeState -> IO (PipeState, a) }

thoughtpolice's avatar
thoughtpolice committed
81 82 83 84 85 86 87
instance Functor CompPipeline where
    fmap = liftM

instance Applicative CompPipeline where
    pure = return
    (<*>) = ap

Edward Z. Yang's avatar
Edward Z. Yang committed
88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
instance Monad CompPipeline where
  return a = P $ \state -> return (state, a)
  P m >>= k = P $ \state -> do (state',a) <- m state
                               unP (k a) state'

eqPhase :: Phase -> Phase -> Bool
eqPhase (Unlit _)   (Unlit _)   = True
eqPhase Ccpp        Ccpp        = True
eqPhase Cc          Cc          = True
eqPhase HCc         HCc         = True
eqPhase SplitAs     SplitAs     = True
eqPhase As          As          = True
eqPhase LlvmOpt	    LlvmOpt 	= True
eqPhase LlvmLlc	    LlvmLlc 	= True
eqPhase LlvmMangle  LlvmMangle 	= True
eqPhase MergeStub   MergeStub   = True
eqPhase StopLn      StopLn      = True
eqPhase _           _           = False

compileFile start_phase state = do
  unP (pipeLoop start_phase) state
  getOutputFilename undefined undefined undefined undefined undefined undefined

pipeLoop phase = do
  dflags@PipeState{stop_phase} <- getPipeState
  io $ evaluate (phase `eqPhase` stop_phase)
  runPhase phase dflags
  pipeLoop phase

getOutputFilename :: Phase -> () -> String -> Maybe String -> Phase -> Maybe String -> IO String
getOutputFilename p o b md p' ml
   | p' `eqPhase` p, () <- o = undefined
   | Just l <- ml = return l
   | Just d <- md = return $ d ++ b
   | otherwise    = undefined

runPhase p _ | p `eqPhase` Cc || p `eqPhase` Ccpp || p `eqPhase` HCc || p `eqPhase` Cobjc = undefined
runPhase LlvmMangle _ = undefined
runPhase SplitAs _ = undefined
runPhase LlvmOpt _ = undefined
runPhase LlvmLlc dflags = phaseOutputFilename >> io (evaluate dflags) >> return undefined
runPhase MergeStub _ = phaseOutputFilename >> undefined
runPhase other _ = io (evaluate (show other)) >> undefined

phaseOutputFilename :: CompPipeline ()
phaseOutputFilename = do
  PipeState{stop_phase, src_basename, output_spec, maybe_loc, hsc_env} <- getPipeState
  io $ getOutputFilename stop_phase output_spec src_basename hsc_env StopLn maybe_loc

getPipeState = P $ \state -> return (state, state)
io m = P $ \state -> do a <- m; return (state, ())