import HscTypes ( HscEnv )
import Linker
-import DataCon
-import Type
-import TcRnMonad ( TcM, initTc, ioToTcRn,
- tryTcErrs)
+import DataCon
+import Type
+import Var
+import TcRnMonad ( TcM, initTc, ioToTcRn,
+ tryTcErrs, traceTc)
import TcType
import TcMType
import TcUnify
import TcGadt
import TcEnv
import DriverPhases
-import TyCon
-import Name
+import TyCon
+import Name
import VarEnv
import Util
import VarSet
-import TysPrim
+import TysPrim
import PrelNames
import TysWiredIn
getClosureData a =
case unpackClosure# a of
(# iptr, ptrs, nptrs #) -> do
+#ifndef GHCI_TABLES_NEXT_TO_CODE
+ -- the info pointer we get back from unpackClosure# is to the
+ -- beginning of the standard info table, but the Storable instance
+ -- for info tables takes into account the extra entry pointer
+ -- when !tablesNextToCode, so we must adjust here:
+ itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE)
+#else
itbl <- peek (Ptr iptr)
+#endif
let tipe = readCType (BCI.tipe itbl)
elems = fromIntegral (BCI.ptrs itbl)
ptrsList = Array 0 (elems - 1) elems ptrs
runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
+traceTR :: SDoc -> TR ()
+traceTR = liftTcM . traceTc
+
trIO :: IO a -> TR a
trIO = liftTcM . ioToTcRn
-- and showing the '_' is more useful.
t | isThunk t && force -> seq a $ go (pred bound) tv ty a
-- We always follow indirections
- Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
+ Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
-- The interesting case
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
| isPointed ty = ASSERT2(not(null pointed)
, ptext SLIT("reOrderTerms") $$
(ppr pointed $$ ppr unpointed))
- head pointed : reOrderTerms (tail pointed) unpointed tys
+ let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
| otherwise = ASSERT2(not(null unpointed)
, ptext SLIT("reOrderTerms") $$
(ppr pointed $$ ppr unpointed))
- head unpointed : reOrderTerms pointed (tail unpointed) tys
+ let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
expandNewtypes t@Term{ ty=ty, subTerms=tt }
| Just (tc, args) <- splitNewTyConApp_maybe ty
substTy rev_subst `fmap` zonkTcType tv
where
-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
- search _ _ _ 0 = fail$ "Failed to reconstruct a type after " ++
- show max_depth ++ " steps"
+ search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
+ int max_depth <> text " steps")
search stop expand l d =
case viewl l of
EmptyL -> return ()
Note that it is very tricky to make this 'rewriting'
work with the unification implemented by TcM, where
substitutions are 'inlined'. The order in which
- constraints are unified is vital for this (or I am
- using TcM wrongly).
+ constraints are unified is vital for this.
+ This is a simple form of residuation, the technique of
+ delaying unification steps until enough information
+ is available.
-}
-congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
+congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
congruenceNewtypes lhs rhs
-- TyVar lhs inductive case
| Just tv <- getTyVar_maybe lhs
| Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
, Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
, tycon_l /= tycon_r
- = return (lhs, upgrade tycon_l rhs)
+ = do rhs' <- upgrade tycon_l rhs
+ return (lhs, rhs')
| otherwise = return (lhs,rhs)
- where upgrade :: TyCon -> Type -> Type
+ where upgrade :: TyCon -> Type -> TR Type
upgrade new_tycon ty
- | not (isNewTyCon new_tycon) = ty
- | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
- , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
- = substTy subst ty'
- upgrade _ _ = panic "congruenceNewtypes.upgrade"
- -- assumes that reptype doesn't touch tyconApp args ^^^
+ | not (isNewTyCon new_tycon) = return ty
+ | otherwise = do
+ vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
+ let ty' = mkTyConApp new_tycon vars
+ liftTcM (unifyType ty (repType ty'))
+ -- assumes that reptype doesn't ^^^^ touch tyconApp args
+ return ty'
--------------------------------------------------------------------------------