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