diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Yhc/Core/FrontEnd/Hugs.hs b/Yhc/Core/FrontEnd/Hugs.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/FrontEnd/Hugs.hs @@ -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 + + diff --git a/Yhc/Core/FrontEnd/Hugs/LinkUtil.hs b/Yhc/Core/FrontEnd/Hugs/LinkUtil.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/FrontEnd/Hugs/LinkUtil.hs @@ -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 + diff --git a/Yhc/Core/FrontEnd/Hugs/ParseUtil.hs b/Yhc/Core/FrontEnd/Hugs/ParseUtil.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/FrontEnd/Hugs/ParseUtil.hs @@ -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 + + + + diff --git a/Yhc/Core/FrontEnd/Hugs/PrimTable.hs b/Yhc/Core/FrontEnd/Hugs/PrimTable.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/FrontEnd/Hugs/PrimTable.hs @@ -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")] + + + diff --git a/Yhc/Core/FrontEnd/Hugs/UnDict.hs b/Yhc/Core/FrontEnd/Hugs/UnDict.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/FrontEnd/Hugs/UnDict.hs @@ -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 + + + + diff --git a/hugs2yc.cabal b/hugs2yc.cabal new file mode 100644 --- /dev/null +++ b/hugs2yc.cabal @@ -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 + +