debugging

5 files changed, 28 insertions, 3 deletions

diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 6cdb14880a..ec5441a2f0 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -70,24 +70,34 @@ codeGen dflags this_mod data_tycons
         ; cgref <- liftIO $ newIORef =<< initC
         ; let cg :: FCode () -> Stream IO CmmGroup ()
               cg fcode = do
+                pprTraceM "cg" empty
                 cmm <- liftIO $ do
+                         putStrLn "start1"
                          st <- readIORef cgref
+                         putStrLn "start2"
                          let (a,st') = runC dflags this_mod st (getCmm fcode)
 
+                         putStrLn "start3"
                          -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
                          -- a big space leak.  DO NOT REMOVE!
                          writeIORef cgref $! st'{ cgs_tops = nilOL,
                                                   cgs_stmts = mkNop }
+                         putStrLn "start4"
                          return a
+                pprTraceM "cg2" empty
                 yield cmm
+                pprTraceM "cg3" empty
 
                -- Note [codegen-split-init] the cmm_init block must come
                -- FIRST.  This is because when -split-objs is on we need to
                -- combine this block with its initialisation routines; see
                -- Note [pipeline-split-init].
+        ; pprTraceM "this far" empty
         ; cg (mkModuleInit cost_centre_info this_mod hpc_info)
+        ; pprTraceM "this far2" empty
 
         ; mapM_ (cg . cgTopBinding dflags) stg_binds
+        ; pprTraceM "this far3" empty
 
                 -- Put datatype_stuff after code_stuff, because the
                 -- datatype closure table (for enumeration types) to
@@ -120,8 +130,11 @@ variable. -}
 cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()
 cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))
   = do  { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs
+        ; pprTraceM "this far 4" (ppr id)
         ; fcode
+        ; pprTraceM "this far 5" (ppr id)
         ; addBindC info
+        ; pprTraceM "this far 6" (ppr id)
         }
 
 cgTopBinding dflags (StgTopLifted (StgRec pairs))
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index 258896ff1a..46397f171e 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -77,6 +77,7 @@ cgTopRhsCon dflags id con args =
               MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )
         ; ASSERT( args `lengthIs` countConRepArgs con ) return ()
 
+        ; pprTraceM "this far 6" (ppr id)
         -- LAY IT OUT
         ; let
             (tot_wds, --  #ptr_wds + #nonptr_wds
@@ -99,6 +100,7 @@ cgTopRhsCon dflags id con args =
             info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds
 
 
+        ; pprTraceM "this far 7" (ppr id)
         ; payload <- mapM mk_payload nv_args_w_offsets
                 -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
                 -- NB2: all the amodes should be Lits!
@@ -112,7 +114,9 @@ cgTopRhsCon dflags id con args =
                              payload
 
                 -- BUILD THE OBJECT
+        ; pprTraceM "this far 8" (ppr id)
         ; emitDataLits closure_label closure_rep
+        ; pprTraceM "this far 9" (ppr id)
 
         ; return () }
 
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index e605762f1f..1f5d40c259 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -109,6 +109,8 @@ maybeLetNoEscape _other                                      = Nothing
 addBindC :: CgIdInfo -> FCode ()
 addBindC stuff_to_bind = do
         binds <- getBinds
+        pprTraceM "this far new 1" empty
+
         setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
 
 addBindsC :: [CgIdInfo] -> FCode ()
diff --git a/hadrian/ghci.sh b/hadrian/ghci.sh
index 4c9b9c6710..21291b126b 100755
--- a/hadrian/ghci.sh
+++ b/hadrian/ghci.sh
@@ -2,5 +2,8 @@
 
 set -e
 
-GHC_FLAGS=$(TERM=dumb CABFLAGS=-v0 . "hadrian/build.cabal.sh" tool-args -q --build-root=.hadrian_ghci --flavour=ghc-in-ghci "$@")
-ghci $GHC_FLAGS -fno-code -fwrite-interface -hidir=.hadrian_ghci/interface -O0 ghc/Main.hs
+GHC=/home/matt/ghc/m559b/stage1/bin/ghc
+export GHC_LOADED_INTO_GHCI=1
+GHC_FLAGS=$(TERM=dumb CABFLAGS=-v0 . "hadrian/build.cabal.sh"  tool-args -q --build-root=.hadrian_ghci --flavour=ghc-in-ghci "$@")
+echo $GHC_FLAGS
+/home/matt/ghc/m559b/stage1/bin/ghc --interactive -O0 $GHC_FLAGS -fwrite-interface -hidir=.hadrian_ghci/interface -O0 -DGHC_LOADED_INTO_GHCI ghc/Main.hs
diff --git a/utils/genprimopcode/ParserM.hs b/utils/genprimopcode/ParserM.hs
index 190ec0edc0..ada6291ca3 100644
--- a/utils/genprimopcode/ParserM.hs
+++ b/utils/genprimopcode/ParserM.hs
@@ -42,7 +42,10 @@ instance Monad ParserM where
                                             Left err ->
                                                 Left err
     return a = ParserM $ \i s -> Right (i, s, a)
-    fail err = ParserM $ \_ _ -> Left err
+    --fail err = ParserM $ \_ _ -> Left err
+
+instance MonadFail ParserM where
+  fail err = ParserM $ \_ _ -> Left err
 
 run_parser :: ParserM a -> (String -> Either String a)
 run_parser (ParserM f)