-- (c) The University of Glasgow, 1997-2006{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples,
 GeneralizedNewtypeDeriving #-}{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}-- We always optimise this, otherwise performance of a non-optimised-- compiler is severely affected-- |-- There are two principal string types used internally by GHC:---- ['FastString']---- * A compact, hash-consed, representation of character strings.-- * Comparison is O(1), and you can get a 'Unique.Unique' from them.-- * Generated by 'fsLit'.-- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'.---- ['PtrString']---- * Pointer and size of a Latin-1 encoded string.-- * Practically no operations.-- * Outputing them is fast.-- * Generated by 'sLit'.-- * Turn into 'Outputable.SDoc' with 'Outputable.ptext'-- * Requires manual memory management.-- Improper use may lead to memory leaks or dangling pointers.-- * It assumes Latin-1 as the encoding, therefore it cannot represent-- arbitrary Unicode strings.---- Use 'PtrString' unless you want the facilities of 'FastString'.moduleFastString(-- * ByteStringbytesFS ,-- :: FastString -> ByteStringfastStringToByteString ,-- = bytesFS (kept for haddock)mkFastStringByteString ,fastZStringToByteString ,unsafeMkByteString ,-- * FastZStringFastZString ,hPutFZS ,zString ,lengthFZS ,-- * FastStringsFastString (..),-- not abstract, for now.-- ** ConstructionfsLit ,mkFastString ,mkFastStringBytes ,mkFastStringByteList ,mkFastStringForeignPtr ,mkFastString# ,-- ** DeconstructionunpackFS ,-- :: FastString -> String-- ** EncodingzEncodeFS ,-- ** OperationsuniqueOfFS ,lengthFS ,nullFS ,appendFS ,headFS ,tailFS ,concatFS ,consFS ,nilFS ,isUnderscoreFS ,-- ** OutputinghPutFS ,-- ** InternalgetFastStringTable ,hasZEncoding ,-- * PtrStringsPtrString (..),-- ** ConstructionsLit ,mkPtrString# ,mkPtrString ,-- ** DeconstructionunpackPtrString ,-- ** OperationslengthPS )where#include "HsVersions.h"
importGhcPrelude asPreludeimportEncoding importFastFunctions importPanic importUtil importControl.Concurrent.MVarimportControl.DeepSeqimportControl.MonadimportData.ByteString(ByteString)importqualifiedData.ByteStringasBSimportqualifiedData.ByteString.Char8asBSCimportqualifiedData.ByteString.InternalasBSimportqualifiedData.ByteString.UnsafeasBSimportForeign.CimportGHC.ExtsimportSystem.IOimportData.DataimportData.IORefimportData.Maybe(isJust)importData.CharimportData.SemigroupasSemiimportGHC.IOimportForeign#if 0
importGHC.Conc.Sync(sharedCAF)#endif
importGHC.Base(unpackCString#,unpackNBytes#)-- | Gives the UTF-8 encoded bytes corresponding to a 'FastString'bytesFS::FastString ->ByteStringbytesFS f =fs_bsf {-# DEPRECATEDfastStringToByteString"Use `bytesFS` instead"#-}fastStringToByteString::FastString ->ByteStringfastStringToByteString =bytesFS fastZStringToByteString::FastZString ->ByteStringfastZStringToByteString (FastZString bs )=bs -- This will drop information if any character > '\xFF'unsafeMkByteString::String->ByteStringunsafeMkByteString =BSC.packhashFastString::FastString ->InthashFastString (FastString __bs _)=inlinePerformIO $BS.unsafeUseAsCStringLenbs $\(ptr ,len )->return$hashStr (castPtrptr )len -- -----------------------------------------------------------------------------newtypeFastZString =FastZString ByteStringderivingNFDatahPutFZS::Handle->FastZString ->IO()hPutFZS handle (FastZString bs )=BS.hPuthandle bs zString::FastZString ->StringzString (FastZString bs )=inlinePerformIO $BS.unsafeUseAsCStringLenbs peekCAStringLenlengthFZS::FastZString ->IntlengthFZS (FastZString bs )=BS.lengthbs mkFastZStringString::String->FastZString mkFastZStringString str =FastZString (BSC.packstr )-- -----------------------------------------------------------------------------{-|
A 'FastString' is an array of bytes, hashed to support fast O(1)
comparison. It is also associated with a character encoding, so that
we know how to convert a 'FastString' to the local encoding, or to the
Z-encoding used by the compiler internally.
'FastString's support a memoized conversion to the Z-encoding via zEncodeFS.
-}dataFastString =FastString {uniq ::{-# UNPACK#-}!Int,-- unique idn_chars ::{-# UNPACK#-}!Int,-- number of charsfs_bs ::{-# UNPACK#-}!ByteString,fs_ref ::{-# UNPACK#-}!(IORef(MaybeFastZString ))}instanceEqFastString wheref1 == f2 =uniqf1 ==uniqf2 instanceOrdFastString where-- Compares lexicographically, not by uniquea <= b =casecmpFS a b of{LT->True;EQ->True;GT->False}a < b =casecmpFS a b of{LT->True;EQ->False;GT->False}a >= b =casecmpFS a b of{LT->False;EQ->True;GT->True}a > b =casecmpFS a b of{LT->False;EQ->False;GT->True}max x y |x >=y =x |otherwise=y min x y |x <=y =x |otherwise=y compare a b =cmpFS a b instanceIsStringFastString wherefromString =fsLit instanceSemi.SemigroupFastString where(<> )=appendFS instanceMonoidFastString wheremempty =nilFS mappend =(Semi.<>)mconcat =concatFS instanceShowFastString whereshow fs =show(unpackFS fs )instanceDataFastString where-- don't traverse?toConstr _=abstractConstr "FastString"gunfold __=error"gunfold"dataTypeOf _=mkNoRepType"FastString"cmpFS::FastString ->FastString ->OrderingcmpFS f1 @(FastString u1 ___)f2 @(FastString u2 ___)=ifu1 ==u2 thenEQelsecompare(bytesFS f1 )(bytesFS f2 )foreignimportccallunsafe"memcmp"memcmp::Ptra ->Ptrb ->Int->IOInt-- ------------------------------------------------------------------------------- Construction{-
Internally, the compiler will maintain a fast string symbol table, providing
sharing and fast comparison. Creation of new @FastString@s then covertly does a
lookup, re-using the @FastString@ if there was a hit.
The design of the FastString hash table allows for lockless concurrent reads
and updates to multiple buckets with low synchronization overhead.
See Note [Updating the FastString table] on how it's updated.
-}dataFastStringTable =FastStringTable {-# UNPACK#-}!(IORefInt)-- the unique ID counter shared with all buckets(Array#(IORefFastStringTableSegment ))-- concurrent segmentsdataFastStringTableSegment =FastStringTableSegment {-# UNPACK#-}!(MVar())-- the lock for write in each segment{-# UNPACK#-}!(IORefInt)-- the number of elements(MutableArray#RealWorld[FastString ])-- buckets in this segment{-
Following parameters are determined based on:
* Benchmark based on testsuite/tests/utils/should_run/T14854.hs
* Stats of @echo :browse | ghc --interactive -dfaststring-stats >/dev/null@:
 on 2018年10月24日, we have 13920 entries.
-}segmentBits,numSegments,segmentMask,initialNumBuckets::IntsegmentBits =8numSegments =256-- bit segmentBitssegmentMask =0xff-- bit segmentBits - 1initialNumBuckets =64hashToSegment#::Int#->Int#hashToSegment# hash# =hash# `andI#`segmentMask# where!(I#segmentMask# )=segmentMask hashToIndex#::MutableArray#RealWorld[FastString ]->Int#->Int#hashToIndex# buckets# hash# =(hash# `uncheckedIShiftRL#`segmentBits# )`remInt#`size# where!(I#segmentBits# )=segmentBits size# =sizeofMutableArray#buckets# maybeResizeSegment::IORefFastStringTableSegment ->IOFastStringTableSegment maybeResizeSegment segmentRef =dosegment @(FastStringTableSegment lock counter old# )<-readIORefsegmentRef letoldSize# =sizeofMutableArray#old# newSize# =oldSize# *#2#(I#n# )<-readIORefcounter ifisTrue#(n# <#newSize# )-- maximum load of 1thenreturnsegment elsedoresizedSegment @(FastStringTableSegment __new# )<-IO$\s1# ->casenewArray#newSize# []s1# of(#s2# ,arr# #)->(#s2# ,FastStringTableSegment lock counter arr# #)forM_[0..(I#oldSize# )-1]$\(I#i# )->dofsList <-IO$readArray#old# i# forM_fsList $\fs ->dolet-- Shall we store in hash value in FastString instead?!(I#hash# )=hashFastString fs idx# =hashToIndex# new# hash# IO$\s1# ->casereadArray#new# idx# s1# of(#s2# ,bucket #)->casewriteArray#new# idx# (fs :bucket )s2# ofs3# ->(#s3# ,()#)writeIORefsegmentRef resizedSegment returnresizedSegment {-# NOINLINEstringTable#-}stringTable::FastStringTable stringTable =unsafePerformIO$dolet!(I#numSegments# )=numSegments !(I#initialNumBuckets# )=initialNumBuckets loop a# i# s1# |isTrue#(i# ==#numSegments# )=s1# |otherwise=casenewMVar()`unIO`s1# of(#s2# ,lock #)->casenewIORef0`unIO`s2# of(#s3# ,counter #)->casenewArray#initialNumBuckets# []s3# of(#s4# ,buckets# #)->casenewIORef(FastStringTableSegment lock counter buckets# )`unIO`s4# of(#s5# ,segment #)->casewriteArray#a# i# segment s5# ofs6# ->loop a# (i# +#1#)s6# uid <-newIORef603979776-- ord '$' * 0x01000000tab <-IO$\s1# ->casenewArray#numSegments# (panic "string_table")s1# of(#s2# ,arr# #)->caseloop arr# 0#s2# ofs3# ->caseunsafeFreezeArray#arr# s3# of(#s4# ,segments# #)->(#s4# ,FastStringTable uid segments# #)-- use the support wired into the RTS to share this CAF among all images of-- libHSghc#if 1
returntab #else
sharedCAFtabgetOrSetLibHSghcFastStringTable-- from the RTS; thus we cannot use this mechanism when STAGE<2; the previous-- RTS might not have this symbolforeignimportccallunsafe"getOrSetLibHSghcFastStringTable"getOrSetLibHSghcFastStringTable::Ptra->IO(Ptra)#endif
{-
We include the FastString table in the `sharedCAF` mechanism because we'd like
FastStrings created by a Core plugin to have the same uniques as corresponding
strings created by the host compiler itself. For example, this allows plugins
to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or
even re-invoke the parser.
In particular, the following little sanity test was failing in a plugin
prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not
be looked up /by the plugin/.
 let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT"
 putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts
`mkTcOcc` involves the lookup (or creation) of a FastString. Since the
plugin's FastString.string_table is empty, constructing the RdrName also
allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These
uniques are almost certainly unequal to the ones that the host compiler
originally assigned to those FastStrings. Thus the lookup fails since the
domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's
unique.
Maintaining synchronization of the two instances of this global is rather
difficult because of the uses of `unsafePerformIO` in this module. Not
synchronizing them risks breaking the rather major invariant that two
FastStrings with the same unique have the same string. Thus we use the
lower-level `sharedCAF` mechanism that relies on Globals.c.
-}mkFastString#::Addr#->FastString mkFastString# a# =mkFastStringBytes ptr (ptrStrLength ptr )whereptr =Ptra# {- Note [Updating the FastString table]
We use a concurrent hashtable which contains multiple segments, each hash value
always maps to the same segment. Read is lock-free, write to the a segment
should acquire a lock for that segment to avoid race condition, writes to
different segments are independent.
The procedure goes like this:
1. Find out which segment to operate on based on the hash value
2. Read the relevant bucket and perform a look up of the string.
3. If it exists, return it.
4. Otherwise grab a unique ID, create a new FastString and atomically attempt
 to update the relevant segment with this FastString:
 * Resize the segment by doubling the number of buckets when the number of
 FastStrings in this segment grows beyond the threshold.
 * Double check that the string is not in the bucket. Another thread may have
 inserted it while we were creating our string.
 * Return the existing FastString if it exists. The one we preemptively
 created will get GCed.
 * Otherwise, insert and return the string we created.
-}mkFastStringWith::(Int->IOFastString )->PtrWord8->Int->IOFastString mkFastStringWith mk_fs !ptr !len =doFastStringTableSegment lock _buckets# <-readIORefsegmentRef letidx# =hashToIndex# buckets# hash# bucket <-IO$readArray#buckets# idx# res <-bucket_match bucket len ptr caseres ofJustfound ->returnfound Nothing->do-- The withMVar below is not dupable. It can lead to deadlock if it is-- only run partially and putMVar is not called after takeMVar.noDuplicaten <-get_uid new_fs <-mk_fs n withMVarlock $\_->insert new_fs where!(FastStringTable uid segments# )=stringTable get_uid =atomicModifyIORef'uid $\n ->(n +1,n )!(I#hash# )=hashStr ptr len (#segmentRef #)=indexArray#segments# (hashToSegment# hash# )insert fs =doFastStringTableSegment _counter buckets# <-maybeResizeSegment segmentRef letidx# =hashToIndex# buckets# hash# bucket <-IO$readArray#buckets# idx# res <-bucket_match bucket len ptr caseres of-- The FastString was added by another thread after previous read and-- before we acquired the write lock.Justfound ->returnfound Nothing->doIO$\s1# ->casewriteArray#buckets# idx# (fs :bucket )s1# ofs2# ->(#s2# ,()#)modifyIORef'counter succreturnfs bucket_match::[FastString ]->Int->PtrWord8->IO(MaybeFastString )bucket_match []__=returnNothingbucket_match(v @(FastString __bs _):ls )len ptr |len ==BS.lengthbs =dob <-BS.unsafeUseAsCStringbs $\buf ->cmpStringPrefix ptr (castPtrbuf )len ifb thenreturn(Justv )elsebucket_match ls len ptr |otherwise=bucket_match ls len ptr mkFastStringBytes::PtrWord8->Int->FastString mkFastStringBytes !ptr !len =-- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is-- idempotent.unsafeDupablePerformIO$mkFastStringWith (copyNewFastString ptr len )ptr len -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference-- between this and 'mkFastStringBytes' is that we don't have to copy-- the bytes if the string is new to the table.mkFastStringForeignPtr::PtrWord8->ForeignPtrWord8->Int->IOFastString mkFastStringForeignPtr ptr !fp len =mkFastStringWith (mkNewFastString fp ptr len )ptr len -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference-- between this and 'mkFastStringBytes' is that we don't have to copy-- the bytes if the string is new to the table.mkFastStringByteString::ByteString->FastString mkFastStringByteString bs =inlinePerformIO $BS.unsafeUseAsCStringLenbs $\(ptr ,len )->doletptr' =castPtrptr mkFastStringWith (mkNewFastStringByteString bs ptr' len )ptr' len -- | Creates a UTF-8 encoded 'FastString' from a 'String'mkFastString::String->FastString mkFastString str =inlinePerformIO $doletl =utf8EncodedLength str buf <-mallocForeignPtrBytesl withForeignPtrbuf $\ptr ->doutf8EncodeString ptr str mkFastStringForeignPtr ptr buf l -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@mkFastStringByteList::[Word8]->FastString mkFastStringByteList str =mkFastStringByteString (BS.packstr )-- | Creates a Z-encoded 'FastString' from a 'String'mkZFastString::String->FastZString mkZFastString =mkFastZStringString mkNewFastString::ForeignPtrWord8->PtrWord8->Int->Int->IOFastString mkNewFastString fp ptr len uid =doref <-newIORefNothingn_chars <-countUTF8Chars ptr len return(FastString uid n_chars (BS.fromForeignPtrfp 0len )ref )mkNewFastStringByteString::ByteString->PtrWord8->Int->Int->IOFastString mkNewFastStringByteString bs ptr len uid =doref <-newIORefNothingn_chars <-countUTF8Chars ptr len return(FastString uid n_chars bs ref )copyNewFastString::PtrWord8->Int->Int->IOFastString copyNewFastString ptr len uid =dofp <-copyBytesToForeignPtr ptr len ref <-newIORefNothingn_chars <-countUTF8Chars ptr len return(FastString uid n_chars (BS.fromForeignPtrfp 0len )ref )copyBytesToForeignPtr::PtrWord8->Int->IO(ForeignPtrWord8)copyBytesToForeignPtr ptr len =dofp <-mallocForeignPtrByteslen withForeignPtrfp $\ptr' ->copyBytesptr' ptr len returnfp cmpStringPrefix::PtrWord8->PtrWord8->Int->IOBoolcmpStringPrefix ptr1 ptr2 len =dor <-memcmp ptr1 ptr2 len return(r ==0)hashStr::PtrWord8->Int->Int-- use the Addr to produce a hash value between 0 & m (inclusive)hashStr (Ptra# )(I#len# )=loop 0#0#whereloop h n |isTrue#(n ==#len# )=I#h |otherwise=loop h2 (n +#1#)where!c =ord#(indexCharOffAddr#a# n )!h2 =(h *#16777619#)`xorI#`c -- ------------------------------------------------------------------------------- Operations-- | Returns the length of the 'FastString' in characterslengthFS::FastString ->IntlengthFS f =n_charsf -- | Returns @True@ if this 'FastString' is not Z-encoded but already has-- a Z-encoding cached (used in producing stats).hasZEncoding::FastString ->BoolhasZEncoding (FastString ___ref )=inlinePerformIO $dom <-readIORefref return(isJustm )-- | Returns @True@ if the 'FastString' is emptynullFS::FastString ->BoolnullFS f =BS.null(fs_bsf )-- | Unpacks and decodes the FastStringunpackFS::FastString ->StringunpackFS (FastString __bs _)=utf8DecodeByteString bs -- | Returns a Z-encoded version of a 'FastString'. This might be the-- original, if it was already Z-encoded. The first time this-- function is applied to a particular 'FastString', the results are-- memoized.--zEncodeFS::FastString ->FastZString zEncodeFS fs @(FastString ___ref )=inlinePerformIO $dom <-readIORefref casem ofJustzfs ->returnzfs Nothing->doatomicModifyIORef'ref $\m' ->casem' ofNothing->letzfs =mkZFastString (zEncodeString (unpackFS fs ))in(Justzfs ,zfs )Justzfs ->(m' ,zfs )appendFS::FastString ->FastString ->FastString appendFS fs1 fs2 =mkFastStringByteString $BS.append(bytesFS fs1 )(bytesFS fs2 )concatFS::[FastString ]->FastString concatFS =mkFastStringByteString .BS.concat.mapfs_bsheadFS::FastString ->CharheadFS (FastString _0__)=panic "headFS: Empty FastString"headFS(FastString __bs _)=inlinePerformIO $BS.unsafeUseAsCStringbs $\ptr ->return(fst(utf8DecodeChar (castPtrptr )))tailFS::FastString ->FastString tailFS (FastString _0__)=panic "tailFS: Empty FastString"tailFS(FastString __bs _)=inlinePerformIO $BS.unsafeUseAsCStringbs $\ptr ->dolet(_,n )=utf8DecodeChar (castPtrptr )return$!mkFastStringByteString (BS.dropn bs )consFS::Char->FastString ->FastString consFS c fs =mkFastString (c :unpackFS fs )uniqueOfFS::FastString ->IntuniqueOfFS (FastString u ___)=u nilFS::FastString nilFS =mkFastString ""isUnderscoreFS::FastString ->BoolisUnderscoreFS fs =fs ==fsLit "_"-- ------------------------------------------------------------------------------- StatsgetFastStringTable::IO[[[FastString ]]]getFastStringTable =forM[0..numSegments -1]$\(I#i# )->dolet(#segmentRef #)=indexArray#segments# i# FastStringTableSegment __buckets# <-readIORefsegmentRef letbucketSize =I#(sizeofMutableArray#buckets# )forM[0..bucketSize -1]$\(I#j# )->IO$readArray#buckets# j# where!(FastStringTable _segments# )=stringTable -- ------------------------------------------------------------------------------- Outputting 'FastString's-- |Outputs a 'FastString' with /no decoding at all/, that is, you-- get the actual bytes in the 'FastString' written to the 'Handle'.hPutFS::Handle->FastString ->IO()hPutFS handle fs =BS.hPuthandle $bytesFS fs -- ToDo: we'll probably want an hPutFSLocal, or something, to output-- in the current locale's encoding (for error messages and suchlike).-- ------------------------------------------------------------------------------- PtrStrings, here for convenience only.-- | A 'PtrString' is a pointer to some array of Latin-1 encoded chars.dataPtrString =PtrString !(PtrWord8)!Int-- | Wrap an unboxed address into a 'PtrString'.mkPtrString#::Addr#->PtrString mkPtrString# a# =PtrString (Ptra# )(ptrStrLength (Ptra# ))-- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1-- encoding. The original string must not contain non-Latin-1 characters-- (above codepoint @0xff@).{-# INLINEmkPtrString#-}mkPtrString::String->PtrString mkPtrString s =-- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks-- and because someone might be using `eqAddr#` to check for string equality.unsafePerformIO(doletlen =lengths p <-mallocByteslen letloop::Int->String->IO()loop !_[]=return()loopn (c :cs )=dopokeByteOffp n (fromIntegral(ordc )::Word8)loop (1+n )cs loop 0s return(PtrString p len ))-- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding.-- This does not free the memory associated with 'PtrString'.unpackPtrString::PtrString ->StringunpackPtrString (PtrString (Ptrp# )(I#n# ))=unpackNBytes#p# n# -- | Return the length of a 'PtrString'lengthPS::PtrString ->IntlengthPS (PtrString _n )=n -- ------------------------------------------------------------------------------- under the carpetforeignimportccallunsafe"strlen"ptrStrLength::PtrWord8->Int{-# NOINLINEsLit#-}sLit::String->PtrString sLit x =mkPtrString x {-# NOINLINEfsLit#-}fsLit::String->FastString fsLit x =mkFastString x {-# RULES"slit"forallx.sLit(unpackCString#x)=mkPtrString#x#-}{-# RULES"fslit"forallx.fsLit(unpackCString#x)=mkFastString#x#-}