Commit 97a8fe87 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Template Haskell: improve lifting for strings

When you have a (\s::String -> ....[| s |]....), the string 
's' is lifted.  We used to get a chain of single-character 
Cons nodes, correct but lots and lots of code.  

This patch arranges to optimise that to a string literal. It does
so in two places:
  a) In TcExpr, if we know that s::String, we generate liftString directly
  b) In DsMeta, if we find a list of character literals, we convert to
     a string.  This catches a few cases that (a) does not

There an accompanying  patch in the template-haskell package, 
adding Language.Haskell.TH.Syntax.liftString

parent 857847a6
......@@ -23,7 +23,7 @@
module DsMeta( dsBracket,
templateHaskellNames, qTyConName, nameTyConName,
liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
quoteExpName, quotePatName
) where
......@@ -1757,12 +1757,13 @@ predTyConName = thTc (fsLit "Pred") predTyConKey
returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
mkNameLName :: Name
returnQName = thFun (fsLit "returnQ") returnQIdKey
bindQName = thFun (fsLit "bindQ") bindQIdKey
sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
mkNameLName, liftStringName :: Name
returnQName = thFun (fsLit "returnQ") returnQIdKey
bindQName = thFun (fsLit "bindQ") bindQIdKey
sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
newNameName = thFun (fsLit "newName") newNameIdKey
liftName = thFun (fsLit "lift") liftIdKey
liftName = thFun (fsLit "lift") liftIdKey
liftStringName = thFun (fsLit "liftString") liftStringIdKey
mkNameName = thFun (fsLit "mkName") mkNameIdKey
mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
......@@ -2053,6 +2054,9 @@ floatPrimLIdKey = mkPreludeMiscIdUnique 215
doublePrimLIdKey = mkPreludeMiscIdUnique 216
rationalLIdKey = mkPreludeMiscIdUnique 217
liftStringIdKey :: Unique
liftStringIdKey = mkPreludeMiscIdUnique 218
-- data Pat = ...
litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
......@@ -2081,6 +2085,7 @@ matchIdKey = mkPreludeMiscIdUnique 231
clauseIdKey :: Unique
clauseIdKey = mkPreludeMiscIdUnique 232
-- data Exp = ...
varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,
......
......@@ -508,7 +508,10 @@ cvtl e = wrapL (cvt e)
cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
cvt (ListE xs) = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
cvt (ListE xs)
| Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
-- Note [Converting strings]
| otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
; e' <- returnL $ OpApp x' s' undefined y'
; return $ HsPar e' }
......@@ -597,6 +600,21 @@ cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
-- An Integer is like an (overloaded) '3' in a Haskell source program
-- Similarly 3.5 for fractionals
{- Note [Converting strings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
a string literal for "xy". Of course, we might hope to get
(LitE (StringL "xy")), but not always, and allCharLs fails quickly
if it isn't a literal string
-}
allCharLs :: [TH.Exp] -> Maybe String
-- Note [Converting strings]
allCharLs (LitE (CharL c) : xs)
| Just cs <- allCharLs xs = Just (c:cs)
allCharLs [] = Just []
allCharLs _ = Nothing
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
......
......@@ -1152,18 +1152,33 @@ thBrackId orig id ps_var lie_var
-- so we zap it to a LiftedTypeKind monotype
-- C.f. the call in TcPat.newLitInst
; setLIEVar lie_var $ do
{ lift <- newMethodFromName orig id_ty' DsMeta.liftName
-- Put the 'lift' constraint into the right LIE
; lift <- if isStringTy id_ty' then
tcLookupId DsMeta.liftStringName
-- See Note [Lifting strings]
else
setLIEVar lie_var $ do -- Put the 'lift' constraint into the right LIE
newMethodFromName orig id_ty' DsMeta.liftName
-- Update the pending splices
; ps <- readMutVar ps_var
; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
; return id } }
; return id }
#endif /* GHCI */
\end{code}
Note [Lifting strings]
~~~~~~~~~~~~~~~~~~~~~~
If we see $(... [| s |] ...) where s::String, we don't want to
generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
So this conditional short-circuits the lifting mechanism to generate
(liftString "xy") in that case. I didn't want to use overlapping instances
for the Lift class in TH.Syntax, because that can lead to overlapping-instance
errors in a polymorphic situation.
If this check fails (which isn't impossible) we get another chance; see
Note [Converting strings] in Convert.lhs
Local record selectors
~~~~~~~~~~~~~~~~~~~~~~
Record selectors for TyCons in this module are ordinary local bindings,
......
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