ghc/compiler/ghci/InterpSyn.lhs

   1 %
   2 % (c) The University of Glasgow 2000
   3 %
   4 \section[InterpSyn]{Abstract syntax for interpretable trees}
   5
   6 \begin{code}
   7 module InterpSyn {- Todo: ( ... ) -} where
   8
   9 #include "HsVersions.h"
  10
  11 import Id
  12 import RdrName
  13 import PrimOp
  14 import Outputable
  15
  16 import PrelAddr -- tmp
  17 import PrelGHC  -- tmp
  18
  19 -----------------------------------------------------------------------------
  20 -- The interpretable expression type
  21
  22 data HValue = HValue  -- dummy type, actually a pointer to some Real Code.
  23
  24 data IBind con var = IBind Id (IExpr con var)
  25
  26 binder (IBind v e) = v
  27 bindee (IBind v e) = e
  28
  29 data AltAlg  con var = AltAlg  Int{-tagNo-} [(Id,Rep)] (IExpr con var)
  30 data AltPrim con var = AltPrim (Lit con var) (IExpr con var)
  31
  32 -- HACK ALERT!  A Lit may *only* be one of LitI, LitL, LitF, LitD
  33 type Lit con var = IExpr con var
  34
  35 data Rep
  36   = RepI
  37   | RepP
  38   | RepF
  39   | RepD
  40   -- we're assuming that Char# is sufficiently compatible with Int# that
  41   -- we only need one rep for both.
  42
  43   {- Not yet:
  44   | RepI8
  45   | RepI64
  46   -}
  47   deriving Eq
  48
  49
  50
  51 -- index???OffClosure needs to traverse indirection nodes.
  52
  53 -- You can always tell the representation of an IExpr by examining
  54 -- its root node.
  55 data IExpr con var
  56    = CaseAlgP  Id (IExpr con var) [AltAlg  con var] (Maybe (IExpr con var))
  57    | CaseAlgI  Id (IExpr con var) [AltAlg  con var] (Maybe (IExpr con var))
  58
  59    | CasePrimP Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
  60    | CasePrimI Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
  61
  62    -- saturated constructor apps; args are in heap order.
  63    -- The Addrs are the info table pointers.  Descriptors refer to the
  64    -- arg reps; all constructor applications return pointer rep.
  65    | ConApp    con
  66    | ConAppI   con (IExpr con var)
  67    | ConAppP   con (IExpr con var)
  68    | ConAppPP  con (IExpr con var) (IExpr con var)
  69    | ConAppPPP con (IExpr con var) (IExpr con var) (IExpr con var)
  70
  71    | PrimOpI PrimOp [(IExpr con var)]
  72    | PrimOpP PrimOp [(IExpr con var)]
  73
  74    | NonRecP (IBind con var) (IExpr con var)
  75    | RecP    [IBind con var] (IExpr con var)
  76
  77    | NonRecI (IBind con var) (IExpr con var)
  78    | RecI    [IBind con var] (IExpr con var)
  79
  80    | LitI   Int#
  81    | LitF   Float#
  82    | LitD   Double#
  83    | LitS   FAST_STRING
  84
  85    {- not yet:
  86    | LitB   Int8#
  87    | LitL   Int64#
  88    -}
  89
  90    | Native var   -- pointer to a Real Closure
  91
  92    | VarP   Id
  93    | VarI   Id
  94    | VarF   Id
  95    | VarD   Id
  96
  97         -- LamXY indicates a function of reps X -> Y
  98         -- ie var rep = X, result rep = Y
  99         -- NOTE: repOf (LamXY _ _) = RepI regardless of X and Y
 100         --
 101    | LamPP  Id (IExpr con var)
 102    | LamPI  Id (IExpr con var)
 103    | LamPF  Id (IExpr con var)
 104    | LamPD  Id (IExpr con var)
 105    | LamIP  Id (IExpr con var)
 106    | LamII  Id (IExpr con var)
 107    | LamIF  Id (IExpr con var)
 108    | LamID  Id (IExpr con var)
 109    | LamFP  Id (IExpr con var)
 110    | LamFI  Id (IExpr con var)
 111    | LamFF  Id (IExpr con var)
 112    | LamFD  Id (IExpr con var)
 113    | LamDP  Id (IExpr con var)
 114    | LamDI  Id (IExpr con var)
 115    | LamDF  Id (IExpr con var)
 116    | LamDD  Id (IExpr con var)
 117
 118         -- AppXY means apply a fn (always of Ptr rep) to
 119         -- an arg of rep X giving result of Rep Y
 120         -- therefore: repOf (AppXY _ _) = RepY
 121    | AppPP  (IExpr con var) (IExpr con var)
 122    | AppPI  (IExpr con var) (IExpr con var)
 123    | AppPF  (IExpr con var) (IExpr con var)
 124    | AppPD  (IExpr con var) (IExpr con var)
 125    | AppIP  (IExpr con var) (IExpr con var)
 126    | AppII  (IExpr con var) (IExpr con var)
 127    | AppIF  (IExpr con var) (IExpr con var)
 128    | AppID  (IExpr con var) (IExpr con var)
 129    | AppFP  (IExpr con var) (IExpr con var)
 130    | AppFI  (IExpr con var) (IExpr con var)
 131    | AppFF  (IExpr con var) (IExpr con var)
 132    | AppFD  (IExpr con var) (IExpr con var)
 133    | AppDP  (IExpr con var) (IExpr con var)
 134    | AppDI  (IExpr con var) (IExpr con var)
 135    | AppDF  (IExpr con var) (IExpr con var)
 136    | AppDD  (IExpr con var) (IExpr con var)
 137
 138
 139 showExprTag :: IExpr c v -> String
 140 showExprTag expr
 141    = case expr of
 142         CaseAlgP  _ _ _ _ -> "CaseAlgP"
 143         CasePrimP _ _ _ _ -> "CasePrimP"
 144         CaseAlgI  _ _ _ _ -> "CaseAlgI"
 145         CasePrimI _ _ _ _ -> "CasePrimI"
 146         ConApp _          -> "ConApp"
 147         ConAppI _ _       -> "ConAppI"
 148         ConAppP _ _       -> "ConAppP"
 149         ConAppPP _ _ _    -> "ConAppPP"
 150         ConAppPPP _ _ _ _ -> "ConAppPPP"
 151         PrimOpI _ _       -> "PrimOpI"
 152         NonRecP _ _       -> "NonRecP"
 153         RecP _ _          -> "RecP"
 154         NonRecI _ _       -> "NonRecI"
 155         RecI _ _          -> "RecI"
 156         LitI _            -> "LitI"
 157         LitS _            -> "LitS"
 158         Native _          -> "Native"
 159         VarP _            -> "VarP"
 160         VarI _            -> "VarI"
 161         LamPP _ _         -> "LamPP"
 162         LamPI _ _         -> "LamPI"
 163         LamIP _ _         -> "LamIP"
 164         LamII _ _         -> "LamII"
 165         AppPP _ _         -> "AppPP"
 166         AppPI _ _         -> "AppPI"
 167         AppIP _ _         -> "AppIP"
 168         AppII _ _         -> "AppII"
 169         other             -> "(showExprTag:unhandled case)"
 170
 171 -----------------------------------------------------------------------------
 172 -- Instantiations of the IExpr type
 173
 174 type UnlinkedIExpr = IExpr RdrName RdrName
 175 type LinkedIExpr   = IExpr Addr    HValue
 176
 177 type UnlinkedIBind = IBind RdrName RdrName
 178 type LinkedIBind   = IBind Addr    HValue
 179
 180 type UnlinkedAltAlg  = AltAlg  RdrName RdrName
 181 type LinkedAltAlg    = AltAlg  Addr HValue
 182
 183 type UnlinkedAltPrim = AltPrim RdrName RdrName
 184 type LinkedAltPrim = AltPrim Addr HValue
 185
 186 -----------------------------------------------------------------------------
 187 -- Pretty printing
 188
 189 instance Outputable HValue where
 190    ppr x = text (show (A# (unsafeCoerce# x :: Addr#)))
 191         -- ptext SLIT("<O>")  -- unidentified lurking object
 192
 193 pprIBind :: (Outputable var, Outputable con) => IBind con var -> SDoc
 194 pprIBind (IBind v e) = ppr v <+> char '=' <+> pprIExpr e
 195
 196 pprAltAlg (AltAlg tag vars rhs)
 197    = text "Tag_" <> int tag <+> hsep (map ppr vars)
 198      <+> text "->" <+> pprIExpr rhs
 199
 200 pprAltPrim (AltPrim tag rhs)
 201    = pprIExpr tag <+> text "->" <+> pprIExpr rhs
 202
 203 instance Outputable Rep where
 204    ppr RepI = text "I"
 205    ppr RepP = text "P"
 206
 207 instance Outputable Addr where
 208    ppr addr = text (show addr)
 209
 210 pprDefault Nothing = text "NO_DEFAULT"
 211 pprDefault (Just e) = text "DEFAULT ->" $$ nest 2 (pprIExpr e)
 212
 213 pprIExpr :: (Outputable var, Outputable con) => IExpr con var -> SDoc
 214 pprIExpr (expr:: IExpr con var)
 215    = case expr of
 216         PrimOpI op args -> doPrimOp 'I' op args
 217         PrimOpP op args -> doPrimOp 'P' op args
 218
 219         VarI v    -> ppr v
 220         VarP v    -> ppr v
 221         LitI i#   -> int (I# i#) <> char '#'
 222         LitS s    -> char '"' <> ptext s <> char '"'
 223
 224         LamPP v e -> doLam "PP" v e
 225         LamPI v e -> doLam "PI" v e
 226         LamIP v e -> doLam "IP" v e
 227         LamII v e -> doLam "II" v e
 228
 229         AppPP f a -> doApp "PP" f a
 230         AppPI f a -> doApp "PI" f a
 231         AppIP f a -> doApp "IP" f a
 232         AppII f a -> doApp "II" f a
 233
 234         Native v  -> ptext SLIT("Native") <+> ppr v
 235
 236         CasePrimI b sc alts def -> doCasePrim 'I' b sc alts def
 237         CasePrimP b sc alts def -> doCasePrim 'P' b sc alts def
 238
 239         CaseAlgI b sc alts def -> doCaseAlg 'I' b sc alts def
 240         CaseAlgP b sc alts def -> doCaseAlg 'P' b sc alts def
 241
 242         NonRecP bind body -> doNonRec 'P' bind body
 243         NonRecI bind body -> doNonRec 'I' bind body
 244
 245         ConApp    i          -> doConApp "" i ([] :: [IExpr con var])
 246         ConAppI   i a1       -> doConApp "" i [a1]
 247         ConAppP   i a1       -> doConApp "" i [a1]
 248         ConAppPP  i a1 a2    -> doConApp "" i [a1,a2]
 249         ConAppPPP i a1 a2 a3 -> doConApp "" i [a1,a2,a3]
 250
 251         other     -> text "pprIExpr: unimplemented tag:"
 252                      <+> text (showExprTag other)
 253      where
 254         doConApp repstr itbl args
 255            = text "Con" <> text repstr
 256              <+> char '[' <> hsep (map pprIExpr args) <> char ']'
 257
 258         doPrimOp repchar op args
 259            = char repchar <> ppr op <+> char '[' <> hsep (map pprIExpr args) <> char ']'
 260
 261         doNonRec repchr bind body
 262            = vcat [text "let" <> char repchr <+> pprIBind bind, text "in", pprIExpr body]
 263
 264         doCasePrim repchr b sc alts def
 265            = sep [text "CasePrim" <> char repchr
 266                      <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
 267                   nest 2 (vcat (map pprAltPrim alts) $$ pprDefault def),
 268                   char '}'
 269                  ]
 270
 271         doCaseAlg repchr b sc alts def
 272            = sep [text "CaseAlg" <> char repchr
 273                      <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
 274                   nest 2 (vcat (map pprAltAlg alts) $$ pprDefault def),
 275                   char '}'
 276                  ]
 277
 278         doApp repstr f a
 279            = text "(@" <> text repstr <+> pprIExpr f <+> pprIExpr a <> char ')'
 280         doLam repstr v e
 281            = (char '\\' <> text repstr <+> ppr v <+> text "->") $$ pprIExpr e
 282
 283 \end{code}