Commit aa293b89 authored by Matthew Pickering's avatar Matthew Pickering

WIP

parent 4a4044df
......@@ -529,7 +529,7 @@ toIfUnfolding _ NoUnfolding = Nothing
toIfaceExpr :: CoreExpr -> IfaceExpr
toIfaceExpr (Var v) = toIfaceVar v
toIfaceExpr (Lit l) = IfaceLit l
toIfaceExpr (Lit l) = IfaceLit (() <$ l)
toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co)
toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b)
......@@ -572,7 +572,7 @@ toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r)
---------------------
toIfaceCon :: AltCon -> IfaceConAlt
toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)
toIfaceCon (LitAlt l) = IfaceLitAlt l
toIfaceCon (LitAlt l) = IfaceLitAlt (() <$ l)
toIfaceCon DEFAULT = IfaceDefault
---------------------
......
......@@ -473,13 +473,14 @@ loadInterface doc_str mod from
; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
; let { final_iface = iface {
; let { final_iface = iface
{-{
mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_insts in PIT",
mi_fam_insts = panic "No mi_fam_insts in PIT",
mi_rules = panic "No mi_rules in PIT",
mi_anns = panic "No mi_anns in PIT"
}
} -}
}
; let bad_boot = mi_boot iface && fmap fst (if_rec_types gbl_env) == Just mod
......
......@@ -494,10 +494,12 @@ data IfaceExpr
| IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives]
| IfaceLet IfaceBinding IfaceExpr
| IfaceCast IfaceExpr IfaceCoercion
| IfaceLit Literal
| IfaceLit IfaceLiteral
| IfaceFCall ForeignCall IfaceType
| IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E
type IfaceLiteral = LiteralX ()
data IfaceTickish
= IfaceHpcTick Module Int -- from HpcTick x
| IfaceSCC CostCentre Bool Bool -- from ProfNote
......@@ -511,7 +513,7 @@ type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
data IfaceConAlt = IfaceDefault
| IfaceDataAlt IfExtName
| IfaceLitAlt Literal
| IfaceLitAlt IfaceLiteral
data IfaceBinding
= IfaceNonRec IfaceLetBndr IfaceExpr
......
......@@ -27,6 +27,7 @@ module GHC.IfaceToCore (
import GhcPrelude
import TcTypeNats(typeNatCoAxiomRules)
import TysPrim
import GHC.Iface.Syntax
import GHC.Iface.Load
import GHC.Iface.Env
......@@ -1383,7 +1384,7 @@ tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
-------------------------
tcIfaceLit :: Literal -> IfL Literal
tcIfaceLit :: LiteralX () -> IfL Literal
-- Integer literals deserialise to (LitInteger i <error thunk>)
-- so tcIfaceLit just fills in the type.
-- See Note [Integer literals] in Literal
......@@ -1396,7 +1397,21 @@ tcIfaceLit (LitNumber LitNumInteger i _)
tcIfaceLit (LitNumber LitNumNatural i _)
= do t <- tcIfaceTyConByName naturalTyConName
return (mkLitNatural i (mkTyConTy t))
tcIfaceLit lit = return lit
tcIfaceLit (LitChar c) = return $ LitChar c
tcIfaceLit (LitNumber t i _) =
let ty = case t of
LitNumInt -> intPrimTy
LitNumInt64 -> int64PrimTy
LitNumWord -> wordPrimTy
LitNumWord64 -> word64PrimTy
in return $ LitNumber t i ty
tcIfaceLit (LitString s) = return (LitString s)
tcIfaceLit LitNullAddr = return LitNullAddr
tcIfaceLit LitRubbish = return LitRubbish
tcIfaceLit (LitFloat f) = return (LitFloat f)
tcIfaceLit (LitDouble d) = return (LitDouble d)
tcIfaceLit (LitLabel l d e) = return (LitLabel l d e)
-- tcIfaceLit lit = return lit
-------------------------
tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
......
......@@ -6,12 +6,14 @@
-}
{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Literal
(
-- * Main data type
Literal(..) -- Exported to ParseIface
Literal -- Exported to ParseIface
, LiteralX(..)
, LitNumType(..)
-- ** Creating Literals
......@@ -103,12 +105,14 @@ import Numeric ( fromRat )
-- * A character
-- * A string
-- * The NULL pointer
--
data Literal
type Literal = LiteralX Type
data LiteralX a
= LitChar Char -- ^ @Char#@ - at least 31 bits. Create with
-- 'mkLitChar'
| LitNumber !LitNumType !Integer Type
| LitNumber !LitNumType !Integer a
-- ^ Any numeric literal that can be
-- internally represented with an Integer.
-- See Note [Types of LitNumbers] below for the
......@@ -146,7 +150,7 @@ data Literal
--
-- 3) Flag indicating whether the symbol
-- references a function or a data
deriving Data
deriving (Data, Functor, Foldable, Traversable)
-- | Numeric literal type
data LitNumType
......@@ -212,7 +216,7 @@ instance Binary LitNumType where
h <- getByte bh
return (toEnum (fromIntegral h))
instance Binary Literal where
instance Binary (LiteralX ()) where
put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa
put_ bh (LitString ab) = do putByte bh 1; put_ bh ab
put_ bh (LitNullAddr) = do putByte bh 2
......@@ -254,30 +258,19 @@ instance Binary Literal where
nt <- get bh
i <- get bh
-- Note [Types of LitNumbers]
let t = case nt of
LitNumInt -> intPrimTy
LitNumInt64 -> int64PrimTy
LitNumWord -> wordPrimTy
LitNumWord64 -> word64PrimTy
-- See Note [Integer literals]
LitNumInteger ->
panic "Evaluated the place holder for mkInteger"
-- and Note [Natural literals]
LitNumNatural ->
panic "Evaluated the place holder for mkNatural"
return (LitNumber nt i t)
return (LitNumber nt i ())
_ -> do
return (LitRubbish)
instance Outputable Literal where
instance Outputable (LiteralX a) where
ppr = pprLiteral id
instance Eq Literal where
instance Eq (LiteralX a) where
a == b = compare a b == EQ
-- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in
-- 'TrieMap.CoreMap'.
instance Ord Literal where
instance Ord (LiteralX a) where
compare = cmpLit
{-
......@@ -699,7 +692,7 @@ absent_lits = listToUFM [ (addrPrimTyConKey, LitNullAddr)
~~~~~~~~~~
-}
cmpLit :: Literal -> Literal -> Ordering
cmpLit :: LiteralX a -> LiteralX a -> Ordering
cmpLit (LitChar a) (LitChar b) = a `compare` b
cmpLit (LitString a) (LitString b) = a `compare` b
cmpLit (LitNullAddr) (LitNullAddr) = EQ
......@@ -714,7 +707,7 @@ cmpLit lit1 lit2
| litTag lit1 < litTag lit2 = LT
| otherwise = GT
litTag :: Literal -> Int
litTag :: LiteralX a -> Int
litTag (LitChar _) = 1
litTag (LitString _) = 2
litTag (LitNullAddr) = 3
......@@ -730,7 +723,7 @@ litTag (LitRubbish) = 8
* See Note [Printing of literals in Core]
-}
pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
pprLiteral :: (SDoc -> SDoc) -> LiteralX a -> SDoc
pprLiteral _ (LitChar c) = pprPrimChar c
pprLiteral _ (LitString s) = pprHsBytes (fastStringToShortByteString s)
pprLiteral _ (LitNullAddr) = text "__NULL"
......
......@@ -32,7 +32,7 @@ import {-#SOURCE #-} CoreUnfold ( mkUnfolding )
import MkCore ( FloatBind(..) )
import PprCore ( pprCoreBindings, pprRules )
import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
import Literal ( Literal(LitString) )
import Literal ( Literal, LiteralX(LitString) )
import Id
import IdInfo ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )
import Var ( isNonCoVarId )
......
......@@ -628,15 +628,14 @@ extendPIT (PackageIfaceTable comp pit) m mi = do
let raw_iface = forgetModIfaceCaches mi
compact_region <- case comp of
CompactRegion c -> do
-- test c raw_iface
compactAddWithSharing c raw_iface
--- test c raw_iface
compactAdd c raw_iface
EmptyRegion -> do
-- compact () >>= flip test raw_iface
compactWithSharing raw_iface
-- compact () >>= flip test raw_iface
compact raw_iface
let compacted_iface = initModIfaceCaches $ getCompact compact_region
return (PackageIfaceTable (CompactRegion compact_region) (extendModuleEnv pit m compacted_iface))
{-
test :: Compact a -> RawModIface -> IO ()
test bh (ModIface {
mi_module = mod,
......@@ -699,7 +698,6 @@ test bh (ModIface {
print 12
compactAddWithSharing bh usages
print 13
pprTraceM "exports" (ppr exports)
compactAddWithSharing bh exports
print 14
compactAddWithSharing bh exp_hash
......@@ -712,6 +710,52 @@ test bh (ModIface {
print 18
compactAddWithSharing bh anns
print 19
let test_one (IfaceId a b c d) = do
print "start"
pprTrace "decl1" (ppr a) (compactAddWithSharing bh a)
pprTrace "decl2" (ppr b) (compactAddWithSharing bh b)
pprTrace "decl3" (ppr c) (compactAddWithSharing bh c)
case d of
NoInfo -> return ()
HasInfo hs ->
mapM_ (\i -> case i of
HsUnfold _ u ->
do_u u
_ -> return ()) hs
print "done"
return ()
test_one d = do
pprTraceM "start" (ppr d)
pprTrace "decl-other" (ppr d) (compactAddWithSharing bh d)
print "end"
return ()
do_u (IfCoreUnfold _ i_e) = do_ie i_e
do_u _ = return ()
do_ie x = case x of
IfaceLcl l -> do
pprTrace "e-lcl" (ppr l) (compactAddWithSharing bh l)
return ()
IfaceType t -> do
pprTrace "e-t" (ppr t) (compactAddWithSharing bh t)
return ()
-- IfaceCo co
-- IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted
-- IfaceLam IfaceLamBndr IfaceExpr
IfaceApp e1 e2 -> do_ie e1 >> do_ie e2
-- IfaceCase IfaceExpr IfLclName [IfaceAlt]
-- IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives]
-- IfaceLet IfaceBinding IfaceExpr
-- IfaceCast IfaceExpr IfaceCoercion
IfaceLit l -> do
pprTrace "e-l" (ppr l) (compactAddWithSharing bh l)
return ()
-- IfaceFCall ForeignCall IfaceType
-- IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E
_ -> return ()
-- mapM_ (\d -> test_one d) (map snd decls)
compactAddWithSharing bh decls
print 20
compactAddWithSharing bh insts
......@@ -737,7 +781,6 @@ test bh (ModIface {
compactAddWithSharing bh arg_docs
print 31
return ()
-}
extendPITFake :: PackageIfaceTable -> Module -> PackageIfaceTable
extendPITFake (PackageIfaceTable c pit) mod =
......
......@@ -10,7 +10,7 @@ import FastString
import Type
import CoreSyn
import MkCore
import Literal ( Literal(..) )
import Literal ( LiteralX(..) )
import TcEvidence
import HscTypes
import DynFlags
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment