[project @ 2000-01-04 17:40:46 by simonpj]

This commit arranges that literal strings will fuse
nicely, by expressing them as an application of build.

* NoRepStr is now completely redundant, though I havn't removed it yet.

* The unpackStr stuff moves from PrelPack to PrelBase.

* There's a new form of Rule, a BuiltinRule, for rules that
  can't be expressed in Haskell.  The string-fusion rule is one
  such.  It's defined in prelude/PrelRules.lhs.

* PrelRules.lhs also contains a great deal of code that
  implements constant folding.  In due course this will replace
  ConFold.lhs, but for the moment it simply duplicates it.

1 files changed, 33 insertions, 8 deletions

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 94aa74156a..80937db165 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -11,7 +11,7 @@ module CoreSyn (
 
 	mkLets, mkLams,
 	mkApps, mkTyApps, mkValApps, mkVarApps,
-	mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote,
+	mkLit, mkStringLit, mkStringLitFS, mkConApp, mkPrimApp, mkNote,
 	bindNonRec, mkIfThenElse, varToCoreExpr,
 
 	bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId,
@@ -34,6 +34,7 @@ module CoreSyn (
 	-- Core rules
 	CoreRules(..), 	-- Representation needed by friends
 	CoreRule(..),	-- CoreSubst, CoreTidy, CoreFVs, PprCore only
+	RuleName,
 	emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules
     ) where
 
@@ -46,8 +47,9 @@ import VarEnv
 import Id		( mkWildId, getIdOccInfo, idInfo )
 import Type		( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType )
 import IdInfo		( OccInfo(..), megaSeqIdInfo )
-import Const	        ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
+import Const	        ( Con(..), DataCon, Literal(MachStr), mkMachInt, PrimOp )
 import TysWiredIn	( trueDataCon, falseDataCon )
+import ThinAir		( unpackCStringId, unpackCString2Id, addr2IntegerId )
 import VarSet
 import Outputable
 \end{code}
@@ -118,12 +120,18 @@ data CoreRules
   = Rules [CoreRule]
 	  IdOrTyVarSet		-- Locally-defined free vars of RHSs
 
+type RuleName = FAST_STRING
+
 data CoreRule
-  = Rule FAST_STRING	-- Rule name
+  = Rule RuleName
 	 [CoreBndr]	-- Forall'd variables
 	 [CoreExpr]	-- LHS args
 	 CoreExpr	-- RHS
 
+  | BuiltinRule		-- Built-in rules are used for constant folding
+			-- and suchlike.  It has no free variables.
+	([CoreExpr] -> Maybe (RuleName, CoreExpr))
+
 emptyCoreRules :: CoreRules
 emptyCoreRules = Rules [] emptyVarSet
 
@@ -184,16 +192,32 @@ mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 mkValApps f args = foldl (\ e a -> App e a)	   f args
 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 
-mkLit       :: Literal -> Expr b
-mkStringLit :: String  -> Expr b
-mkConApp    :: DataCon -> [Arg b] -> Expr b
-mkPrimApp   :: PrimOp  -> [Arg b] -> Expr b
+mkLit         :: Literal -> Expr b
+mkStringLit   :: String  -> Expr b
+mkStringLitFS :: FAST_STRING  -> Expr b
+mkConApp      :: DataCon -> [Arg b] -> Expr b
+mkPrimApp     :: PrimOp  -> [Arg b] -> Expr b
 
 mkLit lit	  = Con (Literal lit) []
-mkStringLit str	  = Con (Literal (NoRepStr (_PK_ str) stringTy)) []
 mkConApp con args = Con (DataCon con) args
 mkPrimApp op args = Con (PrimOp op)   args
 
+mkStringLit str	= mkStringLitFS (_PK_ str)
+
+mkStringLitFS str
+  | any is_NUL (_UNPK_ str)
+  = 	 -- Must cater for NULs in literal string
+    mkApps (Var unpackCString2Id)
+		[mkLit (MachStr str),
+		 mkLit (mkMachInt (toInteger (_LENGTH_ str)))]
+
+  | otherwise
+  =	-- No NULs in the string
+    App (Var unpackCStringId) (mkLit (MachStr str))
+
+  where
+    is_NUL c = c == '\0'
+
 varToCoreExpr :: CoreBndr -> CoreExpr
 varToCoreExpr v | isId v    = Var v
                 | otherwise = Type (mkTyVarTy v)
@@ -430,6 +454,7 @@ seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
 
 seq_rules [] = ()
 seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
+seq_rules (BuiltinRule _ : rules) = seq_rules rules
 \end{code}
 
 \begin{code}