1 
    2 {------------------------------------------------------------------------}
    3 {--- Generic stuff for all architectures.                 Generics.hs ---}
    4 {------------------------------------------------------------------------}
    5 
    6 {- 
    7    This file is part of Cacheprof, a profiling tool for finding
    8    sources of cache misses in programs.
    9 
   10    Copyright (C) 1999 Julian Seward (jseward@acm.org) 
   11    Home page: http://www.cacheprof.org
   12 
   13    This program is free software; you can redistribute it and/or
   14    modify it under the terms of the GNU General Public License as
   15    published by the Free Software Foundation; either version 2 of the
   16    License, or (at your option) any later version.
   17 
   18    This program is distributed in the hope that it will be useful, but
   19    WITHOUT ANY WARRANTY; without even the implied warranty of
   20    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   21    General Public License for more details.
   22 
   23    You should have received a copy of the GNU General Public License
   24    along with this program; if not, write to the Free Software
   25    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
   26    02111-1307, USA.
   27 
   28    The GNU General Public License is contained in the file LICENSE.
   29 -}
   30 
   31 module Generics where
   32 
   33 internal msg
   34    = error ("\ncacheann: Internal error: " ++ msg ++ "\n")
   35 incomplete msg
   36    = error ("\ncacheann: Unhandled instruction set artefact:\n   " 
   37             ++ msg ++ "\n")
   38 inputerr msg
   39    = error ("\ncacheann: Bad input: " ++ msg ++ "\n")
   40 
   41 {-----------------------------------------------------------}
   42 {--- A data type for lexemes                             ---}
   43 {-----------------------------------------------------------}
   44 
   45 {- In here, LReg, LLiteral and LName are arch/syntax
   46    specific, but I don't think this matters, so long
   47    as the arch-specific lexer produces the Right Things.
   48    Note that lexers themselves are arch/syntax
   49    specific.
   50 -}
   51 data Lex
   52    = LReg     String  -- a register name eg "%eax"
   53    | LNum     String  -- a number           "456"
   54    | LLiteral String  -- a literal value    "$12"
   55    | LName    String  -- a name             "fprintf"
   56    | LLabel   String  -- a label            ".L3345"
   57    | LComma
   58    | LLParen
   59    | LRParen
   60    | LPlus
   61    | LMinus
   62    | LStar
   63    | LDollar
   64      deriving (Show, Eq)
   65 
   66 
   67 unLReg (LReg s) = s
   68 isLReg lx = case lx of { LReg _ -> True; _ -> False }
   69 
   70 unLNum (LNum s) = s
   71 isLNum lx = case lx of { LNum _ -> True; _ -> False }
   72 
   73 unLLiteral (LLiteral s) = s
   74 isLLiteral lx = case lx of { LLiteral _ -> True; _ -> False }
   75 
   76 unLName (LName s) = s
   77 isLName lx = case lx of { LName _ -> True; _ -> False }
   78 
   79 unLLabel (LLabel s) = s
   80 isLLabel lx = case lx of { LLabel _ -> True; _ -> False }
   81 
   82 
   83 
   84 {-----------------------------------------------------------}
   85 {--- Combinator parser generics -- building blocks for   ---}
   86 {--- parsers                                             ---}
   87 {-----------------------------------------------------------}
   88 
   89 data PResult a
   90    = PFail
   91    | POk a [Lex]
   92      deriving Show
   93 
   94 type Parser a = [Lex] -> PResult a
   95 
   96 pEmpty :: a -> Parser a
   97 pEmpty x ts = POk x ts
   98 
   99 pSat :: (Lex -> Bool) -> Parser Lex
  100 pSat p []     = PFail
  101 pSat p (t:ts) = if p t then POk t ts else PFail
  102 
  103 pApply :: (a -> b) -> Parser a -> Parser b
  104 pApply f p ts
  105    = case p ts of
  106         PFail -> PFail
  107         POk x uu -> POk (f x) uu
  108    
  109 
  110 pName :: String -> a -> Parser a
  111 pName w x ((LName w2):lxs)
  112    = if w == w2 then POk x lxs else PFail
  113 pName w x _ = PFail
  114 
  115 p2 :: (a -> b -> c) 
  116       -> Parser a -> Parser b -> Parser c
  117 p2 f p1 p2 ts1
  118    = case p1 ts1 of { PFail -> PFail ; POk x1 uu1 ->
  119      case p2 uu1 of { PFail -> PFail ; POk x2 uu2 ->
  120      POk (f x1 x2) uu2
  121      }}
  122 
  123 p3 :: (a -> b -> c -> d) 
  124       -> Parser a -> Parser b -> Parser c -> Parser d
  125 p3 f p1 p2 p3 ts1
  126    = case p1 ts1 of { PFail -> PFail ; POk x1 uu1 ->
  127      case p2 uu1 of { PFail -> PFail ; POk x2 uu2 ->
  128      case p3 uu2 of { PFail -> PFail ; POk x3 uu3 ->
  129      POk (f x1 x2 x3) uu3
  130      }}}
  131 
  132 pStar :: Parser a -> Parser [a]
  133 pStar p ts
  134    = case p ts of
  135         PFail     -> POk [] ts
  136         POk x uu1 -> case pStar p uu1 of
  137                         POk xs uu2 -> POk (x:xs) uu2
  138                         PFail      -> internal "pStar failed"
  139 
  140 pPlus :: Parser a -> Parser [a]
  141 pPlus p = p2 (:) p (pStar p)
  142 
  143 pAlt2 :: Parser a -> Parser a -> Parser a
  144 pAlt2 p1 p2 ts
  145    = case p1 ts of
  146         POk x1 uu -> POk x1 uu
  147         PFail     -> p2 ts
  148 
  149 pAlts :: [Parser a] -> Parser a
  150 pAlts = foldl1 pAlt2
  151 
  152 pOpt :: Parser a -> Parser (Maybe a)
  153 pOpt p ts
  154    = case p ts of
  155         PFail    -> POk Nothing ts
  156         POk x uu -> POk (Just x) uu
  157 
  158 pStarComma p
  159    = pAlts [
  160         p2 (\xs y -> xs++[y]) (pPlus (p2 (\x y -> x) p pLComma)) p,
  161         pApply (\x -> [x]) p,
  162         pEmpty []
  163      ]
  164 
  165 pLComma  = pSat (== LComma)
  166 pLMinus  = pSat (== LMinus)
  167 pLPlus   = pSat (== LPlus)
  168 pLLParen = pSat (== LLParen)
  169 pLRParen = pSat (== LRParen)
  170 pLStar   = pSat (== LStar)
  171 pLDollar = pSat (== LDollar)
  172 
  173 pInParens p    = p3 (\_ r _ -> r) pLLParen p pLRParen
  174 pPreComma p    = p2 (\_ r -> r) pLComma p
  175 pPreCommaOpt p = p2 (\_ r -> r) (pOpt pLComma) p
  176 
  177 
  178 
  179 {------------------------------------------------------------------------}
  180 {--- end                                                  Generics.hs ---}
  181 {------------------------------------------------------------------------}