packages feed

hugs2yc (empty) → 0.1

raw patch · 8 files changed

+879/−0 lines, 8 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, filepath, mtl, parsec, uniplate, ycextra, yhccore

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Dmitry Golubovsky 2008.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Dmitry Golubovsky nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Yhc/Core/FrontEnd/Hugs.hs view
@@ -0,0 +1,96 @@+------------------------------------------------------------------+-- |+-- Module      :  Yhc.Core.FrontEnd.Hugs+-- Copyright   :  (c) Dmitry Golubovsky, 2007              +-- License     :  BSD-style+-- +-- Maintainer  :  golubovsky@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-- +--+--+-- Hugs Core to Yhc Core converter (via parsing).+------------------------------------------------------------------++module Yhc.Core.FrontEnd.Hugs (+  parseHugsCore, +  linkHugsCore,+  module Yhc.Core.FrontEnd.Hugs.PrimTable) +where++import Control.Monad+import System.FilePath+import Text.ParserCombinators.Parsec+import System.Directory+import System.IO+import Yhc.Core.FrontEnd.Hugs.ParseUtil+import Yhc.Core.FrontEnd.Hugs.LinkUtil+import Yhc.Core.FrontEnd.Hugs.UnDict+import Yhc.Core.FrontEnd.Hugs.Annotations+import Yhc.Core.FrontEnd.Hugs.PrimTable++import Yhc.Core.Extra+import qualified Data.Map as M++-- |Toplevel parser: reads in a given single Hugs Core file,+-- starts the module parser with empty state. The function+-- returns either a parse error or an individual Yhc Core in memory.+-- Due to the Hugs specifics, individual Yhc Core modules are not+-- usable, so it is recommended to use the 'linkHugsCore' function+-- unless anything special is needed.++parseHugsCore :: FilePath -> IO (Either ParseError Core)++parseHugsCore f = do+  let emptyst = PState {+    modName = ""+   ,funName = ""+   ,fbStack = [0]+   ,counter = 0+   ,autoFuncs = []+  }+  inp <- readFile f+  return $ runParser pModule emptyst f inp++-- |Hugs Core Linker: reads in all *.cor files from the given directories+-- and produces a linked .yca object ready to save in a file. +-- Names of reachability roots are picked from the arguments,+-- and they should be fully qualified names with+-- semicolons separating module name from function name.+-- If an empty list is provided, all \"main\" functions+-- found in all modules will be used as roots. If none exists,+-- error will be reported. Error will also be reported if parsing+-- of any of the files, or final linking results in an error.++linkHugsCore :: [FilePath] -- ^directories where *.cor files reside+             -> [CoreFuncName] -- ^reachability roots+             -> String -- ^name of the new Core+             -> IO Core++linkHugsCore dirs roots0 outcore= do+  dcs <- mapM getDirectoryContents dirs +  let fdcs = zipWith prepdir dirs dcs+      prepdir d fs = map (d </>) fs+      hcfs = (filter (\f -> takeExtension f == ".cor") . concat) fdcs+  cores <- mapM (\f -> do hPutStr stderr $ "Parsing module " ++ f ++ " ... "+                          ec <- parseHugsCore f+                          case ec of+                            Left e -> error ("linkHugsCore: " ++ show e)+                            Right c -> hPutStrLn stderr "done" >> return c) hcfs+  let mcore = mergeCores (dropExtension outcore) cores+      mains = [x | x <- map coreFuncName (coreFuncs mcore), dropModule x == "main"]+      roots = roots0 ++ mains+      roots' = "SEL_ELEM" : roots+  when (null roots) $ error "linkHugsCore: no reachability roots were specified or found"++  let opts_all = coreReachable roots' . +                 unDict . coreCaseElim . coreSimplify .+                 fixCasePats . removeRecursiveLet .+                 mapPrims . mapFuns . mapDatas . mapCons . fixCore++  let fmcore = opts_all mcore++  return fmcore++
+ Yhc/Core/FrontEnd/Hugs/LinkUtil.hs view
@@ -0,0 +1,141 @@+-- Linker utility functions for Hugs Core++module Yhc.Core.FrontEnd.Hugs.LinkUtil where++import Control.Monad+import Data.Maybe+import Yhc.Core.Extra+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.List as L+import Yhc.Core.FrontEnd.Hugs.ParseUtil (nameGen)+import Yhc.Core.FrontEnd.Hugs.PrimTable (hugsPrimTable)++import Debug.Trace++-- Taken from Yhc Linker++mergeCores :: String -> [Core] -> Core+mergeCores modname cores = Core modname [] (concat datas) (concat funcs)+    where (datas,funcs) = unzip $ map (\x -> (coreDatas x, coreFuncs x)) cores++-- Fix core by deriving some missing objects such as tuple constructors,+-- or some other known constructors and functions.++fixCore :: Core -> Core++fixCore c = +  let urd = coreUnreachableDatas c +      c' = fixDatas urd c+      urf = coreUnreachableFuncs c'+  in  fixFuncs urf c' where+  fixFuncs _ c = c+  fixDatas mcs c = foldl fixOneData c mcs where+    isTuple ('H':'u':'g':'s':'.':'P':'r':'e':'l':'u':'d':'e':';':'(' : rtpl)+      | all (== ',') ((reverse . tail . reverse) rtpl) = length rtpl+    isTuple _ = 0+    fixOneData c tpl | isTuple tpl > 0 =+      let ntpl = isTuple tpl+          cargs = take ntpl nameGen+          tpldata = CoreData {+            coreDataName = tpl,+            coreDataTypes = [],+            coreDataCtors = [CoreCtor {+              coreCtorName = tpl,+              coreCtorFields = zip cargs (repeat Nothing)}]}+      in c {coreDatas = tpldata : coreDatas c,+            coreFuncs = coreFuncs c}+    fixOneData c _ = c++-- Convert cases with calls to PrimPmXXX to case with constant patterns.+-- Hugs generates:+-- case (Prelude;primPmInt Prelude;v30 0 _1) of+--   Prelude;True -> Prelude;v1489 0+--   _ -> foo+--+-- This has to be transformed to:+-- case _1 of+--   0 -> Prelude;v1489 0+--   _ -> foo+-- In this case, the first argument of primPmInt is a dictionary +-- that would not be used under the new scheme. The second is+-- a constant to match, and the third is a variable to become+-- the case scrutinee variable under the new scheme.++pmfuns = map ("Prelude;primPm" ++) ["Int", "Integer", "Flt"]++fixCasePats :: Core -> Core++fixCasePats core = transformExpr (f core) core where+  f core (CoreCase (CoreApp (CoreFun pmfun) [_, CoreLit clit, cvar]) +            [(PatCon "Prelude;True" [], exmat), d@(PatDefault, exdfl)]) +              | pmfun `elem` pmfuns =+    CoreCase cvar [(PatLit clit, exmat), d]+  f _ x = x++-- Remap function names in the case Hugs defines them in an undesired way.+-- Basically, everything defined in Hugs.Prelude goes to Prelude.++mapFuns :: Core -> Core++mapFuns core = mapFunNames funmap core where+  funmap = M.fromList $ zip hpfuns pfuns+  hpfuns = filter toRemap allfuns+  allfuns = map coreFuncName $ coreFuncs core+  pfuns = map (("Prelude;" ++ ) . dropModule) hpfuns+++-- Remap constructor names in the case Hugs defines them in an undesired way.+-- Basically, everything defined in Hugs.Prelude goes to Prelude.++mapCons :: Core -> Core++mapCons core = mapConNames ctormap core where+  ctormap = M.fromList $ zip hpctors pctors+  hpctors = filter toRemap allctors+  allctors = map coreCtorName $ concat $ map coreDataCtors $ coreDatas core+  pctors = map (("Prelude;" ++ ) . dropModule) hpctors++-- Remap data objects (LHS of data XXX) in the case Hugs defines them in an undesired way.+-- Basically, everything defined in Hugs.Prelude goes to Prelude.++mapDatas :: Core -> Core++mapDatas core = mapDataNames dtmap core where+  dtmap = M.fromList $ zip hpdatas pdatas+  hpdatas = filter toRemap alldatas+  alldatas = map coreDataName $ coreDatas core+  pdatas = map (("Prelude;" ++ ) . dropModule) hpdatas++-- Remap Hugs primitives into Yhc Core normal primitives.+-- The mapping table is in the Yhc.Core.FrontEnd.Hugs.PrimTable module.++mapPrims :: Core -> Core++mapPrims = mapFunNames (M.fromList hugsPrimTable)++-- Filter for function names to remap by mapFuns.++toRemap ('H':'u':'g':'s':'.':'P':'r':'e':'l':'u':'d':'e':';': _) = True+toRemap _ = False++-- Transform all calls to constructor lifting functions into+-- calls to conctructors themselves provided that call to the lifting+-- function was saturated.++unLiftCtors :: Core -> Core+unLiftCtors core = transformExpr (fx core) core where+  fx core ap@(CoreApp (CoreFun f) args) | coreSaturated core ap =+    fromMaybe ap $ do+      fdef <- coreFuncMaybe core f+      when (isCorePrim fdef) $ fail $ "unLiftCtors: primitive " ++ f+      let fbdy = coreFuncBody fdef+          fargs = coreFuncArgs fdef+      case fbdy of+        CoreApp cc@(CoreCon c) cargs+          | length fargs == length cargs &&+            all isCoreVar cargs &&+            all id (zipWith (==) (map CoreVar fargs) cargs) -> return $ CoreApp cc args+        _ -> return ap+  fx _ x = x+
+ Yhc/Core/FrontEnd/Hugs/ParseUtil.hs view
@@ -0,0 +1,372 @@+-- Parser utility functions for Hugs Core.++module Yhc.Core.FrontEnd.Hugs.ParseUtil where++import Yhc.Core.Extra+import Data.Char+import Data.List+import Data.Maybe+import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Token+import Text.ParserCombinators.Parsec.Language (haskellDef)++-- Tokenizer for Hugs Core, based on Haskell language definitions.++tkp = makeTokenParser haskellDef {+  identStart = letter <|> oneOf "_'"+ ,identLetter = alphaNum <|> oneOf "_'"+ ,reservedNames = ["module", "data", "primitive", "case", "in", "of", "let",+                   "let_", "_fatbar", "[]", "()", "::"]+}++-- State of the Hugs core parser++data PState = PState {+  modName :: String                -- current Core module name+ ,funName :: String                -- current function name+ ,fbStack :: [Int]                 -- stack of FATBARs: number identifies+                                   -- a currently introduced FATBAR binding:+                                   -- the number will be appended to "v_fail_"+                                   -- If the stack contains only a zero, default+                                   -- binding is in effect, that is a code to throw+                                   -- a pattern match exception.+                                   -- to get a variable bound to the current FATBAR+ ,counter :: Int                   -- unique numbers producer+ ,autoFuncs :: [CoreFunc]          -- any functions not included in the source Hugs Core+                                   -- and generated during the conversion.+}++-- Qualified identifier: data structure to distinguish between+-- a function and a data constructor.++data QUALID = QCTOR String+            | QFUNC String+            deriving (Show, Eq)++-- Two-letter internal variable name generator.++nameGen = [a : b : [] | a <- ['a' .. 'z'], b <- ['0' .. '9']]++-- Parser. Reads in Hugs Core syntax, returns Yhc Core structure.++-- ident = id [. id...]++ident = (identifier tkp) `sepBy1` (dot tkp) >>= return . concat . intersperse "."++-- Special names for data constructors: [], (), #n for tuples of n.+-- Tuples will be recoded in Yhc way (,...,)++nil = try $ squares tkp (return "[]")++unit = try $ parens tkp (return "()")++tuple = try $ do+  char '#'+  n <- natural tkp+  return $ "(" ++ replicate (fromIntegral n - 1) ',' ++ ")"++-- Parser for a qualified (dot-separated) name, distinguishes+-- between tuples (which are not qualified) functions and data constructors.+-- Tuples will be artificially qualified with Prelude.++pQUALID :: GenParser Char a QUALID++pQUALID = +      (tuple >>= return . QCTOR . ("Hugs.Prelude;" ++)) +  <|> (try $ do+         let anyid = nil <|> infctor <|> unit <|> tuple <|> identifier tkp <|> operator tkp+             fstupr [] = False+             fstupr (h : t) = isUpper h+             funcid [] = False+             funcid (h : t) = isLower h || h `elem` "'_"+             infctid [] = False+             infctid (':' : _) = True+             infctid _ = False+             isoper s = either (const False) (const True) (parse (operator tkp) "" s)+         parts <- anyid `sepBy` dot tkp+         let strap = reverse parts+             x [] = (QCTOR, 0)+             x [_] = (QCTOR, 0)+             x (c : "Make" : md) | all fstupr (c : md) = (QCTOR, 2)+             x (f : md) | all fstupr md && funcid f = (QFUNC, 1)+             x (c : md) | all fstupr md && c `elem` ["[]", "()"] = (QCTOR, 1)+             x (c : md) | all fstupr md && infctid c = (QCTOR, 1)+             x (o : md) | all fstupr md && isoper o = (QFUNC, 1)+             x ps | all fstupr ps = (QCTOR, 1)+                  | otherwise = (QCTOR, 0)+         case x strap of+           (_, 0) -> pzero+           (c, n) -> do +             let (m, f) = splitAt n strap+             (return . c . concat) $ reverse +               (intersperse "." m ++ [";"] ++ intersperse "." f))++-- Infix constructor: colon followed by an operator++infctor = try $ do+  c <- char ':'+  o <- (operator tkp) <|> (reserved tkp "=" >> return "=") <|> (whiteSpace tkp >> return "")+  return (c : o)++-- module = "module" id ";" [datas] [funcs]++pModule :: GenParser Char PState Core++pModule = do+  reserved tkp "module"+  mid <- ident+  semi tkp+  updateState (\st -> st {modName = mid})+  datas <- many pData+  prims <- many pPrim+  funcs <- many pFunc+  cmts <- whiteSpace tkp+  autof <- getState >>= return . autoFuncs+  return $ Core {+    coreName = mid, +    coreImports = [], +    coreDatas = datas, +    coreFuncs = prims ++ funcs ++ autof}++-- primitive = "primitive" QUALID args ";"++pPrim = do+  reserved tkp "primitive"+  pid <- pQUALID+  pargs <- many ident+  semi tkp+  case pid of+    QCTOR _ -> pzero+    QFUNC pf -> return $ CorePrim {+      coreFuncName = pf,+      corePrimArity = length pargs,+      corePrimExternal = dropModule pf,+      corePrimConv = "hugsprim",+      corePrimImport = True,+      corePrimTypes = []}++-- data = "data" id "=" [ctors] ";"++pData = do+  reserved tkp "data"+  did <- (nil <|> unit <|> ident <|> tuple)+  symbol tkp "="+  ctors <- pCtor `sepBy` (symbol tkp "|")+  semi tkp+  mid <- getState >>= return . modName+  return $ CoreData {+    coreDataName = mid ++ ";" ++ did,+    coreDataTypes = [],+    coreDataCtors = ctors}++-- ctor = id ["*"]+-- Constructor parser.++pCtor = do+  cid <- (nil <|> infctor <|> unit <|> ident <|> tuple) +  stars <- many (symbol tkp "*")+  let cargs = take (length stars) nameGen+      cflds = zip cargs (repeat Nothing)+  mid <- getState >>= return . modName+  let qcid = mid ++ ";" ++ cid+  return $ CoreCtor {+    coreCtorName = qcid,+    coreCtorFields = cflds}+ +-- function = id [id] "=" expr++pFunc = do+  fname <- identifier tkp <|> parens tkp (operator tkp)+  fargs <- many ident+  symbol tkp "="+  mid <- getState >>= return . modName+  let xfname = mid ++ ";" ++ fname+  updateState (\st -> st {funName = xfname})+  fexpr <- pExpr+  semi tkp+  return $ CoreFunc {+    coreFuncName = xfname,+    coreFuncArgs = fargs,+    coreFuncBody = fexpr}++-- Typed constants. They have format (value :: TYPE) where TYPE may be+-- Int | Integer | Float | Double++pTypConst = try $ parens tkp (tyFloat <|> tyInt) >>= return++tyInt = try $ do+  n <- integer tkp+  reserved tkp "::"+  t <- many1 letter+  case t of+    "Int" -> return $ CoreLit (CoreInt $ fromIntegral n)+    "Integer" -> return $ CoreLit (CoreInteger n)+    _ -> fail "tyInt"+  +tyFloat = try $ do+  n <- float tkp+  reserved tkp "::"+  t <- many1 letter+  case t of+    "Float" -> return $ CoreLit (CoreFloat $ realToFrac n)+    "Double" -> return $ CoreLit (CoreDouble n)+    _ -> fail "tyFloat"+  ++-- General expression parsers.++pString = try $ do s <- stringLiteral tkp+                   return $ CoreLit (CoreStr s)++pChar = try $ do c <- charLiteral tkp+                 return $ CoreLit (CoreChr c)++pInt = try $ do n <- integer tkp +                return $ CoreLit (CoreInteger n)++pFloat = try $ do f <- float tkp+                  return $ CoreLit (CoreDouble f)++pVar = do i <- identifier tkp+          return $ CoreVar i++pQVar = try $ do q <- pQUALID+                 let cf = case q of+                       QCTOR c -> CoreCon c+                       QFUNC f -> CoreFun f+                 return cf++pParExpr = try $ parens tkp pExpr >>= return++pLetExpr = try $ do+  reserved tkp "let"+  bnds <- many1 pBind+  reserved tkp "in"+  e <- pExpr+  return $ coreLet bnds e++pBind = try $ do+  vn <- ident+  symbol tkp "="+  be <- pExpr+  semi tkp+  return (vn, be)++-- FATBAR means that some expression will be evaluated as a default of a CASE.++pFatBar = try $ do+  reserved tkp "let_" +  reserved tkp "_fatbar"+  symbol tkp "="+  fbexpr <- pExpr+  semi tkp+  reserved tkp "in"+  doCase (Just fbexpr)++-- This means that CASE reuses the currently bound FATBAR variable.+-- If no FATBAR has been specified, this is a pattern match failure.++pCase = doCase Nothing++-- Common part for all CASE constructions. If new FATBAR was introduced.+-- it creates a new binding for a "v_fail_N" variable. Otherwise+-- it just generates a CASE construction. If a stack is empty (only+-- 0 on top), failure expression will be bound to default failure+-- handler (which throws a pattern match exception).++doCase mbfb = try $ do+  reserved tkp "case"+  scrut <- pExpr+  reserved tkp "of"+  doCase' mbfb scrut++-- A new FATBAR binding was introduced: push it on the stack and+-- bind default pattern to it.++doCase' (Just fb) scrut = do+  cnt <- getCount+  updateState (\st -> st {fbStack = cnt : fbStack st})+  let failvar = "v_fail_" ++ show cnt+  cc <- doCase' Nothing scrut+  updateState (\st -> st {fbStack = tail (fbStack st)})+  return $ coreLet [(failvar, fb)] cc++-- No FATBAR was introduced. Use whatever is on the stack. If 0+-- is on the stack, bind default pattern to the default failure+-- handler, otherwise to the failure variable whose name is+-- determined by the stack contents.++doCase' Nothing scrut = do+  fbnum <- getState >>= return . head . fbStack+  fun <- getState >>= return . funName+  let failvar = "v_fail_" ++ show fbnum+  cpats <- braces tkp ((pConPat <|> pCharPat <|> pDefPat failvar) `sepBy1` semi tkp)+  let dflet = if fbnum == 0 then coreLet [(failvar, defFailExpr fun)] else id+      cc = CoreCase scrut cpats+  return $ dflet cc++-- Character literal pattern.++pCharPat = try $ do+  (CoreLit c) <- pChar+  symbol tkp "->"+  patexp <- pExpr+  return (PatLit {patLit = c}, patexp)++-- Default pattern is given a variable bound to a current FATBAR. If+-- no actual expression is specified to handle the default case,+-- FATBAR will be invoked.++pDefPat fv = try $ do+  symbol tkp "_"+  symbol tkp "->"+  defexp <- (try (symbol tkp "_fatbar" >> return Nothing)) <|> (pExpr >>= return . Just)+  let patexp = fromMaybe (CoreVar fv) defexp+  return (PatDefault, patexp)++-- Conctructor pattern takes care that the name given corresponds to+-- a constructor.++pConPat = try $ do+  q <- pQUALID+  cargs <- many ident+  symbol tkp "->"+  patexp <- pExpr+  case q of+    QCTOR c -> return (PatCon {patCon = c, patVars = cargs}, patexp)+    _ -> pzero++-- A simple expression: one that does not include function application,+-- or a parenthesized expression (i. e. with one term at tolevel)++pSmpExpr = pString <|> pChar <|> pTypConst <|> pFloat <|> +           pInt <|> pQVar <|> pVar <|> pLetExpr <|>+           pCase <|> pFatBar <|> pParExpr++-- Toplevel expression that may be an application++pExpr :: GenParser Char PState CoreExpr++pExpr = try $ do (f:es) <- many1 pSmpExpr+                 return $ coreApp f es++-- Default failure expression+-- Prelude.throw (Hugs.Prelude.PatternMatchFail fun)++defFailExpr fun = +  let failmsg = "pattern match failure in function " ++ fun+      primthrow = CoreFun "Hugs.Prelude;throw"+      exctor = CoreCon "Hugs.Prelude;PatternMatchFail"+      litstr = CoreLit (CoreStr failmsg)+  in  coreApp primthrow [coreApp exctor [litstr]]++-- Calling this function returns the current unique value counter+-- and increments the counter.++getCount = do cnt <- getState >>= return . counter+              updateState (\st -> st {counter = cnt + 1})+              return $ cnt + 1++++
+ Yhc/Core/FrontEnd/Hugs/PrimTable.hs view
@@ -0,0 +1,125 @@+-- Table of Hugs primitives mapped into Yhc Core normal primitives.+-- Primitives initially in Hugs.Peelude are expected to have been mapped+-- to Prelude before.++module Yhc.Core.FrontEnd.Hugs.PrimTable (hugsPrimTable) where++import Yhc.Core.Extra++-- |Table of Hugs primitives mapped to the Normal Set of primitives.++hugsPrimTable :: [(CoreFuncName, CoreFuncName)]++hugsPrimTable = normPrims++normPrims = [+  ("Prelude;primPlusInt", "ADD_W")+ ,("Prelude;primPlusInteger", "ADD_L")+ ,("Prelude;primPlusFloat", "ADD_F")+ ,("Prelude;primPlusDouble", "ADD_D")+ ,("Prelude;primMinusInt", "SUB_W")+ ,("Prelude;primMinusInteger", "SUB_L")+ ,("Prelude;primMinusFloat", "SUB_F")+ ,("Prelude;primMinusDouble", "SUB_D")+ ,("Prelude;primMulInt", "MUL_W")+ ,("Prelude;primMulInteger", "MUL_L")+ ,("Prelude;primMulFloat", "MUL_F")+ ,("Prelude;primMulDouble", "MUL_D")+ ,("Prelude;primNegInt", "NEG_W")+ ,("Prelude;primNegInteger", "NEG_L")+ ,("Prelude;primNegFloat", "NEG_F")+ ,("Prelude;primNegDouble", "NEG_D")+ ,("Prelude;primCmpInt", "CMP_W")+ ,("Prelude;primCmpInteger", "CMP_L")+ ,("Prelude;primCmpChar", "CMP_C")+ ,("Prelude;primCmpFloat", "CMP_F")+ ,("Prelude;primCmpDouble", "CMP_D")+ ,("Prelude;primEqInt", "EQ_W")+ ,("Prelude;primEqInteger", "EQ_L") + ,("Prelude;primEqFloat", "EQ_F")+ ,("Prelude;primEqChar", "EQ_C")+ ,("Prelude;primEqDouble", "EQ_D")+ ,("Prelude;primDivFloat", "DIV_F")+ ,("Prelude;primDivDouble", "DIV_D")+ ,("Prelude;primIntToInteger", "CAST_WL")+ ,("Prelude;primIntegerToInt", "CAST_LW")+ ,("Prelude;primIntToDouble", "CAST_WD")+ ,("Prelude;primIntToFloat", "CAST_WF")+ ,("Prelude;primIntegerToDouble", "CAST_LD")+ ,("Prelude;primIntegerToFloat", "CAST_LF")+ ,("Prelude;primDoubleToFloat", "CAST_DF")+ ,("Prelude;primRationalToDouble", "CAST_RD")+ ,("Prelude;primRationalToFloat", "CAST_RF")+ ,("Prelude;primCharToInt", "CAST_CW")+ ,("Prelude;primIntToChar", "CAST_WC")+ ,("Prelude;primQuotInt", "QUOT_W")+ ,("Prelude;primRemInt", "REM_W")+ ,("Prelude;primDivInt", "DIV_W")+ ,("Prelude;primModInt", "MOD_W")+ ,("Prelude;primQuotInteger", "QUOT_L")+ ,("Prelude;primRemInteger", "REM_L")+ ,("Prelude;primDivInteger", "DIV_L")+ ,("Prelude;primModInteger", "MOD_L")+ ,("Prelude;primMaxInt", "MAX_W")+ ,("Prelude;primMinInt", "MIN_W")+ ,("Prelude;primMaxChar", "MAX_C")+ ,("Prelude;primIsUpper", "ISUPR_C")+ ,("Prelude;primIsLower", "ISLOW_C")+ ,("Prelude;primIsAlpha", "ISALP_C")+ ,("Prelude;primIsAlphaNum", "ISALN_C")+ ,("Prelude;primIsPrint", "ISPRT_C")+ ,("Prelude;toUpper", "TOUPR_C")+ ,("Prelude;toLower", "TOLOW_C")+ ,("Prelude;isUpper", "ISUPR_C")+ ,("Prelude;isLower", "ISLOW_C")+ ,("Prelude;isAlpha", "ISALP_C")+ ,("Prelude;isAlphaNum", "ISALN_C")+ ,("Prelude;isPrint", "ISPRT_C")+ ,("Hugs.Char;toUpper", "TOUPR_C")+ ,("Hugs.Char;toLower", "TOLOW_C")+ ,("Hugs.Char;toTitle", "TOTIT_C")+ ,("Hugs.Char;primUniGenCat", "UCAT_C")+ ,("Prelude;primSinFloat", "SIN_F")+ ,("Prelude;primCosFloat", "COS_F")+ ,("Prelude;primTanFloat", "TAN_F")+ ,("Prelude;primAsinFloat", "ASIN_F")+ ,("Prelude;primAcosFloat", "ACOS_F")+ ,("Prelude;primAtanFloat", "ATAN_F")+ ,("Prelude;primLogFloat", "LOG_F")+ ,("Prelude;primExpFloat", "EXP_F")+ ,("Prelude;primSqrtFloat", "SQRT_F")+ ,("Prelude;primSinDouble", "SIN_D")+ ,("Prelude;primCosDouble", "COS_D")+ ,("Prelude;primTanDouble", "TAN_D")+ ,("Prelude;primAsinDouble", "ASIN_D")+ ,("Prelude;primAcosDouble", "ACOS_D")+ ,("Prelude;primAtanDouble", "ATAN_D")+ ,("Prelude;primLogDouble", "LOG_D")+ ,("Prelude;primExpDouble", "EXP_D")+ ,("Prelude;primSqrtDouble", "SQRT_D")+ ,("Prelude;primFloatRadix", "RADIX_F")+ ,("Prelude;primFloatDigits", "DIGITS_F")+ ,("Prelude;primFloatMinExp", "MINEXP_F")+ ,("Prelude;primFloatMaxExp", "MAXEXP_F")+ ,("Prelude;primFloatEncode", "ENC_F")+ ,("Prelude;primFloatDecode", "DEC_F")+ ,("Prelude;primDoubleRadix", "RADIX_F")+ ,("Prelude;primDoubleDigits", "DIGITS_D")+ ,("Prelude;primDoubleMinExp", "MINEXP_D")+ ,("Prelude;primDoubleMaxExp", "MAXEXP_D")+ ,("Prelude;primDoubleEncode", "ENC_D")+ ,("Prelude;primDoubleDecode", "DEC_D")+ ,("Prelude;primQrmInt", "QRM_W")+ ,("Prelude;primQrmInteger", "QRM_L")+ ,("Prelude;$!", "STRICT_APP")+ ,("Prelude;_SEL", "SEL_ELEM")+ ,("Prelude;primShowsInt", "SHOWS_W")+ ,("Prelude;primShowsInteger", "SHOWS_L")+ ,("Prelude;primShowsDouble", "SHOWS_D")+ ,("Prelude;primShowsFloat", "SHOWS_F")+ ,("Prelude;seq", "SEQ")+ ,("Prelude;throw", "THROW_E")+ ,("Prelude;_concmp", "CMP_T")]+++
+ Yhc/Core/FrontEnd/Hugs/UnDict.hs view
@@ -0,0 +1,80 @@+-- Dereferencing of dictionary-based calls in Hugs-produced Yhc Core.+++module Yhc.Core.FrontEnd.Hugs.UnDict where++import Data.List+import Data.Maybe+import Yhc.Core.Extra++-- |Given function name, find out whether it is possibly a dictionary,+-- A successful candidate has zero arity and body consisting of only data constructor+-- applied to a saturating (>0) number of arguments. No let ... in, therefore all+-- constructor's arguments will point outside, no closures. If test is passed,+-- constructor name, and list of arguments will be returned, otherwise an empty+-- string and empty list will be returned.++possiblyDict :: Core -> CoreFuncName -> (CoreCtorName, [CoreExpr])++possiblyDict core fn = x+  where+    nodict = ("", [])+    unpos (CorePos _ e) = unpos e+    unpos e = e+    x = case coreFuncMaybe core fn of+      Just func@CoreFunc {coreFuncArgs = []} ->+        case unpos (coreFuncBody func) of+          CoreApp (CoreCon con) cargs -> +            case coreCtorMaybe core con of+              Just CoreCtor {coreCtorFields = cfs} | length cargs == length cfs+                -> (con, cargs)+              _ -> nodict+          _ -> nodict+      _ -> nodict++-- |This function eliminates a "dictionary pattern". The dictionary pattern+-- is an application of a selector function to a dictionary (that is, selection+-- of a data field) where data field contains a function name or a constructor name.+-- Overloaded funcitons such as "Prelude.*" are in fact selectors from given dictionaries.+-- Applications of a selector function to a dictionary yields another function+-- which may or may not be a selector again, to be applied to the subsequent arguments.+-- Elimination of such pattern statically gives benefits of one runtime dereference +-- removal, plus strictness analysis will be more accurate since strictness cannot +-- be seen through dictionaries. It is recommended to apply the following transformations+-- to Core prior to this one: coreCaseElim . coreSimplify . unLiftCtors . removeRecursiveLet.++unDict :: Core -> Core++unDict core = transformExpr (f core) core where+  f core x@(CoreApp (CoreFun sel) ((CoreFun dict):rest)) = +    let pblsel = coreSelectorIndex core sel+        pbldict = possiblyDict core dict+    in  case (pblsel, pbldict) of+          ((dctn, idx), (dctr, exprs))+            | null dctn || null dctr -> x+            | dctn /= dctr -> x+            | otherwise -> let e = exprs !! idx in case e of+                CoreCon _ -> CoreApp e rest+                CoreFun _ -> CoreApp e rest+                CoreApp y z -> CoreApp (f core e) rest+                _ -> x+  f core x@(CoreApp (CoreFun sel) [y]) = +    let pblsel = coreSelectorIndex core sel+    in  case pblsel of+          (dctn, idx) | (not . null) dctn && idx >= 0 ->+                        CoreApp (CoreFun "SEL_ELEM") +                                [CoreCon dctn, y, CoreLit $ CoreInt (idx + 1)]+                      | otherwise -> x+  f core x@(CoreApp (CoreFun sel) (y:ys)) = +    let pblsel = coreSelectorIndex core sel+    in  case pblsel of+          (dctn, idx) | (not . null) dctn && idx >= 0 ->+                        CoreApp (CoreApp (CoreFun "SEL_ELEM") +                                 [CoreCon dctn, y, CoreLit $ CoreInt (idx + 1)]) ys+                      | otherwise -> x++  f _ x = x++++
+ hugs2yc.cabal view
@@ -0,0 +1,33 @@+Cabal-Version:      >= 1.2+Name:               hugs2yc+Version:            0.1+Copyright:          2008, Dmitry Golubovsky and The Yhc Team+Maintainer:         golubovsky@gmail.com+Homepage:           http://www.haskell.org/haskellwiki/Yhc+License:            BSD3+License-File:       LICENSE+Build-Type:         Simple+Author:             Dmitry Golubovsky+Synopsis:           Hugs Front-end to Yhc Core.+Description:+    A converter of Hugs Core output to Yhc Core format for further conversion by a back-end.+Category:           Development++Flag splitBase+    Description: Choose the new smaller, split-up base package.++Library+    if flag(splitBase)+        build-depends: base >= 3, mtl, containers+    else+        build-depends: base < 3, mtl+    build-depends: mtl, uniplate, yhccore, ycextra, +                   parsec, directory, filepath++    Exposed-modules:+        Yhc.Core.FrontEnd.Hugs +    Other-modules:+        Yhc.Core.FrontEnd.Hugs.ParseUtil, Yhc.Core.FrontEnd.Hugs.UnDict,+        Yhc.Core.FrontEnd.Hugs.LinkUtil, Yhc.Core.FrontEnd.Hugs.PrimTable++