Commit 4b172698 authored by qrczak's avatar qrczak

[project @ 2000-08-07 23:37:19 by qrczak]

Now Char, Char#, StgChar have 31 bits (physically 32).
"foo"# is still an array of bytes.

CharRep represents 32 bits (on a 64-bit arch too). There is also
Int8Rep, used in those places where bytes were originally meant.
readCharArray, indexCharOffAddr etc. still use bytes. Storable and
{I,M}Array use wide Chars.

In future perhaps all sized integers should be primitive types. Then
some usages of indexing primops scattered through the code could
be changed to then-available Int8 ones, and then Char variants of
primops could be made wide (other usages that handle text should use
conversion that will be provided later).

I/O and _ccall_ arguments assume ISO-8859-1. UTF-8 is internally used
for string literals (only).

Z-encoding is ready for Unicode identifiers.

Ranges of intlike and charlike closures are more easily configurable.

I've probably broken nativeGen/MachCode.lhs:chrCode for Alpha but I
don't know the Alpha assembler to fix it (what is zapnot?). Generally
I'm not sure if I've done the NCG changes right.

This commit breaks the binary compatibility (of course).

TODO:
* is* and to{Lower,Upper} in Char (in progress).
* Libraries for text conversion (in design / experiments),
  to be plugged to I/O and a higher level foreign library.
* PackedString.
* StringBuffer and accepting source in encodings other than ISO-8859-1.
parent 514da0a6
......@@ -155,13 +155,17 @@ import qualified FastString
# define _NIL_ (FastString.mkFastString "")
# define _CONS_ FastString.consFS
# define _HEAD_ FastString.headFS
# define _HEAD_INT_ FastString.headIntFS
# define _TAIL_ FastString.tailFS
# define _LENGTH_ FastString.lengthFS
# define _PK_ FastString.mkFastString
# define _PK_INT_ FastString.mkFastStringInt
# define _UNPK_ FastString.unpackFS
# define _UNPK_INT_ FastString.unpackIntFS
# define _APPEND_ `FastString.appendFS`
# define _CONCAT_ FastString.concatFS
#else
# error I think that FastString is now always used. If not, fix this.
# define FAST_STRING String
# define SLIT(x) (x)
# define _CMP_STRING_ cmpString
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: AbsCSyn.lhs,v 1.32 2000/08/02 14:13:26 rrt Exp $
% $Id: AbsCSyn.lhs,v 1.33 2000/08/07 23:37:19 qrczak Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
......@@ -315,7 +315,7 @@ data CAddrMode
| CCharLike CAddrMode -- The address of a static char-like closure for
-- the specified character. It is guaranteed to be in
-- the range 0..255.
-- the range mIN_CHARLIKE..mAX_CHARLIKE
| CIntLike CAddrMode -- The address of a static int-like closure for the
-- specified small integer. It is guaranteed to be in
......
......@@ -6,8 +6,7 @@ module CStrings(
cSEP, pp_cSEP,
stringToC, charToC, pprFSInCStyle, pprStringInCStyle,
charToEasyHaskell
pprFSInCStyle, pprStringInCStyle
) where
#include "HsVersions.h"
......@@ -36,64 +35,20 @@ pp_cSEP = char '_'
\begin{code}
pprFSInCStyle :: FAST_STRING -> SDoc
pprFSInCStyle fs = doubleQuotes (text (stringToC (_UNPK_ fs)))
-- Assumes it contains only characters '\0'..'\xFF'!
pprFSInCStyle fs = pprStringInCStyle (_UNPK_ fs)
pprStringInCStyle :: String -> SDoc
pprStringInCStyle s = doubleQuotes (text (stringToC s))
stringToC :: String -> String
-- Convert a string to the form required by C in a C literal string
-- Tthe hassle is what to do w/ strings like "ESC 0"...
stringToC "" = ""
stringToC [c] = charToC c
stringToC (c:cs)
-- if we have something "octifiable" in "c", we'd better "octify"
-- the rest of the string, too.
= if (c < ' ' || c > '~')
then (charToC c) ++ (concat (map char_to_C cs))
else (charToC c) ++ (stringToC cs)
where
char_to_C c | c == '\n' = "\\n" -- use C escapes when we can
| c == '\a' = "\\a"
| c == '\b' = "\\b" -- ToDo: chk some of these...
| c == '\r' = "\\r"
| c == '\t' = "\\t"
| c == '\f' = "\\f"
| c == '\v' = "\\v"
| otherwise = '\\' : (octify (ord c))
pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
charToC :: Char -> String
-- Convert a character to the form reqd in a C character literal
charToC c = if (c >= ' ' && c <= '~') -- non-portable...
then case c of
'\'' -> "\\'"
'\\' -> "\\\\"
'"' -> "\\\""
'\n' -> "\\n"
'\a' -> "\\a"
'\b' -> "\\b"
'\r' -> "\\r"
'\t' -> "\\t"
'\f' -> "\\f"
'\v' -> "\\v"
_ -> [c]
else '\\' : (octify (ord c))
charToEasyHaskell :: Char -> String
-- Convert a character to the form reqd in a Haskell character literal
charToEasyHaskell c
= if (c >= 'a' && c <= 'z')
|| (c >= 'A' && c <= 'Z')
|| (c >= '0' && c <= '9')
then [c]
else case c of
_ -> '\\' : show (ord c)
octify :: Int -> String
octify n
= if n < 8 then
[chr (n + ord '0')]
else
octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
charToC '\"' = "\\\""
charToC '\'' = "\\\'"
charToC '\\' = "\\\\"
charToC c | c >= ' ' && c <= '~' = [c]
| c > '\xFF' = panic ("charToC "++show c)
| otherwise = ['\\',
chr (ord '0' + ord c `div` 64),
chr (ord '0' + ord c `div` 8 `mod` 8),
chr (ord '0' + ord c `mod` 8)]
\end{code}
......@@ -38,7 +38,7 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
import CStrings ( stringToC, pprCLabelString )
import CStrings ( pprStringInCStyle, pprCLabelString )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
import Literal ( Literal(..) )
import TyCon ( tyConDataCons )
......@@ -498,8 +498,8 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _
type_str = pprSMRep (closureSMRep cl_info)
pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
pp_descr = pprStringInCStyle cl_descr
pp_type = pprStringInCStyle (closureTypeDescr cl_info)
pprAbsC stmt@(CClosureTbl tycon) _
= vcat (
......@@ -1289,6 +1289,7 @@ pprUnionTag RetRep = char 'p'
pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
pprUnionTag CharRep = char 'c'
pprUnionTag Int8Rep = ptext SLIT("i8")
pprUnionTag IntRep = char 'i'
pprUnionTag WordRep = char 'w'
pprUnionTag AddrRep = char 'a'
......@@ -1534,9 +1535,8 @@ ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
-- CIntLike must be a literal -- no decls
ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
-- CCharLike may have be arbitrary value -- may have decls
ppr_decls_Amode (CCharLike char)
= ppr_decls_Amode char
-- CCharLike too
ppr_decls_Amode (CCharLike char) = returnTE (Nothing, Nothing)
-- now, the only place where we actually print temps/externs...
ppr_decls_Amode (CTemp uniq kind)
......
......@@ -27,7 +27,7 @@ import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
import PrimRep ( PrimRep(..) )
import Type ( Type, typePrimRep )
import PprType ( pprParendType )
import CStrings ( charToC, charToEasyHaskell, pprFSInCStyle )
import CStrings ( pprFSInCStyle )
import Outputable
import Util ( thenCmp )
......@@ -85,7 +85,7 @@ function applications, etc., etc., has not yet been done.
data Literal
= ------------------
-- First the primitive guys
MachChar Char
MachChar Int -- Char# At least 31 bits
| MachStr FAST_STRING
| MachAddr Integer -- Whatever this machine thinks is a "pointer"
......@@ -159,8 +159,8 @@ int2WordLit (MachInt i)
| i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD
| otherwise = MachWord i
char2IntLit (MachChar c) = MachInt (toInteger (ord c))
int2CharLit (MachInt i) = MachChar (chr (fromInteger i))
char2IntLit (MachChar c) = MachInt (toInteger c)
int2CharLit (MachInt i) = MachChar (fromInteger i)
float2IntLit (MachFloat f) = MachInt (truncate f)
int2FloatLit (MachInt i) = MachFloat (fromInteger i)
......@@ -268,13 +268,13 @@ pprLit lit
iface_style = ifaceStyle sty
in
case lit of
MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), char '\'',
text (charToC ch), char '\'']
| iface_style -> char '\'' <> text (charToEasyHaskell ch) <> char '\''
| otherwise -> text ['\'', ch, '\'']
MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), text (show ch)]
| otherwise -> pprHsChar ch
MachStr s | code_style -> pprFSInCStyle s
| otherwise -> pprFSAsString s
| otherwise -> pprHsString s
-- Warning: printing MachStr in code_style assumes it contains
-- only characters '\0'..'\xFF'!
MachInt i | code_style && i == tARGET_MIN_INT -> parens (integer (i+1) <> text "-1")
-- Avoid a problem whereby gcc interprets
......@@ -300,11 +300,11 @@ pprLit lit
| otherwise -> ptext SLIT("__addr") <+> integer p
MachLabel l | code_style -> ptext SLIT("(&") <> ptext l <> char ')'
| otherwise -> ptext SLIT("__label") <+> pprFSAsString l
| otherwise -> ptext SLIT("__label") <+> pprHsString l
MachLitLit s ty | code_style -> ptext s
| otherwise -> parens (hsep [ptext SLIT("__litlit"),
pprFSAsString s,
pprHsString s,
pprParendType ty])
pprIntVal :: Integer -> SDoc
......@@ -337,7 +337,7 @@ Hash values should be zero or a positive integer. No negatives please.
\begin{code}
hashLiteral :: Literal -> Int
hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints
hashLiteral (MachChar c) = c + 1000 -- Keep it out of range of common ints
hashLiteral (MachStr s) = hashFS s
hashLiteral (MachAddr i) = hashInteger i
hashLiteral (MachInt i) = hashInteger i
......
......@@ -92,6 +92,8 @@ import Unique
import Maybe ( isJust )
import Outputable
import Util ( assoc )
import UnicodeUtil ( stringToUtf8 )
import Char ( ord )
\end{code}
......@@ -371,7 +373,7 @@ Similarly for newtypes
unN = /\a -> \n:N -> coerce (a->a) n
\begin{code}
mkRecordSelId tycon field_label unpack_id
mkRecordSelId tycon field_label unpack_id unpackUtf8_id
-- Assumes that all fields with the same field label have the same type
--
-- Annoyingly, we have to pass in the unpackCString# Id, because
......@@ -442,7 +444,16 @@ mkRecordSelId tycon field_label unpack_id
error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), err_string]
-- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04.
err_string = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
err_string
| all safeChar full_msg
= App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
| otherwise
= App (Var unpackUtf8_id) (Lit (MachStr (_PK_ (stringToUtf8 (map ord full_msg)))))
where
safeChar c = c >= '\1' && c <= '\xFF'
-- TODO: Putting this Unicode stuff here is ugly. Find a better
-- generic place to make string literals. This logic is repeated
-- in DsUtils.
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
\end{code}
......
......@@ -39,7 +39,7 @@ module OccName (
#include "HsVersions.h"
import Char ( isDigit, isAlpha, isUpper, isLower, ISALPHANUM, ord, chr, digitToInt, intToDigit )
import Char ( isDigit, isAlpha, isUpper, isLower, ISALPHANUM, ord, chr, digitToInt )
import Util ( thenCmp )
import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM )
import Outputable
......@@ -438,8 +438,8 @@ The basic encoding scheme is this.
* Most other printable characters translate to 'zx' or 'Zx' for some
alphabetic character x
* The others translate as 'zxdd' where 'dd' is exactly two hexadecimal
digits for the ord of the character
* The others translate as 'znnnU' where 'nnn' is the decimal number
of the character
Before After
--------------------------
......@@ -532,9 +532,7 @@ encode_ch '/' = "zs"
encode_ch '*' = "zt"
encode_ch '_' = "zu"
encode_ch '%' = "zv"
encode_ch c = ['z', 'x', intToDigit hi, intToDigit lo]
where
(hi,lo) = ord c `quotRem` 16
encode_ch c = 'z' : shows (ord c) "U"
\end{code}
Decode is used for user printing.
......@@ -577,14 +575,15 @@ decode_escape ('s' : rest) = '/' : decode rest
decode_escape ('t' : rest) = '*' : decode rest
decode_escape ('u' : rest) = '_' : decode rest
decode_escape ('v' : rest) = '%' : decode rest
decode_escape ('x' : d1 : d2 : rest) = chr (digitToInt d1 * 16 + digitToInt d2) : decode rest
-- Tuples are coded as Z23T
-- Characters not having a specific code are coded as z224U
decode_escape (c : rest)
| isDigit c = go (digitToInt c) rest
where
go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest
go n ('T' : rest) = '(' : replicate n ',' ++ ')' : decode rest
go n ('U' : rest) = chr n : decode rest
go n other = pprPanic "decode_escape" (ppr n <+> text (c:rest))
decode_escape (c : rest) = pprTrace "decode_escape" (char c) (decode rest)
......
......@@ -177,7 +177,7 @@ module Unique (
trueDataConKey,
unboundKey,
unboxedConKey,
unpackCString2IdKey,
unpackCStringUtf8IdKey,
unpackCStringAppendIdKey,
unpackCStringFoldrIdKey,
unpackCStringIdKey,
......@@ -630,7 +630,7 @@ realWorldPrimIdKey = mkPreludeMiscIdUnique 23
recConErrorIdKey = mkPreludeMiscIdUnique 24
recUpdErrorIdKey = mkPreludeMiscIdUnique 25
traceIdKey = mkPreludeMiscIdUnique 26
unpackCString2IdKey = mkPreludeMiscIdUnique 27
unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 27
unpackCStringAppendIdKey = mkPreludeMiscIdUnique 28
unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 29
unpackCStringIdKey = mkPreludeMiscIdUnique 30
......
......@@ -33,7 +33,8 @@ import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp,
getSpRelOffset )
import CgClosure ( cgTopRhsClosure )
import CgRetConv ( assignRegs )
import Constants ( mAX_INTLIKE, mIN_INTLIKE, mIN_UPD_SIZE )
import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE,
mIN_UPD_SIZE )
import CgHeapery ( allocDynClosure, inPlaceAllocDynClosure )
import CgTailCall ( performReturn, mkStaticAlgReturnCode, doTailCall,
mkUnboxedTupleReturnCode )
......@@ -143,6 +144,12 @@ buildDynCon binder cc con []
(mkConLFInfo con))
\end{code}
The following three paragraphs about @Char@-like and @Int@-like
closures are obsolete, but I don't understand the details well enough
to properly word them, sorry. I've changed the treatment of @Char@s to
be analogous to @Int@s: only a subset is preallocated, because @Char@
has now 31 bits. Only literals are handled here. -- Qrczak
Now for @Char@-like closures. We generate an assignment of the
address of the closure to a temporary. It would be possible simply to
generate no code, and record the addressing mode in the environment,
......@@ -160,18 +167,22 @@ Because of this, we use can safely return an addressing mode.
\begin{code}
buildDynCon binder cc con [arg_amode]
| maybeCharLikeCon con
= absC (CAssign temp_amode (CCharLike arg_amode)) `thenC`
returnFC temp_id_info
| maybeIntLikeCon con && in_range_int_lit arg_amode
= returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
where
(temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
in_range_int_lit (CLit (MachInt val)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
in_range_int_lit other_amode = False
in_range_int_lit _other_amode = False
buildDynCon binder cc con [arg_amode]
| maybeCharLikeCon con && in_range_char_lit arg_amode
= returnFC (stableAmodeIdInfo binder (CCharLike arg_amode) (mkConLFInfo con))
where
(temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
in_range_char_lit (CLit (MachChar val)) = val <= mAX_CHARLIKE && val >= mIN_CHARLIKE
in_range_char_lit _other_amode = False
\end{code}
Now the general case.
......@@ -296,7 +307,6 @@ cgReturnDataCon con amodes
-- do update in place...
UpdateCode
| not (isNullaryDataCon con) -- no nullary constructors, please
&& not (maybeCharLikeCon con) -- no chars please (these are all static)
&& not (any isFollowableRep (map getAmodeRep amodes))
-- no ptrs please (generational gc...)
&& closureSize closure_info <= mIN_UPD_SIZE
......
%
% (c) The GRASP Project, Glasgow University, 1992-1998
%
% $Id: CgRetConv.lhs,v 1.23 2000/07/11 16:03:37 simonmar Exp $
% $Id: CgRetConv.lhs,v 1.24 2000/08/07 23:37:20 qrczak Exp $
%
\section[CgRetConv]{Return conventions for the code generator}
......@@ -81,6 +81,7 @@ dataReturnConvPrim Int64Rep = LongReg Int64Rep ILIT(1)
dataReturnConvPrim Word64Rep = LongReg Word64Rep ILIT(1)
dataReturnConvPrim AddrRep = VanillaReg AddrRep ILIT(1)
dataReturnConvPrim CharRep = VanillaReg CharRep ILIT(1)
dataReturnConvPrim Int8Rep = VanillaReg Int8Rep ILIT(1)
dataReturnConvPrim FloatRep = FloatReg ILIT(1)
dataReturnConvPrim DoubleRep = DoubleReg ILIT(1)
dataReturnConvPrim VoidRep = VoidReg
......
......@@ -148,7 +148,7 @@ dsExpr (HsLitOut (HsString s) _)
| _LENGTH_ s == 1
= let
the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_ s))]
the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_INT_ s))]
the_nil = mkNilExpr charTy
the_cons = mkConsExpr charTy the_char the_nil
in
......
......@@ -70,8 +70,9 @@ import TysWiredIn ( nilDataCon, consDataCon,
)
import BasicTypes ( Boxity(..) )
import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
import Unique ( unpackCStringIdKey, unpackCString2IdKey )
import Unique ( unpackCStringIdKey, unpackCStringUtf8IdKey )
import Outputable
import UnicodeUtil ( stringToUtf8 )
\end{code}
......@@ -123,7 +124,7 @@ tidyLitPat lit lit_ty default_pat
mk_list (HsString s) = foldr
(\c pat -> ConPat consDataCon lit_ty [] [] [mk_char_lit c,pat])
(ConPat nilDataCon lit_ty [] [] []) (_UNPK_ s)
(ConPat nilDataCon lit_ty [] [] []) (_UNPK_INT_ s)
mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
\end{code}
......@@ -390,20 +391,19 @@ mkStringLit str = mkStringLitFS (_PK_ str)
mkStringLitFS :: FAST_STRING -> DsM CoreExpr
mkStringLitFS str
| any is_NUL (_UNPK_ str)
= -- Must cater for NULs in literal string
dsLookupGlobalValue unpackCString2IdKey `thenDs` \ unpack_id ->
returnDs (mkApps (Var unpack_id)
[Lit (MachStr str),
mkIntLitInt (_LENGTH_ str)])
| otherwise
= -- No NULs in the string
| all safeChar chars
=
dsLookupGlobalValue unpackCStringIdKey `thenDs` \ unpack_id ->
returnDs (App (Var unpack_id) (Lit (MachStr str)))
| otherwise
=
dsLookupGlobalValue unpackCStringUtf8IdKey `thenDs` \ unpack_id ->
returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
where
is_NUL c = c == '\0'
chars = _UNPK_INT_ str
safeChar c = c >= 1 && c <= 0xFF
\end{code}
%************************************************************************
......
......@@ -21,8 +21,8 @@ import Ratio ( Rational )
\begin{code}
data HsLit
= HsChar Char -- characters
| HsCharPrim Char -- unboxed char literals
= HsChar Int -- characters
| HsCharPrim Int -- unboxed char literals
| HsString FAST_STRING -- strings
| HsStringPrim FAST_STRING -- packed string
......@@ -57,10 +57,10 @@ negLiteral (HsFrac f) = HsFrac (-f)
\begin{code}
instance Outputable HsLit where
-- Use "show" because it puts in appropriate escapes
ppr (HsChar c) = text (show c)
ppr (HsCharPrim c) = text (show c) <> char '#'
ppr (HsStringPrim s) = pprFSAsString s <> char '#'
ppr (HsString s) = pprFSAsString s
ppr (HsChar c) = pprHsChar c
ppr (HsCharPrim c) = pprHsChar c <> char '#'
ppr (HsString s) = pprHsString s
ppr (HsStringPrim s) = pprHsString s <> char '#'
ppr (HsInt i) = integer i
ppr (HsFrac f) = rational f
ppr (HsFloatPrim f) = rational f <> char '#'
......
......@@ -190,7 +190,7 @@ pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc
pprUfExpr add_par (UfVar v) = ppr v
pprUfExpr add_par (UfLit l) = ppr l
pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprFSAsString l, pprParendHsType ty])
pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
......@@ -238,7 +238,7 @@ instance Outputable name => Outputable (UfNote name) where
instance Outputable name => Outputable (UfConAlt name) where
ppr UfDefault = text "__DEFAULT"
ppr (UfLitAlt l) = ppr l
ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprFSAsString l, pprParendHsType ty])
ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
ppr (UfDataAlt d) = ppr d
instance Outputable name => Outputable (UfBinder name) where
......
......@@ -131,7 +131,7 @@ instance Ord Name where
data Lit
= IntLit Integer -- unboxed
| CharLit Char -- unboxed
| CharLit Int -- unboxed
| StringLit String -- java string
deriving Show
......
......@@ -605,6 +605,7 @@ suffix _ = ""
primName :: PrimType -> String
primName PrimInt = "int"
primName PrimChar = "char"
primName PrimByte = "byte"
primName PrimBoolean = "boolean"
primName _ = error "unsupported primitive"
......@@ -803,6 +804,9 @@ inttype = PrimType PrimInt
chartype :: Type
chartype = PrimType PrimChar
bytetype :: Type
bytetype = PrimType PrimByte
-- This lets you get inside a possible "Value" type,
-- to access the internal unboxed object.
access :: Expr -> Type -> Expr
......@@ -811,6 +815,7 @@ access expr other = expr
accessPrim expr PrimInt = Call expr (Name "intValue" inttype) []
accessPrim expr PrimChar = Call expr (Name "charValue" chartype) []
accessPrim expr PrimByte = Call expr (Name "byteValue" bytetype) []
accessPrim expr other = pprPanic "accessPrim" (text (show other))
-- This is where we map from typename to types,
......@@ -831,6 +836,7 @@ primRepToType ::PrimRep -> Type
primRepToType PtrRep = objectType
primRepToType IntRep = inttype
primRepToType CharRep = chartype
primRepToType Int8Rep = bytetype
primRepToType AddrRep = objectType
primRepToType other = pprPanic "primRepToType" (ppr other)
......
......@@ -220,7 +220,7 @@ call e n es = e <> dot <> n <> parens (hsep (punctuate comma (map expr es)))
literal = \l ->
case l of
{ IntLit i -> text (show i)
; CharLit c -> text (show c)
; CharLit c -> text "(char)" <+> text (show c)
; StringLit s -> text ("\"" ++ s ++ "\"") -- strings are already printable
}
......
......@@ -57,6 +57,7 @@ module Constants (
oTHER_TAG,
mAX_INTLIKE, mIN_INTLIKE,
mAX_CHARLIKE, mIN_CHARLIKE,
spRelToInt,
......@@ -120,6 +121,10 @@ oTHER_TAG = (INFO_OTHER_TAG :: Integer) -- (-1) unevaluated, probably
mIN_INTLIKE, mAX_INTLIKE :: Integer -- Only used to compare with (MachInt Integer)
mIN_INTLIKE = MIN_INTLIKE
mAX_INTLIKE = MAX_INTLIKE
mIN_CHARLIKE, mAX_CHARLIKE :: Int -- Only used to compare with (MachChar Int)
mIN_CHARLIKE = MIN_CHARLIKE
mAX_CHARLIKE = MAX_CHARLIKE
\end{code}
A little function that abstracts the stack direction. Note that most
......
......@@ -146,7 +146,7 @@ Here we handle top-level things, like @CCodeBlock@s and
mk_StCLbl_for_SRT :: CLabel -> StixTree
mk_StCLbl_for_SRT label
| labelDynamic label
= StIndex CharRep (StCLbl label) (StInt 1)
= StIndex Int8Rep (StCLbl label) (StInt 1)
| otherwise
= StCLbl label
......@@ -223,7 +223,8 @@ Here we handle top-level things, like @CCodeBlock@s and
= StData (promote_to_word (getAmodeRep amode)) [a2stix amode]
-- We need to promote any item smaller than a word to a word
promote_to_word CharRep = WordRep
promote_to_word Int8Rep = IntRep
promote_to_word CharRep = IntRep
promote_to_word other = other
-- always at least one padding word: this is the static link field
......@@ -473,7 +474,7 @@ be tuned.)
\begin{code}
intTag :: Literal -> Integer
intTag (MachChar c) = toInteger (ord c)
intTag (MachChar c) = toInteger c
intTag (MachInt i) = i
intTag (MachWord w) = intTag (word2IntLit (MachWord w))
intTag _ = panic "intTag"
......
......@@ -160,7 +160,8 @@ mangleIndexTree (StIndex pk base off)
]
where
shift DoubleRep = 3::Integer
shift CharRep = 0::Integer
shift CharRep = 2::Integer
shift Int8Rep = 0::Integer
shift _ = IF_ARCH_alpha(3,2)
\end{code}
......@@ -3249,14 +3250,16 @@ coerceFP2Int x
%* *
%************************************************************************
Integer to character conversion. Where applicable, we try to do this
in one step if the original object is in memory.
Integer to character conversion.
\begin{code}
chrCode :: StixTree -> NatM Register
#if alpha_TARGET_ARCH
-- TODO: This is probably wrong, but I don't know Alpha assembler.
-- It should coerce a 64-bit value to a 32-bit value.
chrCode x
= getRegister x `thenNat` \ register ->
getNewRegNCG IntRep `thenNat` \ reg ->
......@@ -3273,47 +3276,23 @@ chrCode x
chrCode x
= getRegister x `thenNat` \ register ->
let
code__2 dst = let
code = registerCode register dst
src = registerName register dst
in code `appOL`
if isFixed register && src /= dst
then toOL [MOV L (OpReg src) (OpReg dst),
AND L (OpImm (ImmInt 255)) (OpReg dst)]
else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src))
in
returnNat (Any IntRep code__2)
returnNat (
case register of