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   | RepV       -- void rep
  45   | RepI8
  46   | RepI64
  47   -}
  48   deriving Eq
  49
  50
  51
  52 -- index???OffClosure needs to traverse indirection nodes.
  53
  54 -- You can always tell the representation of an IExpr by examining
  55 -- its root node.
  56 data IExpr con var
  57    = CaseAlgP  Id (IExpr con var) [AltAlg  con var] (Maybe (IExpr con var))
  58    | CaseAlgI  Id (IExpr con var) [AltAlg  con var] (Maybe (IExpr con var))
  59    | CaseAlgF  Id (IExpr con var) [AltAlg  con var] (Maybe (IExpr con var))
  60    | CaseAlgD  Id (IExpr con var) [AltAlg  con var] (Maybe (IExpr con var))
  61
  62    | CasePrimP Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
  63    | CasePrimI Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
  64    | CasePrimF Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
  65    | CasePrimD Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
  66
  67    -- saturated constructor apps; args are in heap order.
  68    -- The Addrs are the info table pointers.  Descriptors refer to the
  69    -- arg reps; all constructor applications return pointer rep.
  70    | ConApp    con
  71    | ConAppI   con (IExpr con var)
  72    | ConAppP   con (IExpr con var)
  73    | ConAppPP  con (IExpr con var) (IExpr con var)
  74    | ConAppPPP con (IExpr con var) (IExpr con var) (IExpr con var)
  75
  76    | PrimOpP PrimOp [(IExpr con var)]
  77    | PrimOpI PrimOp [(IExpr con var)]
  78    | PrimOpF PrimOp [(IExpr con var)]
  79    | PrimOpD PrimOp [(IExpr con var)]
  80
  81    | NonRecP (IBind con var) (IExpr con var)
  82    | NonRecI (IBind con var) (IExpr con var)
  83    | NonRecF (IBind con var) (IExpr con var)
  84    | NonRecD (IBind con var) (IExpr con var)
  85
  86    | RecP    [IBind con var] (IExpr con var)
  87    | RecI    [IBind con var] (IExpr con var)
  88    | RecF    [IBind con var] (IExpr con var)
  89    | RecD    [IBind con var] (IExpr con var)
  90
  91    | LitI   Int#
  92    | LitF   Float#
  93    | LitD   Double#
  94
  95    {- not yet:
  96    | LitB   Int8#
  97    | LitL   Int64#
  98    -}
  99
 100    | Native var   -- pointer to a Real Closure
 101
 102    | VarP   Id
 103    | VarI   Id
 104    | VarF   Id
 105    | VarD   Id
 106
 107         -- LamXY indicates a function of reps X -> Y
 108         -- ie var rep = X, result rep = Y
 109         -- NOTE: repOf (LamXY _ _) = RepI regardless of X and Y
 110         --
 111    | LamPP  Id (IExpr con var)
 112    | LamPI  Id (IExpr con var)
 113    | LamPF  Id (IExpr con var)
 114    | LamPD  Id (IExpr con var)
 115    | LamIP  Id (IExpr con var)
 116    | LamII  Id (IExpr con var)
 117    | LamIF  Id (IExpr con var)
 118    | LamID  Id (IExpr con var)
 119    | LamFP  Id (IExpr con var)
 120    | LamFI  Id (IExpr con var)
 121    | LamFF  Id (IExpr con var)
 122    | LamFD  Id (IExpr con var)
 123    | LamDP  Id (IExpr con var)
 124    | LamDI  Id (IExpr con var)
 125    | LamDF  Id (IExpr con var)
 126    | LamDD  Id (IExpr con var)
 127
 128         -- AppXY means apply a fn (always of Ptr rep) to
 129         -- an arg of rep X giving result of Rep Y
 130         -- therefore: repOf (AppXY _ _) = RepY
 131    | AppPP  (IExpr con var) (IExpr con var)
 132    | AppPI  (IExpr con var) (IExpr con var)
 133    | AppPF  (IExpr con var) (IExpr con var)
 134    | AppPD  (IExpr con var) (IExpr con var)
 135    | AppIP  (IExpr con var) (IExpr con var)
 136    | AppII  (IExpr con var) (IExpr con var)
 137    | AppIF  (IExpr con var) (IExpr con var)
 138    | AppID  (IExpr con var) (IExpr con var)
 139    | AppFP  (IExpr con var) (IExpr con var)
 140    | AppFI  (IExpr con var) (IExpr con var)
 141    | AppFF  (IExpr con var) (IExpr con var)
 142    | AppFD  (IExpr con var) (IExpr con var)
 143    | AppDP  (IExpr con var) (IExpr con var)
 144    | AppDI  (IExpr con var) (IExpr con var)
 145    | AppDF  (IExpr con var) (IExpr con var)
 146    | AppDD  (IExpr con var) (IExpr con var)
 147
 148
 149 showExprTag :: IExpr c v -> String
 150 showExprTag expr
 151    = case expr of
 152
 153         CaseAlgP  _ _ _ _ -> "CaseAlgP"
 154         CaseAlgI  _ _ _ _ -> "CaseAlgI"
 155         CaseAlgF  _ _ _ _ -> "CaseAlgF"
 156         CaseAlgD  _ _ _ _ -> "CaseAlgD"
 157
 158         CasePrimP _ _ _ _ -> "CasePrimP"
 159         CasePrimI _ _ _ _ -> "CasePrimI"
 160         CasePrimF _ _ _ _ -> "CasePrimF"
 161         CasePrimD _ _ _ _ -> "CasePrimD"
 162
 163         ConApp _          -> "ConApp"
 164         ConAppI _ _       -> "ConAppI"
 165         ConAppP _ _       -> "ConAppP"
 166         ConAppPP _ _ _    -> "ConAppPP"
 167         ConAppPPP _ _ _ _ -> "ConAppPPP"
 168
 169         PrimOpP _ _       -> "PrimOpP"
 170         PrimOpI _ _       -> "PrimOpI"
 171         PrimOpF _ _       -> "PrimOpF"
 172         PrimOpD _ _       -> "PrimOpD"
 173
 174         NonRecP _ _       -> "NonRecP"
 175         NonRecI _ _       -> "NonRecI"
 176         NonRecF _ _       -> "NonRecF"
 177         NonRecD _ _       -> "NonRecD"
 178
 179         RecP _ _          -> "RecP"
 180         RecI _ _          -> "RecI"
 181         RecF _ _          -> "RecF"
 182         RecD _ _          -> "RecD"
 183
 184         LitI _            -> "LitI"
 185         LitF _            -> "LitF"
 186         LitD _            -> "LitD"
 187
 188         Native _          -> "Native"
 189
 190         VarP _            -> "VarP"
 191         VarI _            -> "VarI"
 192         VarF _            -> "VarF"
 193         VarD _            -> "VarD"
 194
 195         LamPP _ _         -> "LamPP"
 196         LamPI _ _         -> "LamPI"
 197         LamPF _ _         -> "LamPF"
 198         LamPD _ _         -> "LamPD"
 199         LamIP _ _         -> "LamIP"
 200         LamII _ _         -> "LamII"
 201         LamIF _ _         -> "LamIF"
 202         LamID _ _         -> "LamID"
 203         LamFP _ _         -> "LamFP"
 204         LamFI _ _         -> "LamFI"
 205         LamFF _ _         -> "LamFF"
 206         LamFD _ _         -> "LamFD"
 207         LamDP _ _         -> "LamDP"
 208         LamDI _ _         -> "LamDI"
 209         LamDF _ _         -> "LamDF"
 210         LamDD _ _         -> "LamDD"
 211
 212         AppPP _ _         -> "AppPP"
 213         AppPI _ _         -> "AppPI"
 214         AppPF _ _         -> "AppPF"
 215         AppPD _ _         -> "AppPD"
 216         AppIP _ _         -> "AppIP"
 217         AppII _ _         -> "AppII"
 218         AppIF _ _         -> "AppIF"
 219         AppID _ _         -> "AppID"
 220         AppFP _ _         -> "AppFP"
 221         AppFI _ _         -> "AppFI"
 222         AppFF _ _         -> "AppFF"
 223         AppFD _ _         -> "AppFD"
 224         AppDP _ _         -> "AppDP"
 225         AppDI _ _         -> "AppDI"
 226         AppDF _ _         -> "AppDF"
 227         AppDD _ _         -> "AppDD"
 228
 229         other             -> "(showExprTag:unhandled case)"
 230
 231 -----------------------------------------------------------------------------
 232 -- Instantiations of the IExpr type
 233
 234 type UnlinkedIExpr = IExpr RdrName RdrName
 235 type LinkedIExpr   = IExpr Addr    HValue
 236
 237 type UnlinkedIBind = IBind RdrName RdrName
 238 type LinkedIBind   = IBind Addr    HValue
 239
 240 type UnlinkedAltAlg  = AltAlg  RdrName RdrName
 241 type LinkedAltAlg    = AltAlg  Addr HValue
 242
 243 type UnlinkedAltPrim = AltPrim RdrName RdrName
 244 type LinkedAltPrim = AltPrim Addr HValue
 245
 246 -----------------------------------------------------------------------------
 247 -- Pretty printing
 248
 249 instance Outputable HValue where
 250    ppr x = text (show (A# (unsafeCoerce# x :: Addr#)))
 251         -- ptext SLIT("<O>")  -- unidentified lurking object
 252
 253 pprIBind :: (Outputable var, Outputable con) => IBind con var -> SDoc
 254 pprIBind (IBind v e) = ppr v <+> char '=' <+> pprIExpr e
 255
 256 pprAltAlg (AltAlg tag vars rhs)
 257    = text "Tag_" <> int tag <+> hsep (map ppr vars)
 258      <+> text "->" <+> pprIExpr rhs
 259
 260 pprAltPrim (AltPrim tag rhs)
 261    = pprIExpr tag <+> text "->" <+> pprIExpr rhs
 262
 263 instance Outputable Rep where
 264    ppr RepI = text "I"
 265    ppr RepP = text "P"
 266
 267 instance Outputable Addr where
 268    ppr addr = text (show addr)
 269
 270 pprDefault Nothing = text "NO_DEFAULT"
 271 pprDefault (Just e) = text "DEFAULT ->" $$ nest 2 (pprIExpr e)
 272
 273 pprIExpr :: (Outputable var, Outputable con) => IExpr con var -> SDoc
 274 pprIExpr (expr:: IExpr con var)
 275    = case expr of
 276         PrimOpI op args -> doPrimOp 'I' op args
 277         PrimOpP op args -> doPrimOp 'P' op args
 278
 279         VarI v    -> ppr v
 280         VarP v    -> ppr v
 281         LitI i#   -> int (I# i#) <> char '#'
 282
 283         LamPP v e -> doLam "PP" v e
 284         LamPI v e -> doLam "PI" v e
 285         LamIP v e -> doLam "IP" v e
 286         LamII v e -> doLam "II" v e
 287
 288         AppPP f a -> doApp "PP" f a
 289         AppPI f a -> doApp "PI" f a
 290         AppIP f a -> doApp "IP" f a
 291         AppII f a -> doApp "II" f a
 292
 293         Native v  -> ptext SLIT("Native") <+> ppr v
 294
 295         CasePrimI b sc alts def -> doCasePrim 'I' b sc alts def
 296         CasePrimP b sc alts def -> doCasePrim 'P' b sc alts def
 297
 298         CaseAlgI b sc alts def -> doCaseAlg 'I' b sc alts def
 299         CaseAlgP b sc alts def -> doCaseAlg 'P' b sc alts def
 300
 301         NonRecP bind body -> doNonRec 'P' bind body
 302         NonRecI bind body -> doNonRec 'I' bind body
 303
 304         ConApp    i          -> doConApp "" i ([] :: [IExpr con var])
 305         ConAppI   i a1       -> doConApp "" i [a1]
 306         ConAppP   i a1       -> doConApp "" i [a1]
 307         ConAppPP  i a1 a2    -> doConApp "" i [a1,a2]
 308         ConAppPPP i a1 a2 a3 -> doConApp "" i [a1,a2,a3]
 309
 310         other     -> text "pprIExpr: unimplemented tag:"
 311                      <+> text (showExprTag other)
 312      where
 313         doConApp repstr itbl args
 314            = text "Con" <> text repstr
 315              <+> char '[' <> hsep (map pprIExpr args) <> char ']'
 316
 317         doPrimOp repchar op args
 318            = char repchar <> ppr op <+> char '[' <> hsep (map pprIExpr args) <> char ']'
 319
 320         doNonRec repchr bind body
 321            = vcat [text "let" <> char repchr <+> pprIBind bind, text "in", pprIExpr body]
 322
 323         doCasePrim repchr b sc alts def
 324            = sep [text "CasePrim" <> char repchr
 325                      <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
 326                   nest 2 (vcat (map pprAltPrim alts) $$ pprDefault def),
 327                   char '}'
 328                  ]
 329
 330         doCaseAlg repchr b sc alts def
 331            = sep [text "CaseAlg" <> char repchr
 332                      <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
 333                   nest 2 (vcat (map pprAltAlg alts) $$ pprDefault def),
 334                   char '}'
 335                  ]
 336
 337         doApp repstr f a
 338            = text "(@" <> text repstr <+> pprIExpr f <+> pprIExpr a <> char ')'
 339         doLam repstr v e
 340            = (char '\\' <> text repstr <+> ppr v <+> text "->") $$ pprIExpr e
 341
 342 \end{code}