diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/deSugar/Desugar.hs | 6 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 3 | ||||
| -rw-r--r-- | compiler/typecheck/TcSplice.hs | 12 |
4 files changed, 22 insertions, 1 deletions
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 1cd7979128..5111141770 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -289,6 +289,7 @@ deSugar hsc_env tcg_imp_specs = imp_specs, tcg_dependent_files = dependent_files, tcg_ev_binds = ev_binds, + tcg_th_cstubs = th_cstubs_var, tcg_fords = fords, tcg_rules = rules, tcg_vects = vects, @@ -373,6 +374,9 @@ deSugar hsc_env -- past desugaring. See Note [Identity versus semantic module]. ; MASSERT( id_mod == mod ) + ; cstubs <- readIORef th_cstubs_var + ; let ds_fords' = foldl' appendStubC ds_fords (map text cstubs) + ; let mod_guts = ModGuts { mg_module = mod, mg_hsc_src = hsc_src, @@ -393,7 +397,7 @@ deSugar hsc_env mg_patsyns = patsyns, mg_rules = ds_rules_for_imps, mg_binds = ds_binds, - mg_foreign = ds_fords, + mg_foreign = ds_fords', mg_hpc_info = ds_hpc_info, mg_modBreaks = modBreaks, mg_vect_decls = ds_vects, diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 33cb4d14d0..1c84b4014e 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -217,6 +217,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this dependent_files_var <- newIORef [] ; static_wc_var <- newIORef emptyWC ; th_topdecls_var <- newIORef [] ; + th_cstubs_var <- newIORef [] ; th_topnames_var <- newIORef emptyNameSet ; th_modfinalizers_var <- newIORef [] ; th_state_var <- newIORef Map.empty ; @@ -231,6 +232,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this gbl_env = TcGblEnv { tcg_th_topdecls = th_topdecls_var, + tcg_th_cstubs = th_cstubs_var, tcg_th_topnames = th_topnames_var, tcg_th_modfinalizers = th_modfinalizers_var, tcg_th_state = th_state_var, diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 782a99297b..766119635f 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -608,6 +608,9 @@ data TcGblEnv tcg_th_topdecls :: TcRef [LHsDecl RdrName], -- ^ Top-level declarations from addTopDecls + tcg_th_cstubs :: TcRef [String], + -- ^ C stubs from addCStub + tcg_th_topnames :: TcRef NameSet, -- ^ Exact names bound in top-level declarations in tcg_th_topdecls diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index e142cae3b2..aba70aaaa1 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -909,6 +909,17 @@ instance TH.Quasi TcM where hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") + qAddCStub str = do + l <- getSrcSpanM + r <- case l of + UnhelpfulSpan _ -> pprPanic "qAddCStub: Unhelpful location" (ppr l) + RealSrcSpan s -> return s + let filename = unpackFS (srcSpanFile r) + linePragma = "#line " ++ show (srcSpanStartLine r) + ++ " " ++ show filename + th_cstubs_var <- fmap tcg_th_cstubs getGblEnv + updTcRef th_cstubs_var ([linePragma, str] ++) + qAddModFinalizer fin = do r <- liftIO $ mkRemoteRef fin fref <- liftIO $ mkForeignRef r (freeRemoteRef r) @@ -1100,6 +1111,7 @@ handleTHMessage msg = case msg of hsc_env <- env_top <$> getEnv wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs + AddCStub str -> wrapTHResult $ TH.qAddCStub str IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled _ -> panic ("handleTHMessage: unexpected message " ++ show msg) |